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.
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 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.
The -syn (--check-syntax) flag may be used with all source and destination streams except for standard input and output. However data streams which are not associated with a filename will be copied to a temporary file before being passed to Perl. This use of temporary files can cause somewhat confusing output from Perl.
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 formatter feature is relatively new in perltidy, and further documentation needs to be written to complete its description. However, several example programs have been written and can be found in the examples section of the source distribution. Probably the best way to get started is to find one of the examples which most closely matches your application and start modifying it.
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 write_debug_entry in Tidy.pm.
&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 20210717
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.
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.
The source code repository is at https://github.com/perltidy/perltidy.
The perltidy(1) man page describes all of the features of perltidy. It can be found at http://perltidy.sourceforge.net.
Perl-Tidy-20210717/docs/BugLog.html 0000644 0001750 0001750 00000562642 14074553005 015645 0 ustar steve steveTesting 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.
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-20210717/docs/index.html 0000644 0001750 0001750 00000006161 14074553005 015562 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 2 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 sytems 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-20210717/docs/index.md 0000644 0001750 0001750 00000005267 14064634531 015227 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 2 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 sytems 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-20210717/docs/perltidy.html 0000644 0001750 0001750 00000662203 14074553005 016314 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.
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".
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 -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.
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 -o=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.
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 -pbp (--perl-best-practices) flag, then you must put a -nst flag after the -pbp flag because it contains a -st 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> F<.bak> Keep (same as the default behavior)
<-bext='/'> F<.bak> Delete if no errors
<-bext='/backup'> F<.backup> Delete if no errors
<-bext='original/'> F<.original> Delete if no errorsSetting -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.
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 treate the words 'method', 'fun', '_sub' and 'M4' to be treated 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 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.
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 vary 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 -vmll and -wc=n provides a solution to the problem of displaying arbitrarily deep data structures and code in a finite window, although -wc=n may of course be used without -vmll.
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 -fws). If you have any tabs in your comments, quotes, or here-documents, they will remain.
This flag causes each n initial space characters to be replaced by one tab character.
The value of the integer n can be any value but can be coordinated with the number of spaces used for intentation. 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.
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 -lp option. This flag is retained for backwards compatibility, but if you use tabs, the -et=n flag is recommended.
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).
A problem with formatting Perl code is that some modules can introduce new syntax. 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 and the braces would not be balanced:
method deposit( Num $amount) {
$self->balance( $self->balance + $amount );
}For one of the extensions, module Switch::Plain, colons are marked as labels. If you use this module, you may want to also use the --nooutdent-labels flag to prevent lines such as 'default:' from being outdented.
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.
For another method of handling extended syntax see the section "Skipping Selected Sections of Code".
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 -noll or -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 the character encoding, if any, of the input data stream. Perltidy does not look for the encoding directives in the soure stream, such as use utf8, and instead relies on this flag to determine the encoding. (Note that perltidy often works on snippets of code rather than complete files so it cannot rely on use utf8 directives).
The possible values for s are (1) the name of an encoding recognized by the Encode.pm module, (2) none if no encoding is used, or (3) <guess> if perltidy should guess.
For example, the value utf8 causes the stream to be read and written as UTF-8. If the input stream cannot be decoded with a specified encoding then processing is not done.
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 guess tells perltidy to guess between either utf8 encoding or no encoding (meaning one character per byte). The guess uses the Encode::Guess module and this restricted range of guesses covers the most common cases. Testing showed that considering any greater number of encodings as guess suspects is too risky.
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.pl
To process a file in euc-jp you could use
perltidy -enc=euc-jp file.plA perltidy output file is unencoded if the input file is unencoded, and otherwise it is encoded as utf8, even if the input encoding was not utf8.
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 beautification 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. For all practical purposes one either does or does not want to be sure that the output is converged, and there is no penalty to using a large iteration limit since 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, -ola, and control 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 multi-line 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
)
)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 peltidy 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.
By default, 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'
);Use the -lp flag to 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
@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.
This option has no effect on code BLOCKS, such as if/then/else blocks, which always use whatever is specified with -i=n.
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.
In addition, any parameter which significantly restricts the ability of perltidy to choose newlines will conflict with -lp and will cause -lp to be deactivated. These include -io, -fnl, -nanl, and -ndnl. The reason is that the -lp indentation style can require the careful coordination of an arbitrary number of break points in hierarchical lists, and these flags may prevent that.
The -lp option may not be used together with the -t tabs option. It may, however, be used with the -et=n tab method.
This is an experimental parameter; the details might change as experience with it is gained.
The -lp indentation style works well for some types of coding but can produce very long lines when variables have long names and/or containers are very deeply nested. The -lpxl=s flag is intended to help mitigate this problem by providing control over the containers to which the -lp indentation style is applied. The -lp flag by default is "greedy" and applies to as many containers as possible. This flag specifies a list of things which should not be use -lp indentation.
This list 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
-lpxl='[ {'means do NOT include use -lp formatting within square-bracets or braces. The only unspecified container is '(', so this string means that only the contents within parens will use -lp indentation.
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 check on contents
'1' reject -lp unless the contents is a simple list without sublists
'2' reject -lp unless the contents is a simple list without sublists, without
code blocks, and without ternary operatorsFor example,
-lpxl = '[ { (2'means only apply -lp to parenthesized lists which do not contain any sublists, code blocks or ternary expressions.
A third optional item of information which can be given for parens 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:
'k' matches if the previous nonblank token is a perl builtin keyword (such as 'if', 'while'),
'K' matches if 'k' does not, meaning that 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.For example,
-lpxl = '[ { F(2'means only apply -lp to parenthesized lists which follow a function call and which do not contain any sublists, code blocks or ternary expressions. The logic of writing these codes is somewhat counter-intuitive because they describe what is not getting the -lp indentation. So the 'F' indicates that non-function calls are not getting -lp, or in other words that function calls are getting the -lp indentation.
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 -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.
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 appending pre-pending 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 or --nooutdent-long-lines.
This command is equivalent to --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 2 spaces (or whatever -ci has been set to), if possible. This is the default. For example:
my $i;
LOOP: while ( $i = <FOTOS> ) {
chomp($i);
next unless $i;
fixit($i);
}Use -nola to not outdent labels.
The command -okw will cause certain leading control keywords to be outdented by 2 spaces (or whatever -ci has been set to), 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);
}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. It is probably simplest to place any -okwl command in a .perltidyrc file.
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=2 Curly 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.
%bf = map { $_ => -M $_ } grep { /\.deb$/ } dirents '.'; # -bbt=0 (default)
%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>.
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 -fws to leave whitespace completely unchanged).
Setting this option allows perltidy to remove some old whitespace between characters, if necessary. This is the default. If you do not want any old whitespace removed, use -ndws or --nodelete-old-whitespace.
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.
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 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 $SEVERITY_LOWEST+1 .. $SEVERITY_HIGHEST ) { ... }
# perltidy default, syntax ok
for my $severity ( reverse $SEVERITY_LOWEST + 1 .. $SEVERITY_HIGHEST ) { ... }But the following will give a syntax error:
# perltidy -nwrs='+', syntax error:
for my $severity ( reverse $SEVERITY_LOWEST +1 .. $SEVERITY_HIGHEST ) { ... }To avoid subtle parsing problems like this, it is best to avoid spacing a binary operator asymetrically 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 and or xor eq ne if else elsif until unless
while for foreach return switch case given whenThese 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 reason this is not recommended is that 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]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 the -kpit=n command 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 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 multi-line qw quotes and indenting them appropriately.
-ntqw or --notrim-qw cause leading and trailing whitespace around multi-line 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.
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 version as wellwhereas without the -iscl flag the line will be broken:
perltidy -l=80
$vmsfile =~ s/;[\d\-]*$//
; # Clip off version number; we can use a newer version as well
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 any -csc or -dcsc operation:
-cscl="sub : BEGIN END"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 2 spaces (or whatever -ci=n has been set to), 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 will pass this verbatim without error checking
token ident_digit {
[ [ <?word> | _ | <?digit> ] <?ident_digit>
| <''>
]
};
#>>VAdditional text may appear on the special comment lines provided that it is separated from the marker by at least one space, as in the above examples.
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'.
The parameters in this section control breaks after non-blank lines of code. Blank lines are controlled separately by parameters in the section "Blank Line Control".
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 -noll with this.
Note: If you also want to keep your blank lines exactly as they are, you can use the -fbl 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 -cbl, 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 -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 -ce 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 -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,grep Note 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 -cbl flag by itself merely specifies which blocks are formatted with the cuddled format. It has no effect unless this formatting style is activated with -ce.
When cuddled else formatting is selected with -ce, setting this flag causes perltidy to ignore its built-in defaults and rely exclusively on the block types specified on the -cbl flag described in the previous section. For example, to avoid using cuddled catch and finally, which among in 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 the opening brace on a new line:
if ( $input_file eq '-' ) # -bl
{
important_function();
}This flag applies to all structural blocks, including named sub's (unless the -sbl flag is set -- see next item).
The default style, -nbl, places an opening brace on the same line as the keyword introducing it. For example,
if ( $input_file eq '-' ) { # -nbl (default)The flag -sbl can be used to override the value of -bl for the opening braces of named sub's. For example,
perltidy -sblproduces this result:
sub message
{
if (!defined($_[0])) {
print("Hello, World\n");
}
else {
print($_[0], "\n");
}
}This flag is negated with -nsbl. If -sbl is not specified, the value of -bl is used.
The flag -asbl is like the -sbl flag except that it applies to anonymous sub's instead of named subs. For example
perltidy -asblproduces this result:
$a = sub
{
if ( !defined( $_[0] ) ) {
print("Hello, World\n");
}
else {
print( $_[0], "\n" );
}
};This flag is negated with -nasbl, and the default is -nasbl.
The flag -bli is the same as -bl but in addition it causes one unit of continuation indentation ( see -ci ) to be placed before an opening and closing block braces.
For example,
if ( $input_file eq '-' ) # -bli
{
important_function();
}By default, this extra indentation occurs for blocks of type: if, elsif, else, unless, for, foreach, sub, while, until, and also with a preceding label. The next item shows how to change this.
Use this parameter to change the types of block braces for which the -bli flag applies; see "Specifying Block Types". For example, -blil='if elsif else' would apply it to only if/elsif/else blocks.
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 -bl and -bar are specified.
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 levelThe -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.
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 -conv 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->numify() ) & $sy * int( $yr->numify() )
)
),
$m
)
);
# perltidy -wn
$x->badd( bmul(
$class->new( abs(
$sx * int( $xr->numify() ) & $sy * int( $yr->numify() )
) ),
$m
) );The welded closing tokens are by default on a separate line but this can be modified with the -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->numify() ) & $sy * int( $yr->numify() ) ) ),
$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.
Another limitation is that an opening symbol which delimits quoted text cannot be included in a welded pair. This is because quote delimiters are treated specially in perltidy.
Finally, the stacking of containers defined by this flag have priority over any other container stacking flags. This is because any welding is done first.
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-bracets, 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 builtin keyword (such as 'if', 'while'),
'K' matches if 'k' does not, meaning that 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.For example, compare
# perltidy -wn
if ( defined( $_Cgi_Query{
$Config{'methods'}{'authentication'}{'remote'}{'cgi'}{'username'}
} ) )with
# perltidy -wn -wnxl='^K( {'
if ( defined(
$_Cgi_Query{ $Config{'methods'}{'authentication'}{'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
'.(' - the second and later tokens may not be parens
'.w(' - the second and later tokens may not keyword or function 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 everything 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 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 -lp 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 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 -scbb.
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 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 -sot -sct.
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 -sot and -sct flags do.
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.
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 bl 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 -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.
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 important information. If we place a side comment on one of the lines, for example, we get the following result with with default formatting parameters:
my @list = (
1, # a side comment, comment, or blank keeps list intact
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.
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 is that all tables in the file must already be nicely formatted.
If the computed number of fields for any table exceeds n, then it will be reduced to n. The default value for n is a large number, 40. While this value should probably be left unchanged as a general rule, it 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 single comment could be introduced somewhere to freeze the formatting in future applications of perltidy.
# perltidy -mft=2
@month_of_year = (
'Jan', 'Feb',
'Mar', 'Apr',
'May', 'Jun',
'Jul', 'Aug',
'Sep', 'Oct',
'Nov', 'Dec'
);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
);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_Shell) || &prompt('|');
# perltidy -bol [default]
return
unless $cmd = $cmd
|| ( $dot
&& $Last_Shell )
|| &prompt('|');
# perltidy -nbol
return unless $cmd = $cmd || ( $dot && $Last_Shell ) || &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 preformatted a method chain:
my $q = $rs
->related_resultset('CDs')
->related_resultset('Tracks')
->search({
'track.id' => {-ident => 'none_search.id'},
})->as_query;It will keep these breaks, rather than become this:
my $q = $rs->related_resultset('CDs')->related_resultset('Tracks')->search({
'track.id' => {-ident => 'none_search.id'},
})->as_query;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 -wn
my $q = $rs->related_resultset(
'CDs'
)->related_resultset(
'Tracks'
)->search( {
'track.id' => { -ident => 'none_search.id' },
} )->as_query;You may want to include the -weld-nested-containers flag in this case to keep nested braces and parens together, as in the last line.
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 );The result using perltidy -bos keeps the isolated semicolon:
$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.
Two command line parameters provide detailed control over whether perltidy should keep an old line break before or after a specific token type:
-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, @_ );
...;
};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.
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 -kbl=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 -blbp and -blbs parameters. If n=0 then no blank lines will be output (unless all old blank lines are retained with the -kbl=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 value of the B<-mbl=n> flag
n=2 keep all old blank lines, regardless of the value of the B<-mbl=n> flagThe default is n=1.
This is equivalent to kbl=0 and is included for compatibility with previous versions.
This is equivalent to kbl=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. 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)
-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 orignial 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 -icp-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 and -se 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 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$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$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$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.
There are a few points to note regarding one-line blocks. A one-line block is something like this,
where the contents within the curly braces is short enough to fit on a single line.
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 one-line block style of the input file.
If an existing one-line block is longer than the maximum line length, however, it will be broken into multiple lines. When this happens, perltidy checks for and adds any optional terminating semicolon (unless the -nasc option is used) if the block is a code block.
The main exception is that perltidy will attempt to form new one-line blocks following the keywords map, eval, and sort, because these code blocks are often small and most clearly displayed in a single line.
One-line block rules can conflict with the cuddled-else option. When the cuddled-else option is used, perltidy retains existing one-line blocks, even if they do not obey cuddled-else formatting.
Occasionally, when one-line blocks get broken because they exceed the available line length, the formatting will violate the requested brace style. If this happens, reformatting the script a second time should correct the problem.
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.
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 one-line blocks having a single statement
n=1 stable; keep input file placement of 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.
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.
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 -novalign, a flag mainly intended for debugging. 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'
);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.)
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. Instructions for Windows 95 and later versions can be found here:
http://www.netmanage.com/000/20021101_005_tcm21-6336.pdf
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 are:
-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.
The commands --dump-options, --dump-defaults, --dump-long-names, and --dump-short-names, all described below, may all be helpful.
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 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 -dac to reduce the file size of a perl script.
The following flags are available for debugging:
--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-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.
--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 useful during program development, when large numbers of files with varying sizes are processed, because it can reduce virtual memory usage.
--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 only applies to files specified by filename on the command line.
--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.
-DEBUG will write a file with extension .DEBUG for each input file showing the tokenization of all lines of code.
The first $VERSION line of a file which might be eval'd by MakeMaker is passed through unchanged except for indentation. 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. 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. Use --nolook-for-selfloader, or -nlsl, to deactivate this feature.
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.
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=s where '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
quite, 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 anl asbl asc ast asu atnl aws b baa
baao bar bbao bbb bbc bbs bl bli boa boc
bok bol bom bos bot cblx ce conv cs csc
cscb cscw dac dbc dcbl dcsc ddf dln dnl dop
dp dpro dsc dsm dsn dtt dwls dwrs dws f
fll 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 iob isbc
iscl kgb kgbd kgbi kis lal log lop lp lsl
mem nib ohbr okw ola olc oll olq opr opt
osbc osbr otr ple pod pvl q 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 vmll w
wn x xci 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 20210717
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.
The source code repository is at https://github.com/perltidy/perltidy.
Copyright (c) 2000-2021 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-20210717/docs/stylekey.html 0000644 0001750 0001750 00000075540 14074553005 016333 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.
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.
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 with one tab character for each n spaces, use -et=n. Typically, n would be 8.
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 speces (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.
If you prefer the first (default) scheme, no parameter is needed.
If you prefer the latter scheme, use -lp.
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_sumething_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.
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=2 For 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 ); # default If 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=1There is a graphical program called tidyview which you can use to read a preliminary .perltidyrc file, make trial adjustments and immediately see their effect on a test file, and then write a new .perltidyrc. You can download a copy at
http://sourceforge.net/projects/tidyview
This document has covered the main parameters. Many more parameters are available for special purposes and for fine-tuning a style. For complete information see the perltidy manual http://perltidy.sourceforge.net/perltidy.html
For an introduction to using perltidy, see the tutorial http://perltidy.sourceforge.net/tutorial.html
Suggestions for improving this document are welcome and may be sent to perltidy at users.sourceforge.net
Perl-Tidy-20210717/docs/ChangeLog.html 0000644 0001750 0001750 00000453374 14074553005 016316 0 ustar steve steve- 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 simmilar 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. Prevously 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 experession:
# 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
rhe 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 configuation 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 alignement 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 formated.
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 additinal 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 matricies, 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 opton.
-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 );There is no fixed rule for setting the value for -ci=n, but it should probably not exceed one-half of the number of spaces of a full indentation level.
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 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.plYou 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. 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";
}The -lp parameter can enhance the readability of lists by adding extra indentation. Consider:
%romanNumerals = (
one => 'I',
two => 'II',
three => 'III',
four => 'IV',
five => 'V',
six => 'VI',
seven => 'VII',
eight => 'VIII',
nine => 'IX',
ten => 'X'
);With the -lp flag, this is formatted as:
%romanNumerals = (
one => 'I',
two => 'II',
three => 'III',
four => 'IV',
five => 'V',
six => 'VI',
seven => 'VII',
eight => 'VIII',
nine => 'IX',
ten => 'X'
);which is preferred by some. (I've actually used -lp and -cti=1 to format this block. The -cti=1 flag causes the closing paren to align vertically with the opening paren, which works well with the -lp indentation style). An advantage of -lp indentation are that it displays lists nicely. A disadvantage is that deeply nested lists can require a long line length.
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.
One last topic that needs to be touched upon concerns the .LOG file. This is where perltidy records messages that are not normally of any interest, but which just might occasionally be useful. This file is not saved, though, unless perltidy detects that it has made a mistake or you ask for it to be saved.
There are a couple of ways to ask perltidy to save a log file. To create a relatively sparse log file, use
perltidy -log testfile.pland for a verbose log file, use
perltidy -g testfile.plThe difference is that the first form only saves detailed information at least every 50th line, while the second form saves detailed information about every line.
So returning to our example, lets force perltidy to save a verbose log file by issuing the following command
perltidy -g testfile.plYou will find that a file named testfile.pl.LOG has been created in your directory.
If you open this file, you will see that it is a text file with a combination of warning messages and informative messages. All you need to know for now is that it exists; someday it may be useful.
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.
If you have some tips for making perltidy work with your editor, and are willing to share them, please email me (see below) and I'll try to incorporate them in this document or put up a link to them.
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.
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 (unfortunately) 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
------------And in the future, there may be more output filters. 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
Many additional special features and capabilities can be found in the manual pages for perltidy at http://perltidy.sourceforge.net/perltidy.html
We hope that perltidy makes perl programming a little more fun. Please check the perltidy web site http://perltidy.sourceforge.net occasionally for updates.
The author may be contacted at perltidy at users.sourceforge.net.
Perl-Tidy-20210717/META.yml 0000664 0001750 0001750 00000001147 14074553103 014106 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 feature is relatively new in perltidy, and further
documentation needs to be written to complete its description. However,
several example programs have been written and can be found in the
B section of the source distribution. Probably the best way
to get started is to find one of the examples which most closely matches
your application and start modifying it.
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 in Tidy.pm.
=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 20210717
=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
A list of current bugs and issues can be found at the CPAN site L
To report a new bug or problem, use the link on this page.
The source code repository is at L.
=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-20210717/lib/Perl/Tidy/ 0002755 0001750 0001750 00000000000 14074553103 015213 5 ustar steve steve Perl-Tidy-20210717/lib/Perl/Tidy/Logger.pm 0000644 0001750 0001750 00000045246 14073571552 017010 0 ustar steve steve #####################################################################
#
# The Perl::Tidy::Logger class writes the .LOG and .ERR files
#
#####################################################################
package Perl::Tidy::Logger;
use strict;
use warnings;
our $VERSION = '20210717';
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,
log_file => undef,
warning_file => undef,
fh_stderr => undef,
saw_extruce => undef,
display_name => undef,
is_encoded_data => undef,
);
my %args = ( %defaults, @args );
my $rOpts = $args{rOpts};
my $log_file = $args{log_file};
my $warning_file = $args{warning_file};
my $fh_stderr = $args{fh_stderr};
my $saw_extrude = $args{saw_extrude};
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
unless ( $fh_warnings || ref($warning_file) ) {
if ( -e $warning_file ) {
unlink($warning_file)
or Perl::Tidy::Die(
"couldn't unlink warning file $warning_file: $!\n");
}
}
my $logfile_gap =
defined( $rOpts->{'logfile-gap'} )
? $rOpts->{'logfile-gap'}
: 50;
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,
_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,
_saw_extrude => $saw_extrude,
_output_array => [],
_input_stream_name => $input_stream_name,
_filename_stamp => $filename_stamp,
}, $class;
}
sub get_input_stream_name {
my $self = shift;
return $self->{_input_stream_name};
}
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;
}
sub resume_logfile {
my $self = shift;
$self->write_logfile_entry( '#' x 60 . "\n" );
$self->{_use_prefix} = 1;
return;
}
sub we_are_at_the_last_line {
my $self = shift;
unless ( $self->{_wrote_line_information_string} ) {
$self->write_logfile_entry("Last line\n\n");
}
$self->{_at_end_of_file} = 1;
return;
}
# record some stuff in case we go down in flames
sub black_box {
my ( $self, $line_of_tokens, $output_line_number ) = @_;
my $input_line = $line_of_tokens->{_line_text};
my $input_line_number = $line_of_tokens->{_line_number};
# save line information in case we have to write a logfile message
$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) > 35 ) {
$out_str = substr( $out_str, 0, 35 ) . " ....";
}
$self->logfile_output( "", "$out_str\n" );
}
return;
}
sub write_logfile_entry {
my ( $self, @msg ) = @_;
# add leading >>> to avoid confusing error messages and code
$self->logfile_output( ">>>", "@msg" );
return;
}
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;
}
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 = "";
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 = "";
$extra_space .=
( $input_line_number < 10 ) ? " "
: ( $input_line_number < 100 ) ? " "
: "";
$extra_space .=
( $output_line_number < 10 ) ? " "
: ( $output_line_number < 100 ) ? " "
: "";
# 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 . " " 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;
}
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;
}
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 ) = @_;
#use constant BRACE_WARNING_LIMIT => 10;
my $BRACE_WARNING_LIMIT = 10;
my $saw_brace_error = $self->{_saw_brace_error};
if ( $saw_brace_error < $BRACE_WARNING_LIMIT ) {
$self->warning($msg);
}
$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;
}
sub complain {
# handle non-critical warning messages based on input flag
my ( $self, $msg ) = @_;
my $rOpts = $self->{_rOpts};
# these appear in .ERR output only if -w flag is used
if ( $rOpts->{'warning-output'} ) {
$self->warning($msg);
}
# otherwise, they go to the .LOG file
else {
$self->{_complaint_count}++;
$self->write_logfile_entry($msg);
}
return;
}
sub warning {
# report errors to .ERR file (or stdout)
my ( $self, $msg ) = @_;
#use constant WARNING_LIMIT => 50;
my $WARNING_LIMIT = 50;
# Always bump the warn count, even if no message goes out
Perl::Tidy::Warn_count_bump();
my $rOpts = $self->{_rOpts};
unless ( $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, my $filename ) =
Perl::Tidy::streamhandle( $warning_file, 'w', $is_encoded_data );
$fh_warnings or Perl::Tidy::Die("couldn't open $filename $!\n");
Perl::Tidy::Warn_msg("## Please see file $filename\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 = "";
$self->{_filename_stamp} = $filename_stamp;
}
}
if ( $self->get_use_prefix() > 0 ) {
$self->write_logfile_entry("WARNING: $msg");
# add prefix 'filename:line_no: ' to message lines
my $input_line_number =
Perl::Tidy::Tokenizer::get_input_line_number();
if ( !defined($input_line_number) ) { $input_line_number = -1 }
my $pre_string = $filename_stamp . $input_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 . " ";
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;
}
# programming bug codes:
# -1 = no bug
# 0 = maybe, not sure.
# 1 = definitely
sub report_possible_bug {
my $self = shift;
my $saw_code_bug = $self->{_saw_code_bug};
$self->{_saw_code_bug} = ( $saw_code_bug < 0 ) ? 0 : $saw_code_bug;
return;
}
sub report_definite_bug {
my $self = shift;
$self->{_saw_code_bug} = 1;
return;
}
sub ask_user_for_bug_report {
my ( $self, $infile_syntax_ok, $formatter ) = @_;
my $saw_code_bug = $self->{_saw_code_bug};
if ( ( $saw_code_bug == 0 ) && ( $infile_syntax_ok == 1 ) ) {
$self->warning(<{_saw_extrude} ) {
$self->warning(<warning(<get_added_semicolon_count();
};
if ( $added_semicolon_count > 0 ) {
$self->warning(<{_saw_code_bug};
my $rOpts = $self->{_rOpts};
return
$saw_code_bug == 1
|| $rOpts->{'logfile'}
|| $rOpts->{'check-syntax'};
}
sub finish {
# called after all formatting to summarize errors
my ( $self, $infile_syntax_ok, $formatter ) = @_;
my $rOpts = $self->{_rOpts};
my $warning_count = $self->{_warning_count};
my $saw_code_bug = $self->{_saw_code_bug};
my $save_logfile =
( $saw_code_bug == 0 && $infile_syntax_ok == 1 )
|| $saw_code_bug == 1
|| $rOpts->{'logfile'};
my $log_file = $self->{_log_file};
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");
$self->unblock_log_output();
}
if ( $self->{_complaint_count} > 0 ) {
$self->warning(
"To see $self->{_complaint_count} non-critical warnings rerun with -w\n"
);
}
if ( $self->{_saw_brace_error}
&& ( $self->{_logfile_gap} > 1 || !$save_logfile ) )
{
$self->warning("To save a full .LOG file rerun with -g\n");
}
}
$self->ask_user_for_bug_report( $infile_syntax_ok, $formatter );
if ($save_logfile) {
my $log_file = $self->{_log_file};
my $is_encoded_data = $self->{_is_encoded_data};
my ( $fh, $filename ) =
Perl::Tidy::streamhandle( $log_file, 'w', $is_encoded_data );
if ($fh) {
my $routput_array = $self->{_output_array};
foreach ( @{$routput_array} ) { $fh->print($_) }
if ( $log_file ne '-' && !ref $log_file ) {
eval { $fh->close() };
}
}
}
return;
}
1;
Perl-Tidy-20210717/lib/Perl/Tidy/VerticalAligner/ 0002755 0001750 0001750 00000000000 14074553103 020266 5 ustar steve steve Perl-Tidy-20210717/lib/Perl/Tidy/VerticalAligner/Line.pm 0000644 0001750 0001750 00000017307 14073571555 021533 0 ustar steve steve #####################################################################
#
# the Perl::Tidy::VerticalAligner::Line class supplies an object to
# contain a single output line
#
#####################################################################
package Perl::Tidy::VerticalAligner::Line;
use strict;
use warnings;
our $VERSION = '20210717';
BEGIN {
my $i = 0;
use constant {
_jmax_ => $i++,
_rtokens_ => $i++,
_rfields_ => $i++,
_rfield_lengths_ => $i++,
_rpatterns_ => $i++,
_indentation_ => $i++,
_leading_space_count_ => $i++,
_outdent_long_lines_ => $i++,
_list_seqno_ => $i++,
_list_type_ => $i++,
_is_hanging_side_comment_ => $i++,
_ralignments_ => $i++,
_maximum_line_length_ => $i++,
_rvertical_tightness_flags_ => $i++,
_is_terminal_ternary_ => $i++,
_j_terminal_match_ => $i++,
_end_group_ => $i++,
_Kend_ => $i++,
_ci_level_ => $i++,
_level_ => $i++,
_level_end_ => $i++,
_imax_pair_ => $i++,
};
}
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 <[_jmax_] = $ri->{jmax};
$self->[_rtokens_] = $ri->{rtokens};
$self->[_rfields_] = $ri->{rfields};
$self->[_rfield_lengths_] = $ri->{rfield_lengths};
$self->[_rpatterns_] = $ri->{rpatterns};
$self->[_indentation_] = $ri->{indentation};
$self->[_leading_space_count_] = $ri->{leading_space_count};
$self->[_outdent_long_lines_] = $ri->{outdent_long_lines};
$self->[_list_type_] = $ri->{list_type};
$self->[_list_seqno_] = $ri->{list_seqno};
$self->[_is_hanging_side_comment_] = $ri->{is_hanging_side_comment};
$self->[_maximum_line_length_] = $ri->{maximum_line_length};
$self->[_rvertical_tightness_flags_] = $ri->{rvertical_tightness_flags};
$self->[_is_terminal_ternary_] = $ri->{is_terminal_ternary};
$self->[_j_terminal_match_] = $ri->{j_terminal_match};
$self->[_end_group_] = $ri->{end_group};
$self->[_Kend_] = $ri->{Kend};
$self->[_ci_level_] = $ri->{ci_level};
$self->[_level_] = $ri->{level};
$self->[_level_end_] = $ri->{level_end};
$self->[_imax_pair_] = $ri->{imax_pair};
$self->[_ralignments_] = [];
return $self;
}
sub get_jmax { return $_[0]->[_jmax_] }
sub get_rtokens { return $_[0]->[_rtokens_] }
sub get_rfields { return $_[0]->[_rfields_] }
sub get_rfield_lengths { return $_[0]->[_rfield_lengths_] }
sub get_rpatterns { return $_[0]->[_rpatterns_] }
sub get_indentation { return $_[0]->[_indentation_] }
sub get_Kend { return $_[0]->[_Kend_] }
sub get_ci_level { return $_[0]->[_ci_level_] }
sub get_level { return $_[0]->[_level_] }
sub get_level_end { return $_[0]->[_level_end_] }
sub get_list_seqno { return $_[0]->[_list_seqno_] }
sub get_imax_pair { return $_[0]->[_imax_pair_] }
sub set_imax_pair {
my ( $self, $val ) = @_;
$self->[_imax_pair_] = $val;
return;
}
sub get_j_terminal_match {
return $_[0]->[_j_terminal_match_];
}
sub set_j_terminal_match {
my ( $self, $val ) = @_;
$self->[_j_terminal_match_] = $val;
return;
}
sub get_is_terminal_ternary {
return $_[0]->[_is_terminal_ternary_];
}
sub get_leading_space_count {
return $_[0]->[_leading_space_count_];
}
sub get_outdent_long_lines {
return $_[0]->[_outdent_long_lines_];
}
sub get_list_type { return $_[0]->[_list_type_] }
sub get_is_hanging_side_comment {
return $_[0]->[_is_hanging_side_comment_];
}
sub get_rvertical_tightness_flags {
return $_[0]->[_rvertical_tightness_flags_];
}
sub get_alignment {
my ( $self, $j ) = @_;
return $self->[_ralignments_]->[$j];
}
sub get_alignments { return @{ $_[0]->[_ralignments_] } }
sub get_column {
##my ( $self, $j ) = @_;
my $alignment = $_[0]->[_ralignments_]->[ $_[1] ];
return unless defined($alignment);
return $alignment->get_column();
}
sub set_alignments {
my ( $self, @args ) = @_;
@{ $self->[_ralignments_] } = @args;
return;
}
sub current_field_width {
my ( $self, $j ) = @_;
my $col_j = 0;
my $col_jm = 0;
my $alignment_j = $self->[_ralignments_]->[$j];
$col_j = $alignment_j->get_column() if defined($alignment_j);
if ( $j > 0 ) {
my $alignment_jm = $self->[_ralignments_]->[ $j - 1 ];
$col_jm = $alignment_jm->get_column() if defined($alignment_jm);
}
return $col_j - $col_jm;
}
sub increase_field_width {
my ( $self, $j, $pad ) = @_;
my $jmax = $self->[_jmax_];
foreach ( $j .. $jmax ) {
my $alignment = $self->[_ralignments_]->[$_];
if ( defined($alignment) ) {
$alignment->increment_column($pad);
}
}
return;
}
sub get_available_space_on_right {
my $jmax = $_[0]->[_jmax_];
return $_[0]->[_maximum_line_length_] - $_[0]->get_column($jmax);
}
sub set_jmax { my ( $self, $val ) = @_; $self->[_jmax_] = $val; return }
sub set_rtokens {
my ( $self, $val ) = @_;
$self->[_rtokens_] = $val;
return;
}
sub set_rfields {
my ( $self, $val ) = @_;
$self->[_rfields_] = $val;
return;
}
sub set_rfield_lengths {
my ( $self, $val ) = @_;
$self->[_rfield_lengths_] = $val;
return;
}
sub set_rpatterns {
my ( $self, $val ) = @_;
$self->[_rpatterns_] = $val;
return;
}
sub set_list_type {
my ( $self, $val ) = @_;
$self->[_list_type_] = $val;
return;
}
sub set_is_hanging_side_comment {
my ( $self, $val ) = @_;
$self->[_is_hanging_side_comment_] = $val;
return;
}
sub set_alignment {
my ( $self, $j, $val ) = @_;
$self->[_ralignments_]->[$j] = $val;
return;
}
sub get_end_group { return $_[0]->[_end_group_] }
sub set_end_group {
my ( $self, $val ) = @_;
$self->[_end_group_] = $val;
return;
}
}
1;
Perl-Tidy-20210717/lib/Perl/Tidy/VerticalAligner/Alignment.pm 0000644 0001750 0001750 00000003625 14073571555 022560 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;
{ #<<< A non-indenting brace
our $VERSION = '20210717';
# _column_ # the current column number
# _saved_column_ # a place for temporary storage
my $i = 0;
use constant {
_column_ => $i++,
_saved_column_ => $i++,
};
sub new {
my ( $class, $rarg ) = @_;
my $self = bless [], $class;
$self->[_column_] = $rarg->{column};
$self->[_saved_column_] = $rarg->{saved_column};
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 {
$_[0]->[_column_] += $_[1];
return;
}
sub save_column {
$_[0]->[_saved_column_] = $_[0]->[_column_];
return;
}
sub restore_column {
$_[0]->[_column_] = $_[0]->[_saved_column_];
return;
}
} ## end of package VerticalAligner::Alignment
1;
Perl-Tidy-20210717/lib/Perl/Tidy/DevNull.pm 0000644 0001750 0001750 00000000607 14073571543 017132 0 ustar steve steve #####################################################################
#
# The Perl::Tidy::DevNull class supplies a dummy print method
#
#####################################################################
package Perl::Tidy::DevNull;
use strict;
use warnings;
our $VERSION = '20210717';
sub new { my $self = shift; return bless {}, $self }
sub print { return }
sub close { return }
1;
Perl-Tidy-20210717/lib/Perl/Tidy/FileWriter.pm 0000644 0001750 0001750 00000030577 14073571545 017650 0 ustar steve steve #####################################################################
#
# the Perl::Tidy::FileWriter class writes the output file
#
#####################################################################
package Perl::Tidy::FileWriter;
use strict;
use warnings;
our $VERSION = '20210717';
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$/ );
my ( $pkg, $fname, $lno ) = caller();
my $my_package = __PACKAGE__;
print STDERR < $i++,
_logger_object_ => $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++,
};
}
sub warning {
my ( $self, $msg ) = @_;
my $logger_object = $self->[_logger_object_];
if ($logger_object) { $logger_object->warning($msg); }
return;
}
sub write_logfile_entry {
my ( $self, $msg ) = @_;
my $logger_object = $self->[_logger_object_];
if ($logger_object) {
$logger_object->write_logfile_entry($msg);
}
return;
}
sub new {
my ( $class, $line_sink_object, $rOpts, $logger_object ) = @_;
my $self = [];
$self->[_line_sink_object_] = $line_sink_object;
$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_] = "";
$self->[_K_last_arrival_] = -1;
# save input stream name for local error messages
$input_stream_name = "";
if ($logger_object) {
$input_stream_name = $logger_object->get_input_stream_name();
}
bless $self, $class;
return $self;
}
sub setup_convergence_test {
my ( $self, $rlist ) = @_;
if ( @{$rlist} ) {
# We are going to destroy the list, so make a copy
# and put in reverse order so we can pop values
my @list = @{$rlist};
if ( $list[0] < $list[-1] ) {
@list = reverse @list;
}
$self->[_rK_checklist_] = \@list;
}
$self->[_K_arrival_order_matches_] = 1;
$self->[_K_sequence_error_msg_] = "";
$self->[_K_last_arrival_] = -1;
return;
}
sub get_convergence_check {
my ($self) = @_;
my $rlist = $self->[_rK_checklist_];
# converged if all K arrived and in correct order
return $self->[_K_arrival_order_matches_] && !@{$rlist};
}
sub get_K_sequence_error_msg {
my ($self) = @_;
return $self->[_K_sequence_error_msg_];
}
sub get_output_line_number {
return $_[0]->[_output_line_number_];
}
sub decrement_output_line_number {
$_[0]->[_output_line_number_]--;
return;
}
sub get_consecutive_nonblank_lines {
return $_[0]->[_consecutive_nonblank_lines_];
}
sub get_consecutive_blank_lines {
return $_[0]->[_consecutive_blank_lines_];
}
sub reset_consecutive_blank_lines {
$_[0]->[_consecutive_blank_lines_] = 0;
return;
}
sub want_blank_line {
my $self = shift;
unless ( $self->[_consecutive_blank_lines_] ) {
$self->write_blank_code_line();
}
return;
}
sub require_blank_code_lines {
# write out the requested number of blanks 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 ( $self, $count ) = @_;
my $need = $count - $self->[_consecutive_blank_lines_];
my $rOpts = $self->[_rOpts_];
my $forced = $rOpts->{'maximum-consecutive-blank-lines'} > 0;
foreach my $i ( 0 .. $need - 1 ) {
$self->write_blank_code_line($forced);
}
return;
}
sub write_blank_code_line {
my $self = shift;
my $forced = shift;
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->write_line("\n");
$self->[_consecutive_blank_lines_]++;
$self->[_consecutive_new_blank_lines_]++ if ($forced);
return;
}
sub write_code_line {
my ( $self, $str, $K ) = @_;
$self->[_consecutive_blank_lines_] = 0;
$self->[_consecutive_new_blank_lines_] = 0;
$self->[_consecutive_nonblank_lines_]++;
$self->write_line($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 ( !$self->[_K_sequence_error_msg_] ) {
my $K_prev = $self->[_K_last_arrival_];
if ( $K < $K_prev ) {
chomp $str;
if ( length($str) > 80 ) {
$str = substr( $str, 0, 80 ) . "...";
}
my $msg = <warning($msg);
# Only issue this warning once
$self->[_K_sequence_error_msg_] = $msg;
# stop here in DEVEL mode so this issue doesn't get missed
DEVEL_MODE && Perl::Tidy::Die($msg);
}
}
$self->[_K_last_arrival_] = $K;
}
return;
}
sub write_line {
my ( $self, $str ) = @_;
$self->[_line_sink_object_]->write_line($str);
if ( chomp $str ) { $self->[_output_line_number_]++; }
# This calculation of excess line length ignores any internal tabs
my $rOpts = $self->[_rOpts_];
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;
}
sub report_line_length_errors {
my $self = shift;
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" : "";
$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" : "";
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;
}
1;
Perl-Tidy-20210717/lib/Perl/Tidy/VerticalAligner.pm 0000644 0001750 0001750 00000615676 14073571553 020657 0 ustar steve steve package Perl::Tidy::VerticalAligner;
use strict;
use warnings;
our $VERSION = '20210717';
use Perl::Tidy::VerticalAligner::Alignment;
use Perl::Tidy::VerticalAligner::Line;
# 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 whenerver 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: Output Step A
# sub valign_output_step_A
# CODE SECTION 7: Output Step B
# sub valign_output_step_B
# CODE SECTION 8: Output Step C
# sub valign_output_step_C
# CODE SECTION 9: Output Step D
# sub valign_output_step_D
# CODE SECTION 10: 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++,
_length_function_ => $i++,
_rOpts_ => $i++,
_rOpts_indent_columns_ => $i++,
_rOpts_tabs_ => $i++,
_rOpts_entab_leading_whitespace_ => $i++,
_rOpts_fixed_position_side_comment_ => $i++,
_rOpts_minimum_space_to_comment_ => $i++,
_rOpts_maximum_line_length_ => $i++,
_rOpts_variable_maximum_line_length_ => $i++,
_rOpts_valign_ => $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++,
_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 {
print STDOUT "VALIGN_DEBUGGING with key $_[0]\n";
return;
};
DEBUG_TABS && $debug_warning->('TABS');
}
sub new {
my ( $class, @args ) = @_;
my %defaults = (
rOpts => undef,
file_writer_object => undef,
logger_object => undef,
diagnostics_object => undef,
length_function => sub { return length( $_[0] ) },
);
my %args = ( %defaults, @args );
# Initialize other caches and buffers
initialize_step_B_cache();
initialize_valign_buffer();
initialize_leading_string_cache();
initialize_decode();
# 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};
$self->[_length_function_] = $args{length_function};
# shortcuts to user options
my $rOpts = $args{rOpts};
$self->[_rOpts_] = $rOpts;
$self->[_rOpts_indent_columns_] = $rOpts->{'indent-columns'};
$self->[_rOpts_tabs_] = $rOpts->{'tabs'};
$self->[_rOpts_entab_leading_whitespace_] =
$rOpts->{'entab-leading-whitespace'};
$self->[_rOpts_fixed_position_side_comment_] =
$rOpts->{'fixed-position-side-comment'};
$self->[_rOpts_minimum_space_to_comment_] =
$rOpts->{'minimum-space-to-comment'};
$self->[_rOpts_maximum_line_length_] = $rOpts->{'maximum-line-length'};
$self->[_rOpts_variable_maximum_line_length_] =
$rOpts->{'variable-maximum-line-length'};
$self->[_rOpts_valign_] = $rOpts->{'valign'};
# Batch of lines being collected
$self->[_rgroup_lines_] = [];
$self->[_group_level_] = 0;
$self->[_group_type_] = "";
$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;
}
#################################
# CODE SECTION 2: Basic Utilities
#################################
sub flush {
# flush() is the external call to completely empty the pipeline.
my ($self) = @_;
# push things out the pipline...
# push out any current group lines
$self->_flush_group_lines();
# then anything left in the cache of step_B
$self->_flush_cache();
# then anything left in the buffer of step_C
$self->dump_valign_buffer();
return;
}
sub initialize_for_new_group {
my ($self) = @_;
$self->[_rgroup_lines_] = [];
$self->[_group_type_] = "";
$self->[_zero_count_] = 0;
$self->[_comment_leading_space_count_] = 0;
$self->[_last_leading_space_count_] = 0;
# Note that the value for _group_level_ is
# handled separately in sub valign_input
return;
}
sub group_line_count {
return +@{ $_[0]->[_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;
}
# interface to Perl::Tidy::Logger routines
sub warning {
my ( $self, $msg ) = @_;
my $logger_object = $self->[_logger_object_];
if ($logger_object) {
$logger_object->warning($msg);
}
return;
}
sub write_logfile_entry {
my ( $self, $msg ) = @_;
my $logger_object = $self->[_logger_object_];
if ($logger_object) {
$logger_object->write_logfile_entry($msg);
}
return;
}
sub report_definite_bug {
my ( $self, $msg ) = @_;
my $logger_object = $self->[_logger_object_];
if ($logger_object) {
$logger_object->report_definite_bug();
}
return;
}
sub get_cached_line_count {
my $self = shift;
return $self->group_line_count() + ( get_cached_line_type() ? 1 : 0 );
}
sub get_spaces {
# return the number of leading spaces associated with an indentation
# variable $indentation is either a constant number of spaces or an
# object with a get_spaces method.
my $indentation = shift;
return ref($indentation) ? $indentation->get_spaces() : $indentation;
}
sub get_recoverable_spaces {
# return the number of spaces (+ means shift right, - means shift left)
# that we would like to shift a group of lines with the same indentation
# to get them to line up with their opening parens
my $indentation = shift;
return ref($indentation) ? $indentation->get_recoverable_spaces() : 0;
}
sub maximum_line_length_for_level {
# return maximum line length for line starting with a given level
my ( $self, $level ) = @_;
my $maximum_line_length = $self->[_rOpts_maximum_line_length_];
if ( $self->[_rOpts_variable_maximum_line_length_] ) {
if ( $level < 0 ) { $level = 0 }
$maximum_line_length += $level * $self->[_rOpts_indent_columns_];
}
return $maximum_line_length;
}
######################################################
# CODE SECTION 3: Code to accept input and form groups
######################################################
sub push_group_line {
my ( $self, $new_line ) = @_;
my $rgroup_lines = $self->[_rgroup_lines_];
push @{$rgroup_lines}, $new_line;
return;
}
use constant DEBUG_VALIGN => 0;
use constant SC_LONG_LINE_DIFF => 12;
sub valign_input {
# Place one line in the current vertical group.
#
# The input parameters are:
# $level = indentation level of this line
# $rfields = reference to array of fields
# $rpatterns = reference to array of patterns, one per field
# $rtokens = reference to array of tokens starting fields 1,2,..
#
# 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, $rline_hash ) = @_;
my $level = $rline_hash->{level};
my $level_end = $rline_hash->{level_end};
my $level_adj = $rline_hash->{level_adj};
my $indentation = $rline_hash->{indentation};
my $list_seqno = $rline_hash->{list_seqno};
my $outdent_long_lines = $rline_hash->{outdent_long_lines};
my $is_terminal_ternary = $rline_hash->{is_terminal_ternary};
my $rvertical_tightness_flags = $rline_hash->{rvertical_tightness_flags};
my $level_jump = $rline_hash->{level_jump};
my $rfields = $rline_hash->{rfields};
my $rtokens = $rline_hash->{rtokens};
my $rpatterns = $rline_hash->{rpatterns};
my $rfield_lengths = $rline_hash->{rfield_lengths};
my $terminal_block_type = $rline_hash->{terminal_block_type};
my $batch_count = $rline_hash->{batch_count};
my $break_alignment_before = $rline_hash->{break_alignment_before};
my $break_alignment_after = $rline_hash->{break_alignment_after};
my $Kend = $rline_hash->{Kend};
my $ci_level = $rline_hash->{ci_level};
# 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 = 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 ( $terminal_block_type && $level_adj == 0 && $level_end > $level ) {
$self->forget_side_comment();
}
my $group_level = $self->[_group_level_];
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_jump=$level_jump, level=$level, group_level=$group_level, level_jump=$level_jump\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_flag = get_cached_line_flag();
if ($rvertical_tightness_flags) {
my $cached_seqno = get_cached_seqno();
if ( $cached_seqno
&& $self->group_line_count() <= 1
&& $rvertical_tightness_flags->[2]
&& $rvertical_tightness_flags->[2] == $cached_seqno )
{
$rvertical_tightness_flags->[3] ||= 1;
set_cached_line_valid(1);
}
}
# do not join an opening block brace with an unbalanced line
# unless requested with a flag value of 2
if ( $cached_line_type == 3
&& !$self->group_line_count()
&& $cached_line_flag < 2
&& $level_jump != 0 )
{
set_cached_line_valid(0);
}
}
# shouldn't happen:
if ( $level < 0 ) { $level = 0 }
# do not align code across indentation level changes
# or if vertical alignment is turned off for debugging
if ( $level != $group_level || $is_outdented || !$self->[_rOpts_valign_] ) {
$self->_flush_group_lines( $level - $group_level );
$group_level = $level;
$self->[_group_level_] = $group_level;
# wait until after the above flush to get the leading space
# count because it may have been changed if the -icp flag is in
# effect
$leading_space_count = get_spaces($indentation);
}
# --------------------------------------------------------------------
# Collect outdentable block COMMENTS
# --------------------------------------------------------------------
my $is_blank_line = "";
if ( $self->[_group_type_] eq 'COMMENT' ) {
if (
(
$is_block_comment
&& $outdent_long_lines
&& $leading_space_count ==
$self->[_comment_leading_space_count_]
)
|| $is_blank_line
)
{
# Note that for a comment group we are not storing a line
# but rather just the text and its length.
$self->push_group_line(
[ $rfields->[0], $rfield_lengths->[0], $Kend ] );
return;
}
else {
$self->_flush_group_lines();
}
}
my $rgroup_lines = $self->[_rgroup_lines_];
if ( $break_alignment_before && @{$rgroup_lines} ) {
$rgroup_lines->[-1]->set_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( $rgroup_lines->[-1], $rfields, $rtokens,
$rpatterns, $rfield_lengths, $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}
&& $level_jump == 0 )
{
$j_terminal_match =
fix_terminal_else( $rgroup_lines->[-1], $rfields, $rtokens,
$rpatterns, $rfield_lengths );
$jmax = @{$rfields} - 1;
}
# --------------------------------------------------------------------
# Handle simple line of code with no fields to match.
# --------------------------------------------------------------------
if ( $jmax <= 0 ) {
$self->[_zero_count_]++;
if ( @{$rgroup_lines}
&& !get_recoverable_spaces( $rgroup_lines->[0]->get_indentation() )
)
{
# flush the current group if it has some aligned columns..
# or we haven't seen a comment lately
if ( $rgroup_lines->[0]->get_jmax() > 1
|| $self->[_zero_count_] > 3 )
{
$self->_flush_group_lines();
}
}
# start new COMMENT group if this comment may be outdented
if ( $is_block_comment
&& $outdent_long_lines
&& !$self->group_line_count() )
{
$self->[_group_type_] = 'COMMENT';
$self->[_comment_leading_space_count_] = $leading_space_count;
$self->push_group_line(
[ $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.
if ( !$self->group_line_count()
&& !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,
}
);
return;
}
}
else {
$self->[_zero_count_] = 0;
}
my $maximum_line_length_for_level =
$self->maximum_line_length_for_level($level);
# --------------------------------------------------------------------
# It simplifies things to create a zero length side comment
# if none exists.
# --------------------------------------------------------------------
$self->make_side_comment( $rtokens, $rfields, $rpatterns, $rfield_lengths );
$jmax = @{$rfields} - 1;
# --------------------------------------------------------------------
# create an object to hold this line
# --------------------------------------------------------------------
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 => "",
is_hanging_side_comment => $is_hanging_side_comment,
maximum_line_length => $maximum_line_length_for_level,
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,
}
);
# --------------------------------------------------------------------
# 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)
# --------------------------------------------------------------------
$self->push_group_line($new_line);
# output this group if it ends in a terminal else or ternary line
if ( defined($j_terminal_match) ) {
$self->_flush_group_lines();
}
# Force break after jump to lower level
if ( $level_jump < 0 ) {
$self->_flush_group_lines($level_jump);
}
# --------------------------------------------------------------------
# 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;
}
sub join_hanging_comment {
# Add dummy fields to a hanging side comment to make it look
# like the first line in its potential group. This simplifies
# the coding.
my ( $new_line, $old_line ) = @_;
my $jmax = $new_line->get_jmax();
# must be 2 fields
return 0 unless $jmax == 1;
my $rtokens = $new_line->get_rtokens();
# the second field must be a comment
return 0 unless $rtokens->[0] eq '#';
my $rfields = $new_line->get_rfields();
# the first field must be empty
return 0 unless $rfields->[0] =~ /^\s*$/;
# the current line must have fewer fields
my $maximum_field_index = $old_line->get_jmax();
return 0
unless $maximum_field_index > $jmax;
# looks ok..
my $rpatterns = $new_line->get_rpatterns();
my $rfield_lengths = $new_line->get_rfield_lengths();
$new_line->set_is_hanging_side_comment(1);
$jmax = $maximum_field_index;
$new_line->set_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] = '';
$rfield_lengths->[$j] = 0;
$rtokens->[ $j - 1 ] = "";
$rpatterns->[ $j - 1 ] = "";
}
return 1;
}
sub make_side_comment {
# create an empty side comment if none exists
my ( $self, $rtokens, $rfields, $rpatterns, $rfield_lengths ) = @_;
my $jmax = @{$rfields} - 1;
# if line does not have a side comment...
if ( ( $jmax == 0 ) || ( $rtokens->[ $jmax - 1 ] ne '#' ) ) {
$jmax += 1;
$rtokens->[ $jmax - 1 ] = '#';
$rfields->[$jmax] = '';
$rfield_lengths->[$jmax] = 0;
$rpatterns->[$jmax] = '#';
}
return;
}
{ ## closure for sub decide_if_list
my %is_comma_token;
BEGIN {
my @q = qw( => );
push @q, ',';
@is_comma_token{@q} = (1) x scalar(@q);
}
sub decide_if_list {
my $line = shift;
# 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->get_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->get_jmax();
foreach ( 1 .. $jmax - 2 ) {
( $raw_tok, $lev, $tag, $tok_count ) =
decode_alignment_token( $rtokens->[$_] );
if ( !$is_comma_token{$raw_tok} ) {
$list_type = "";
last;
}
}
$line->set_list_type($list_type);
}
return;
}
}
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 ( $old_line, $rfields, $rtokens, $rpatterns, $rfield_lengths,
$group_level )
= @_;
return unless ($old_line);
use constant EXPLAIN_TERNARY => 0;
my $jmax = @{$rfields} - 1;
my $rfields_old = $old_line->get_rfields();
my $rpatterns_old = $old_line->get_rpatterns();
my $rtokens_old = $old_line->get_rtokens();
my $maximum_field_index = $old_line->get_jmax();
# look for the question mark after the :
my ($jquestion);
my $depth_question;
my $pad = "";
my $pad_length = 0;
foreach my $j ( 0 .. $maximum_field_index - 1 ) {
my $tok = $rtokens_old->[$j];
my ( $raw_tok, $lev, $tag, $tok_count ) = decode_alignment_token($tok);
if ( $raw_tok eq '?' ) {
$depth_question = $lev;
# depth must be correct
next unless ( $depth_question eq $group_level );
$jquestion = $j;
if ( $rfields_old->[ $j + 1 ] =~ /^(\?\s*)/ ) {
$pad_length = length($1);
$pad = " " x $pad_length;
}
else {
return; # shouldn't happen
}
last;
}
}
return unless ( 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 $" = '><';
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 = 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 unless ( $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, ('') 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 unless ( $jmax > 0 && $tokens[0] ne '#' ); # 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, ('') 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, ('') x $jadd ) if $jadd;
splice( @field_lengths, 0, 0, (0) x $jadd ) if $jadd;
}
EXPLAIN_TERNARY && do {
local $" = '><';
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;
}
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 ( $old_line, $rfields, $rtokens, $rpatterns, $rfield_lengths ) = @_;
return unless ($old_line);
my $jmax = @{$rfields} - 1;
return unless ( $jmax > 0 );
# check for balanced else block following if/elsif/unless
my $rfields_old = $old_line->get_rfields();
# TBD: add handling for 'case'
return unless ( $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->get_rpatterns();
my $rtokens_old = $old_line->get_rtokens();
my $maximum_field_index = $old_line->get_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 unless ( $tok_test eq $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 unless ( 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, ('') 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 }
}
my %is_closing_block_type;
BEGIN {
@_ = qw< } ] >;
@is_closing_block_type{@_} = (1) x scalar(@_);
}
sub check_match {
# See if the current line matches the current vertical alignment group.
my ( $self, $new_line, $base_line, $prev_line ) = @_;
# 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
# 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
# Returns '$imax_align' which 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 = "";
use constant EXPLAIN_CHECK_MATCH => 0;
# 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;
my $jmax = $new_line->get_jmax();
my $maximum_field_index = $base_line->get_jmax();
my $jlimit = $jmax - 2;
if ( $jmax > $maximum_field_index ) {
$jlimit = $maximum_field_index - 2;
}
if ( $new_line->get_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->get_is_hanging_side_comment() ) {
$GoToMsg = "end of hanging side comments";
goto NO_MATCH;
}
# 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->get_imax_pair();
if ( $imax_align != $jlimit ) {
$GoToMsg = "Not all tokens match: $imax_align != $jlimit\n";
goto NO_MATCH;
}
}
# 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";
goto NO_MATCH;
}
# The tokens match. Now See if there is space for this line in the
# current group.
if ( $self->check_fit( $new_line, $base_line ) && !TEST_SWEEP_ONLY ) {
EXPLAIN_CHECK_MATCH
&& print "match and fit, imax_align=$imax_align, jmax=$jmax\n";
return ( 2, $jlimit );
}
else {
EXPLAIN_CHECK_MATCH
&& print "match but no fit, imax_align=$imax_align, jmax=$jmax\n";
return ( 1, $jlimit );
}
NO_MATCH:
EXPLAIN_CHECK_MATCH
&& print
"no match because $GoToMsg, max match index =i $imax_align, jmax=$jmax\n";
return ( 0, $imax_align );
}
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.
# return true if successful
# return false if not successful
my $jmax = $new_line->get_jmax();
my $leading_space_count = $new_line->get_leading_space_count();
my $rfield_lengths = $new_line->get_rfield_lengths();
my $padding_available = $old_line->get_available_space_on_right();
my $jmax_old = $old_line->get_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 ) {
$self->warning(<get_alignments();
foreach my $alignment (@alignments) {
$alignment->save_column();
}
my $is_hanging_side_comment = $new_line->get_is_hanging_side_comment();
# Loop over all alignments ...
my $maximum_field_index = $old_line->get_jmax();
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;
# See if it needs too much space.
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;
}
sub install_new_alignments {
my ($new_line) = @_;
my $jmax = $new_line->get_jmax();
my $rfield_lengths = $new_line->get_rfield_lengths();
my $col = $new_line->get_leading_space_count();
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 } );
$new_line->set_alignment( $j, $alignment );
}
return;
}
sub copy_old_alignments {
my ( $new_line, $old_line ) = @_;
my @new_alignments = $old_line->get_alignments();
$new_line->set_alignments(@new_alignments);
return;
}
sub dump_array {
# debug routine to dump array contents
local $" = ')(';
print STDOUT "(@_)\n";
return;
}
sub level_change {
# compute decrease in level when we remove $diff spaces from the
# leading spaces
my ( $self, $leading_space_count, $diff, $level ) = @_;
my $rOpts_indent_columns = $self->[_rOpts_indent_columns_];
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;
}
###############################################
# 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 unless ( @{$rgroup_lines} );
my $group_level = $self->[_group_level_];
my $leading_space_count = $self->[_comment_leading_space_count_];
my $leading_string =
$self->get_leading_string( $leading_space_count, $group_level );
# look for excessively long lines
my $max_excess = 0;
foreach my $item ( @{$rgroup_lines} ) {
my ( $str, $str_len ) = @{$item};
my $excess =
$str_len +
$leading_space_count -
$self->maximum_line_length_for_level($group_level);
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();
$self->[_last_outdented_line_at_] = $last_outdented_line_at;
my $outdented_line_count = $self->[_outdented_line_count_];
unless ($outdented_line_count) {
$self->[_first_outdented_line_at_] = $last_outdented_line_at;
}
my $nlines = @{$rgroup_lines};
$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 => "",
level => $group_level,
level_end => $group_level,
Kend => $Kend,
}
);
}
$self->initialize_for_new_group();
return;
}
######################################################
# 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
my $rgroup_lines = $self->[_rgroup_lines_];
return unless ( @{$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, $saw_side_comment ) =
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]->get_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: Output the lines.
# All lines in this batch have the same basic leading spacing:
my $group_leader_length = $rgroup_lines->[0]->get_leading_space_count();
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,
}
);
}
$self->initialize_for_new_group();
return;
}
{ ## 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;
}
sub get_rgroup_jrange {
return unless @{$rgroups};
return unless ( $group_line_count > 0 );
my ( $jbeg, $jend ) = @{ $rgroups->[-1] };
return ( $jbeg, $jend );
}
sub end_rgroup {
my ($imax_align) = @_;
return unless @{$rgroups};
return unless ( $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->get_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 ]->get_imax_pair() < 0 );
my $imax_prev =
$jbeg > 0 ? $rall_lines->[ $jbeg - 1 ]->get_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;
}
sub block_penultimate_match {
# emergency reset to prevent sweep_left_to_right from trying to match a
# failed terminal else match
return unless @{$rgroups} > 1;
$rgroups->[-2]->[2] = -1;
return;
}
sub sweep_top_down {
my ( $self, $rlines, $group_level ) = @_;
# 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]->set_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->get_end_group() ) {
end_rgroup(-1);
}
next;
}
my $j_terminal_match = $new_line->get_j_terminal_match();
my ( $jbeg, $jend ) = get_rgroup_jrange();
if ( !defined($jbeg) ) {
# safety check, shouldn't happen
$self->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->get_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 coments out
# to the right.
elsif ( $new_line->get_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 ]->get_rfields()->[-1];
my $side_comment = $new_line->get_rfields()->[-1];
end_rgroup(-1) unless ( $side_comment && $prev_comment );
}
# 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 ] );
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->get_is_terminal_ternary() ) {
block_penultimate_match();
}
}
end_rgroup(-1);
}
# end the group if we know we cannot match next line.
elsif ( $new_line->get_end_group() ) {
end_rgroup(-1);
}
} ## end loop over lines
end_rgroup(-1);
return ($rgroups);
}
}
sub two_line_pad {
my ( $line_m, $line, $imax_min ) = @_;
# Given:
# two isolated (list) lines
# imax_min = number of common alignment tokens
# Return:
# $pad_max = maximum suggested pad distnce
# = 0 if alignment not recommended
# 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 '='.
# 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
# ];
my $rfield_lengths = $line->get_rfield_lengths();
my $rfield_lengths_m = $line_m->get_rfield_lengths();
# Safety check - shouldn't happen
return 0
unless $imax_min < @{$rfield_lengths} && $imax_min < @{$rfield_lengths_m};
my $lensum_m = 0;
my $lensum = 0;
for ( my $i = 0 ; $i <= $imax_min ; $i++ ) {
$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->get_list_type() && $line->get_list_type() ) {
$patterns_match = 1;
my $rpatterns_m = $line_m->get_rpatterns();
my $rpatterns = $line->get_rpatterns();
for ( my $i = 0 ; $i <= $imax_min ; $i++ ) {
my $pat = $rpatterns->[$i];
my $pat_m = $rpatterns_m->[$i];
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;
}
sub sweep_left_to_right {
my ( $rlines, $rgroups, $group_level ) = @_;
# 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 unless ( $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->get_rtokens();
$imax = $line->get_jmax() - 2;
$istop = -1 unless ( 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]->get_list_type();
if (
$jend == $jbeg
&& $jend_m == $jbeg_m
&& ( $ng == 1 || $istop_mm < 0 )
&& ( $ng == $ng_max || $istop < 0 )
&& !$line->get_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 unless ( $imax_min >= 0 );
next
unless ( $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 unless ($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, $tok_count ) = 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, $rgroups, \@todo, \%max_move, $short_pad,
$group_level );
return;
}
{ ## 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
}
sub do_left_to_right_sweep {
my ( $rlines, $rgroups, $rtodo, $rmax_move, $short_pad, $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]->get_list_type();
my $move_to_common_column = sub {
# Move the alignment column of token $itok to $col_want for a
# sequence of groups.
my ( $ngb, $nge, $itok, $col_want, $raw_tok ) = @_;
return unless ( defined($ngb) && $nge > $ngb );
foreach my $ng ( $ngb .. $nge ) {
my ( $jbeg, $jend ) = @{ $rgroups->[$ng] };
my $line = $rlines->[$jbeg];
my $col = $line->get_column($itok);
my $avail = $line->get_available_space_on_right();
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
}
}
};
foreach my $task ( @{$rtodo} ) {
my ( $itok, $ng_beg, $ng_end, $raw_tok, $lev ) = @{$task};
# Nothing to do for a single group
next unless ( $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->get_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 arrors.
my $is_blocked = defined( $blocking_level[$ng] )
&& $lev > $blocking_level[$ng];
# TAIL-WAG-DOG RULE: prevent a 'tail-wag-dog' syndrom, 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 prys 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
elsif (
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->(
$ng_first, $ng - 1, $itok, $col_want, $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->(
$ng_first, $ng_end, $itok, $col_want, $raw_tok
);
} ## end loop over groups for one task
} ## end loop over tasks
return;
}
}
sub delete_selected_tokens {
my ( $line_obj, $ridel ) = @_;
# $line_obj is the line to be modified
# $ridel is a ref to list of indexes to be deleted
# remove an unused alignment token(s) to improve alignment chances
return unless ( defined($line_obj) && defined($ridel) && @{$ridel} );
my $jmax_old = $line_obj->get_jmax();
my $rfields_old = $line_obj->get_rfields();
my $rfield_lengths_old = $line_obj->get_rfield_lengths();
my $rpatterns_old = $line_obj->get_rpatterns();
my $rtokens_old = $line_obj->get_rtokens();
my $j_terminal_match = $line_obj->get_j_terminal_match();
use constant EXPLAIN_DELETE_SELECTED => 0;
local $" = '> <';
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 = $rpatterns_old->[0];
my $field = $rfields_old->[0];
my $field_length = $rfield_lengths_old->[0];
push @{$rfields_new}, $field;
push @{$rfield_lengths_new}, $field_length;
push @{$rpatterns_new}, $pattern;
# Loop to either copy items or concatenate fields and patterns
my $jmin_del;
for ( my $j = 0 ; $j < $jmax_old ; $j++ ) {
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->set_rtokens($rtokens_new);
$line_obj->set_rpatterns($rpatterns_new);
$line_obj->set_rfields($rfields_new);
$line_obj->set_rfield_lengths($rfield_lengths_new);
$line_obj->set_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->set_j_terminal_match(undef);
}
# update list type -
if ( $line_obj->get_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->get_list_type();
my $new_list_type = "";
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;
}
{ ## 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;
}
sub decode_alignment_token {
# Unpack the values packed in an alignment token
#
# 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]
my ($tok) = @_;
if ( defined( $decoded_token{$tok} ) ) {
return @{ $decoded_token{$tok} };
}
my ( $raw_tok, $lev, $tag, $tok_count ) = ( $tok, 0, "", 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;
}
}
{ ## closure for sub delete_unmatched_tokens
my %is_assignment;
my %keep_after_deleted_assignment;
BEGIN {
my @q;
@q = qw(
= **= += *= &= <<= &&=
-= /= |= >>= ||= //=
.= %= ^=
x=
);
@is_assignment{@q} = (1) x scalar(@q);
# These tokens may be kept following an = deletion
@q = qw(
if unless or ||
);
@keep_after_deleted_assignment{@q} = (1) x scalar(@q);
}
# This flag is for testing only and should normally be zero.
use constant TEST_DELETE_NULL => 0;
sub delete_unmatched_tokens {
my ( $rlines, $group_level ) = @_;
# This is a preliminary step in vertical alignment in which we remove
# as many obviously un-needed alignment tokens as possible. This will
# prevent them from interfering with the final alignment.
# These are the return values
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
# Handle no lines -- shouldn't happen
return unless @{$rlines};
# Handle a single line
if ( @{$rlines} == 1 ) {
my $line = $rlines->[0];
my $jmax = $line->get_jmax();
my $length = $line->get_rfield_lengths()->[$jmax];
$saw_side_comment = $length > 0;
return ( $max_lev_diff, $saw_side_comment );
}
my $has_terminal_match = $rlines->[-1]->get_j_terminal_match();
# ignore hanging side comments in these operations
my @filtered = grep { !$_->get_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 ) unless ( $jmax >= 0 );
my @equals_info;
my @line_info;
my %is_good_tok;
# create a hash of tokens for each line
my $rline_hashes = [];
foreach my $line ( @{$rnew_lines} ) {
my $rhash = {};
my $rtokens = $line->get_rtokens();
my $rpatterns = $line->get_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->get_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 }
}
}
# compare each line pair and record matches
my $rtok_hash = {};
my $nr = 0;
for ( my $jl = 0 ; $jl < $jmax ; $jl++ ) {
my $nl = $nr;
$nr = 0;
my $jr = $jl + 1;
my $rhash_l = $rline_hashes->[$jl];
my $rhash_r = $rline_hashes->[$jr];
my $count = 0; # UNUSED NOW?
my $ntoks = 0;
foreach my $tok ( keys %{$rhash_l} ) {
$ntoks++;
if ( defined( $rhash_r->{$tok} ) ) {
if ( $tok ne '#' ) { $count++; }
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]->set_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]->get_ci_level() !=
$rnew_lines->[$jr]->get_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]->set_end_group(1);
}
}
}
# find subgroups
my @subgroups;
push @subgroups, [ 0, $jmax ];
for ( my $jl = 0 ; $jl < $jmax ; $jl++ ) {
if ( $rnew_lines->[$jl]->get_end_group() ) {
$subgroups[-1]->[1] = $jl;
push @subgroups, [ $jl + 1, $jmax ];
}
}
# flag to allow skipping pass 2
my $saw_large_group;
############################################################
# PASS 1 over subgroups to remove unmatched alignment tokens
############################################################
foreach my $item (@subgroups) {
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 ) {
for ( my $jj = $jbeg ; $jj <= $jend ; $jj++ ) {
my %seen;
my $line = $rnew_lines->[$jj];
my $rtokens = $line->get_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 lines to remove unwanted alignment tokens
#####################################################
for ( my $jj = $jbeg ; $jj <= $jend ; $jj++ ) {
my $line = $rnew_lines->[$jj];
my $rtokens = $line->get_rtokens();
my $rhash = $rline_hashes->[$jj];
my $i_eq = $equals_info[$jj]->[0];
my @idel;
my $imax = @{$rtokens} - 2;
my $delete_above_level;
my $deleted_assignment_token;
my $saw_dividing_token = "";
$saw_large_group ||= $nlines > 2 && $imax > 1;
# Loop over all alignment tokens
for ( my $i = 0 ; $i <= $imax ; $i++ ) {
my $tok = $rtokens->[$i];
next if ( $tok eq '#' ); # shouldn't happen
my ( $iii, $il, $ir, $raw_tok, $lev, $tag, $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);
# 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; #$tag;
}
else { $delete_above_level = undef }
}
# EXCEPTION 3: Remove all but certain tokens after an
# assignment deletion.
if (
$deleted_assignment_token
&& ( $lev > $group_level
|| !$keep_after_deleted_assignment{$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) {
# okay to delete second and higher copies of a token
if ( $tok_count == 1 ) {
# 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 }
}
}
}
#####################################
# 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 loopover lines
} # End loop over subgroups
#################################################
# PASS 2 over subgroups to remove null alignments
#################################################
# This pass is only used for testing. It is helping to identify
# alignment situations which might be improved with a future more
# general algorithm which adds a tail matching capability.
if (TEST_DELETE_NULL) {
delete_null_alignments( $rnew_lines, $rline_hashes, \@subgroups )
if ($saw_large_group);
}
# PASS 3: 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 4: compare all lines for common tokens
match_line_pairs( $rlines, $rnew_lines, \@subgroups, $group_level );
return ( $max_lev_diff, $saw_side_comment );
}
}
sub delete_null_alignments {
my ( $rnew_lines, $rline_hashes, $rsubgroups ) = @_;
# This is an optional second pass for deleting alignment tokens which can
# occasionally improve alignment. We look for and remove 'null
# alignments', which are alignments that require no padding. So we can
# 'cheat' and delete them. For example, notice the '=~' alignment in the
# first two lines of the following code:
# $sysname .= 'del' if $self->label =~ /deletion/;
# $sysname .= 'ins' if $self->label =~ /insertion/;
# $sysname .= uc $self->allele_ori->seq if $self->allele_ori->seq;
# These '=~' tokens are already aligned because they are both the same
# distance from the previous alignment token, the 'if'. So we can
# eliminate them as alignments. The advantage is that in some cases, such
# as this one, this will allow other tokens to be aligned. In this case we
# then get the 'if' tokens to align:
# $sysname .= 'del' if $self->label =~ /deletion/;
# $sysname .= 'ins' if $self->label =~ /insertion/;
# $sysname .= uc $self->allele_ori->seq if $self->allele_ori->seq;
# The following rules for limiting this operation have been found to
# work well and avoid problems:
# Rule 1. We only consider a sequence of lines which have the same
# sequence of alignment tokens.
# Rule 2. We never eliminate the first alignment token. One reason is that
# lines may have different leading indentation spaces, so keeping the
# first alignment token insures that our length measurements start at
# a well-defined point. Another reason is that nothing is gained because
# the left-to-right sweep can always handle alignment of this token.
# Rule 3. We require that the first alignment token exist in either
# a previous line or a subsequent line. The reason is that this avoids
# changing two-line matches which go through special logic.
# Rule 4. Do not delete a token which occurs in a previous or subsequent
# line. For example, in the above example, it was ok to eliminate the '=~'
# token from two lines because it did not occur in a surrounding line.
# If it did occur in a surrounding line, the result could be confusing
# or even incorrectly aligned.
# A consequence of these rules is that we only need to consider subgroups
# with at least 3 lines and 2 alignment tokens.
# The subgroup line index range
my ( $jbeg, $jend );
# Vars to keep track of the start of a current sequence of matching
# lines.
my $rtokens_match;
my $rfield_lengths_match;
my $j_match_beg;
my $j_match_end;
my $imax_match;
my $rneed_pad;
# Vars for a line being tested
my $rtokens;
my $rfield_lengths;
my $imax;
my $start_match = sub {
my ($jj) = @_;
$rtokens_match = $rtokens;
$rfield_lengths_match = $rfield_lengths;
$j_match_beg = $jj;
$j_match_end = $jj;
$imax_match = $imax;
$rneed_pad = [];
return;
};
my $add_to_match = sub {
my ($jj) = @_;
$j_match_end = $jj;
# Keep track of any padding that would be needed for each token
for ( my $i = 0 ; $i <= $imax ; $i++ ) {
next if ( $rneed_pad->[$i] );
my $length = $rfield_lengths->[$i];
my $length_match = $rfield_lengths_match->[$i];
if ( $length ne $length_match ) { $rneed_pad->[$i] = 1 }
}
};
my $end_match = sub {
return unless ( $j_match_end > $j_match_beg );
my $nlines = $j_match_end - $j_match_beg + 1;
my $rhash_beg = $rline_hashes->[$j_match_beg];
my $rhash_end = $rline_hashes->[$j_match_end];
my @idel;
# Do not delete unless the first token also occurs in a surrounding line
my $tok0 = $rtokens_match->[0];
return
unless (
(
$j_match_beg > $jbeg
&& $rnew_lines->[ $j_match_beg - 1 ]->get_rtokens()->[0] eq
$tok0
)
|| ( $j_match_end < $jend
&& $rnew_lines->[ $j_match_end + 1 ]->get_rtokens()->[0] eq
$tok0 )
);
# Note that we are skipping the token at i=0
for ( my $i = 1 ; $i <= $imax_match ; $i++ ) {
# do not delete a token which requires padding to align
next if ( $rneed_pad->[$i] );
my $tok = $rtokens_match->[$i];
# Do not delete a token which occurs in a surrounding line
next
if ( $j_match_beg > $jbeg
&& defined( $rline_hashes->[ $j_match_beg - 1 ]->{$tok} ) );
next
if ( $j_match_end < $jend
&& defined( $rline_hashes->[ $j_match_end + 1 ]->{$tok} ) );
# ok to delete
push @idel, $i;
##print "ok to delete tok=$tok\n";
}
if (@idel) {
foreach my $j ( $j_match_beg .. $j_match_end ) {
delete_selected_tokens( $rnew_lines->[$j], \@idel );
}
}
};
foreach my $item ( @{$rsubgroups} ) {
( $jbeg, $jend ) = @{$item};
my $nlines = $jend - $jbeg + 1;
next unless ( $nlines > 2 );
for ( my $jj = $jbeg ; $jj <= $jend ; $jj++ ) {
my $line = $rnew_lines->[$jj];
$rtokens = $line->get_rtokens();
$rfield_lengths = $line->get_rfield_lengths();
$imax = @{$rtokens} - 2;
# start a new match group
if ( $jj == $jbeg ) {
$start_match->($jj);
next;
}
# see if all tokens of this line match the current group
my $match;
if ( $imax == $imax_match ) {
for ( my $i = 0 ; $i <= $imax ; $i++ ) {
my $tok = $rtokens->[$i];
my $tok_match = $rtokens_match->[$i];
last if ( $tok ne $tok_match );
}
$match = 1;
}
# yes, they all match
if ($match) {
$add_to_match->($jj);
}
# now, this line does not match
else {
$end_match->();
$start_match->($jj);
}
} # End loopover lines
$end_match->();
} # End loop over subgroups
return;
} ## end sub delete_null_alignments
sub match_line_pairs {
my ( $rlines, $rnew_lines, $rsubgroups, $group_level ) = @_;
# Compare each pair of lines and save information about common matches
# $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
# 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 );
use constant EXPLAIN_COMPARE_PATTERNS => 0;
my $compare_patterns = sub {
# helper routine to decide if patterns match well enough..
# return code:
# 0 = patterns match, continue
# 1 = no match
# 2 = no match, and lines do not match at all
my ( $tok, $tok_m, $pat, $pat_m, $pad ) = @_;
my $GoToMsg = "";
my $return_code = 1;
my ( $alignment_token, $lev, $tag, $tok_count ) =
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
$GoToMsg = "do not align commas in unnamed containers";
goto NO_MATCH unless ( $tok =~ /[A-Za-z]/ );
}
# 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.
$GoToMsg = "do not align '(' unless patterns match or pad=0";
if ( $pad != 0 ) { goto NO_MATCH }
}
# 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";
goto NO_MATCH;
}
# 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";
if ( $lev eq $group_level ) {
$return_code = 2;
}
goto NO_MATCH;
}
}
MATCH:
return ( 0, \$GoToMsg );
NO_MATCH:
EXPLAIN_COMPARE_PATTERNS
&& print STDERR "no match because $GoToMsg\n";
return ( $return_code, \$GoToMsg );
}; ## end of $compare_patterns->()
# loop over subgroups
foreach my $item ( @{$rsubgroups} ) {
my ( $jbeg, $jend ) = @{$item};
my $nlines = $jend - $jbeg + 1;
next unless ( $nlines > 1 );
# loop over lines in a subgroup
for ( my $jj = $jbeg ; $jj <= $jend ; $jj++ ) {
$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->get_rtokens();
$rpatterns = $line->get_rpatterns();
$rfield_lengths = $line->get_rfield_lengths();
$imax = @{$rtokens} - 2;
$list_type = $line->get_list_type();
$ci_level = $line->get_ci_level();
# 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->get_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;
for ( my $i = 0 ; $i <= $imax_min ; $i++ ) {
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;
for ( my $i = 0 ; $i <= $imax_min ; $i++ ) {
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];
# 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, $rmsg ) = $compare_patterns->(
$tok, $tok_m, $pat, $pat_m, $pad
);
if ($match_code) {
if ( $match_code eq 1 ) { $i_nomatch = $i }
elsif ( $match_code eq 2 ) { $i_nomatch = 0 }
last;
}
}
}
$imax_align = $i_nomatch - 1;
}
$line_m->set_imax_pair($imax_align);
} ## end loop over lines
# Put fence at end of subgroup
$line->set_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 ( @{$rlines} ) {
if ( $line->get_is_hanging_side_comment() ) {
$line->set_imax_pair($last_pair_info);
}
else {
$last_pair_info = $line->get_imax_pair();
}
}
}
return;
}
sub fat_comma_to_comma {
my ($str) = @_;
# We are changing '=>' to ',' and removing any trailing decimal count
# because currently fat commas have a count and commas do not.
# For example, we will change '=>2+{-3.2' into ',2+{-3'
if ( $str =~ /^=>([^\.]*)/ ) { $str = ',' . $1 }
return $str;
}
sub get_line_token_info {
# scan lines of tokens and return summary information about the range of
# levels and patterns.
my ($rlines) = @_;
# 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;
for ( my $jj = 0 ; $jj < @{$rlines} ; $jj++ ) {
my ($line) = $rlines->[$jj];
my $rtokens = $line->get_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 = [];
for ( my $jj = 0 ; $jj < @{$rlines} ; $jj++ ) {
my ($line) = $rlines->[$jj];
my $rtokens = $line->get_rtokens();
my $i = -1;
my ( $lev_min, $lev_max );
my $token_pattern_max = "";
my %saw_level;
my @token_info;
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 $i = $imax - 1;
while ( $i >= 0
&& fat_comma_to_comma( $rtokens->[$i] ) eq $tok_end )
{
$imax = $i;
$i--;
}
}
# 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, $lev, $tag, $tok_count ) =
@{ $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 keys %saw_level;
if ( !defined($lev_min) ) {
$lev_min = -1;
$lev_max = -1;
$levs[0] = -1;
$rtoken_patterns->{$lev_min} = "";
$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 $debug = 0;
my $lev_top = pop @levs; # alread did max level
my $itok = -1;
foreach my $tok ( @{$rtokens} ) {
$itok++;
last if ( $itok > $imax );
my ( $raw_tok, $lev, $tag, $tok_count ) =
@{ $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 $" = ')(';
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 );
}
sub prune_alignment_tree {
my ($rlines) = @_;
my $jmax = @{$rlines} - 1;
return unless $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 alignements, 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 sub end_node
######################################################
# Prune Tree Step 2. Loop to form the tree of matches.
######################################################
for ( my $jp = 0 ; $jp <= $jmax ; $jp++ ) {
# 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, $lev_max, $rtoken_patterns, $rlevs, $rtoken_indexes,
$is_monotonic, $imax_true, $imax )
= @{ $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 (@levels_next) {
$token_patterns_next[$depth] =
defined($_) ? $rtoken_patterns->{$_} : undef;
$token_indexes_next[$depth] =
defined($_) ? $rtoken_indexes->{$_} : 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]->get_end_group() ) {
my $n_parent;
$end_node->( 0, $jm, $n_parent );
}
# Continue at hanging side comment
elsif ( $rlines->[$jp]->get_is_hanging_side_comment() ) {
next;
}
# Otherwise see if anything changed and update the tree if so
else {
foreach my $depth ( 0 .. $MAX_DEPTH ) {
my $def_current = defined( $token_patterns_current[$depth] );
my $def_next = defined( $token_patterns_next[$depth] );
last unless ( $def_current || $def_next );
if ( !$def_current
|| !$def_next
|| $token_patterns_current[$depth] ne
$token_patterns_next[$depth] )
{
my $n_parent;
if ( $depth > 0 && defined( $match_tree[ $depth - 1 ] ) ) {
$n_parent = @{ $match_tree[ $depth - 1 ] } - 1;
}
$end_node->( $depth, $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 orignal array.
# These will be undef if no children.
for ( my $depth = $MAX_DEPTH ; $depth > 0 ; $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;
# Groups with ending comma lists and their range of sizes:
# $ragged_comma_group{$id} = [ imax_group_min, imax_group_max ]
my %ragged_comma_group;
# Define a threshold line count for forcing a break
my $nlines_break = 3;
# 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 );
}
for ( my $depth = 0 ; $depth <= $MAX_DEPTH ; $depth++ ) {
last unless (@todo_list);
my @todo_next;
foreach my $np (@todo_list) {
my ( $jbeg_p, $jend_p, $np_p, $lev_p, $pat_p, $nc_beg_p, $nc_end_p,
$rindexes_p )
= @{ $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, $lev_c, $pat_c, $nc_beg_c,
$nc_end_c )
= @{ $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->get_rtokens();
my $imax = @{$rtokens} - 2;
for ( my $i = 0 ; $i <= $imax ; $i++ ) {
my $tok = $rtokens->[$i];
my ( $raw_tok, $lev, $tag, $tok_count ) =
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 ) = @_;
print "$msg\n";
local $" = ')(';
foreach my $item ( @{$rgroup} ) {
my @fix = @{$item};
foreach (@fix) { $_ = "undef" unless defined $_; }
$fix[4] = "...";
print "(@fix)\n";
}
return;
}
{ ## closure for sub is_marginal_match
my %is_if_or;
my %is_assignment;
my %is_good_alignment;
# This test did not give sufficiently better results to use as an update,
# but the flag is worth keeping as a starting point for future testing.
use constant TEST_MARGINAL_EQ_ALIGNMENT => 0;
BEGIN {
my @q = qw(
if unless or ||
);
@is_if_or{@q} = (1) x scalar(@q);
@q = qw(
= **= += *= &= <<= &&=
-= /= |= >>= ||= //=
.= %= ^=
x=
);
@is_assignment{@q} = (1) x scalar(@q);
# Vertically aligning on certain "good" tokens is usually okay
# so we can be less restrictive in marginal cases.
@q = qw( { ? => = );
push @q, (',');
@is_good_alignment{@q} = (1) x scalar(@q);
}
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 keep alignments of a terminal else or ternary
goto RETURN if ( defined( $line_1->get_j_terminal_match() ) );
# always align lists
my $group_list_type = $line_0->get_list_type();
goto RETURN if ($group_list_type);
# always align hanging side comments
my $is_hanging_side_comment = $line_1->get_is_hanging_side_comment();
goto RETURN if ($is_hanging_side_comment);
my $jmax_0 = $line_0->get_jmax();
my $jmax_1 = $line_1->get_jmax();
my $rtokens_1 = $line_1->get_rtokens();
my $rtokens_0 = $line_0->get_rtokens();
my $rfield_lengths_0 = $line_0->get_rfield_lengths();
my $rfield_lengths_1 = $line_1->get_rfield_lengths();
my $rpatterns_0 = $line_0->get_rpatterns();
my $rpatterns_1 = $line_1->get_rpatterns();
my $imax_next = $line_1->get_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 = ""; # 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;
for ( my $j = 0 ; $j < $jmax_1 - 1 ; $j++ ) {
my ( $raw_tok, $lev, $tag, $tok_count ) =
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->get_leading_space_count() -
$line_0->get_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_alignment{$raw_tok} && !$line_ending_fat_comma ) {
$saw_good_alignment = 1;
}
else {
$jfirst_bad = $j unless defined($jfirst_bad);
}
if ( $rpatterns_0->[$j] ne $rpatterns_1->[$j] ) {
# 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 unless this is a marginal match
########################################
goto RETURN if ( !$is_marginal );
# 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;
}
}
######################################################
# 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:
return ( $is_marginal, $imax_align );
}
}
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 unless ( @{$rlines} && @{$rgroups} );
my $object = $rlines->[0]->get_indentation();
return 0 unless ( ref($object) );
my $extra_leading_spaces = 0;
my $extra_indentation_spaces_wanted = get_recoverable_spaces($object);
return ($extra_leading_spaces) unless ($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]->get_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;
}
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.
# Return true to keep old comment location
# Return false to forget old comment location
my $rfields = $line->get_rfields();
my $is_hanging_side_comment = $line->get_is_hanging_side_comment();
# RULE1: Never forget comment before a hanging side comment
goto 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 unless ($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 );
goto FORGET
if ( $line_diff > $short_diff );
# 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_];
goto 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
goto FORGET
if ( $cached_line_type == 2 || $cached_line_type == 4 );
}
# Otherwise, keep it alive
goto KEEP;
FORGET:
return 0;
KEEP:
return 1;
}
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. Othewise, 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->get_jmax();
if ( $line->get_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;
for ( my $jj = $j_sc_beg + 1 ; $jj < @{$rlines} ; $jj++ ) {
my $ldiff = $jj - $j_sc_beg;
last if ( $ldiff > 5 );
my $line = $rlines->[$jj];
my $jmax = $line->get_jmax();
my $sc_len = $line->get_rfield_lengths()->[$jmax];
next unless ($sc_len);
$num5++;
}
# Forget the old side comment location if necessary
my $line = $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, $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;
for ( my $PASS = 1 ; $PASS <= $MAX_PASS ; $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 $ng (@todo) {
my ( $jbeg, $jend ) = @{ $rgroups->[$ng] };
# 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->get_jmax();
my $is_hanging_side_comment = $line->get_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 = $self->[_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] };
for ( my $jj = $jend ; $jj >= $jbeg ; $jj-- ) {
my $line = $rlines->[$jj];
my $jmax = $line->get_jmax();
if ( $line->get_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;
}
###############################
# CODE SECTION 6: 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 $rfields = $line->get_rfields();
my $rfield_lengths = $line->get_rfield_lengths();
my $leading_space_count = $line->get_leading_space_count();
my $outdent_long_lines = $line->get_outdent_long_lines();
my $maximum_field_index = $line->get_jmax();
my $rvertical_tightness_flags = $line->get_rvertical_tightness_flags();
my $Kend = $line->get_Kend();
my $level_end = $line->get_level_end();
# 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];
# 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 = $line->get_column( $j - 1 );
my $pad = $col - ( $str_len + $leading_space_count );
if ($do_not_align) {
$pad =
( $j < $maximum_field_index )
? 0
: $self->[_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 ( $self->[_rOpts_fixed_position_side_comment_]
&& $j == $maximum_field_index )
{
my $newpad =
$pad + $self->[_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 .= ' ' 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,
}
);
return;
}
sub combine_fields {
# 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.
my ( $line_0, $line_1, $imax_align ) = @_;
if ( !defined($imax_align) ) { $imax_align = -1 }
# First delete the unwanted tokens
my $jmax_old = $line_0->get_jmax();
my @old_alignments = $line_0->get_alignments();
my @idel = ( $imax_align + 1 .. $jmax_old - 2 );
return unless (@idel);
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->get_jmax();
$new_alignments[ $jmax_new - 1 ] = $old_alignments[ $jmax_old - 1 ];
$new_alignments[$jmax_new] = $old_alignments[$jmax_old];
$line_0->set_alignments(@new_alignments);
$line_1->set_alignments(@new_alignments);
return;
}
sub get_output_line_number {
# The output line number reported to a caller =
# the number of items still in the buffer +
# the number of items written.
return $_[0]->group_line_count() +
$_[0]->[_file_writer_object_]->get_output_line_number();
}
###############################
# CODE SECTION 7: 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_flag;
my $cached_seqno;
my $cached_line_valid;
my $cached_line_leading_space_count;
my $cached_seqno_string;
my $cached_line_Kend;
my $seqno_string;
my $last_nonblank_seqno_string;
sub get_seqno_string {
return $seqno_string;
}
sub get_last_nonblank_seqno_string {
return $last_nonblank_seqno_string;
}
sub set_last_nonblank_seqno_string {
my ($val) = @_;
$last_nonblank_seqno_string = $val;
return;
}
sub get_cached_line_flag {
return $cached_line_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 = "";
$cached_line_text_length = 0;
$cached_line_type = 0;
$cached_line_flag = 0;
$cached_seqno = 0;
$cached_line_valid = 0;
$cached_line_leading_space_count = 0;
$cached_seqno_string = "";
$cached_line_Kend = undef;
# These vars hold a string of sequence numbers joined together used by
# the cache
$seqno_string = "";
$last_nonblank_seqno_string = "";
return;
}
sub _flush_cache {
my ($self) = @_;
if ($cached_line_type) {
$seqno_string = $cached_seqno_string;
$self->valign_output_step_C(
$cached_line_text,
$cached_line_leading_space_count,
$self->[_last_level_written_],
$cached_line_Kend,
);
$cached_line_type = 0;
$cached_line_text = "";
$cached_line_text_length = 0;
$cached_seqno_string = "";
$cached_line_Kend = undef;
}
return;
}
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 $last_level_written = $self->[_last_level_written_];
# 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 -
$self->maximum_line_length_for_level($level);
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_];
unless ($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 ? ( ' ' x $leading_space_count ) : "";
my $leading_string_length = length($leading_string);
# Unpack any recombination data; it was packed by
# sub send_lines_to_vertical_aligner. Contents:
#
# [0] type: 1=opening non-block 2=closing non-block
# 3=opening block brace 4=closing block brace
# [1] flag: if opening: 1=no multiple steps, 2=multiple steps ok
# if closing: spaces of padding to use
# [2] sequence number of container
# [3] valid flag: do not append if this flag is false
#
my ( $open_or_close, $tightness_flag, $seqno, $valid, $seqno_beg,
$seqno_end );
if ($rvertical_tightness_flags) {
(
$open_or_close, $tightness_flag, $seqno, $valid, $seqno_beg,
$seqno_end
) = @{$rvertical_tightness_flags};
}
$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) ) {
# Dump an invalid cached line
if ( !$cached_line_valid ) {
$self->valign_output_step_C(
$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_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 -vmll is set. The reason is that the -vmll option can
# cause changes in the maximum line length, leading to blinkers
# if not checked.
if (
$gap >= 0
&& ( $self->[_rOpts_variable_maximum_line_length_]
|| ( defined($level_end) && $level > $level_end ) )
)
{
my $test_line_length =
$cached_line_text_length + $gap + $str_length;
my $maximum_line_length =
$self->maximum_line_length_for_level($last_level_written);
# Add a small tolerance in the length test (fixes case b862)
if ( $test_line_length > $maximum_line_length - 2 ) {
$gap = -1;
}
}
if ( $gap >= 0 && defined($seqno_beg) ) {
$leading_string = $cached_line_text . ' ' 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(
$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 . ' ' x $cached_line_flag . $str;
my $test_line_length =
$cached_line_text_length + $cached_line_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 <=
$self->maximum_line_length_for_level(
$last_level_written)
)
)
{
$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
##}
}
}
}
$str = $test_line;
$str_length = $test_line_length;
$leading_string = "";
$leading_string_length = 0;
$leading_space_count = $cached_line_leading_space_count;
$level = $last_level_written;
}
else {
$self->valign_output_step_C(
$cached_line_text, $cached_line_leading_space_count,
$last_level_written, $cached_line_Kend
);
}
}
}
$cached_line_type = 0;
$cached_line_text = "";
$cached_line_text_length = 0;
$cached_line_Kend = 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
if ( !$open_or_close || $side_comment_length > 0 || $is_outdented_line )
{
$self->valign_output_step_C( $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_flag = $tightness_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;
}
$self->[_last_level_written_] = $level;
$self->[_last_side_comment_length_] = $side_comment_length;
return;
}
}
###############################
# CODE SECTION 8: 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 = "";
return;
}
sub dump_valign_buffer {
my ($self) = @_;
if (@valign_buffer) {
foreach (@valign_buffer) {
$self->valign_output_step_D( @{$_} );
}
@valign_buffer = ();
}
$valign_buffer_filling = "";
return;
}
sub reduce_valign_buffer_indentation {
my ( $self, $diff ) = @_;
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;
}
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, @args ) = @_;
my $seqno_string = get_seqno_string();
my $last_nonblank_seqno_string = get_last_nonblank_seqno_string();
# 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];
}
else {
$self->valign_output_step_D(@args);
}
# 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 ( $seqno_string =~ /^\d+(\:+\d+)+$/
&& $args[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;
}
}
###############################
# CODE SECTION 9: Output Step D
###############################
sub valign_output_step_D {
###############################################################
# This is Step D in writing vertically aligned lines.
# It is the end of the vertical alignment pipeline.
# Write one vertically aligned line of code to the output object.
###############################################################
my ( $self, $line, $leading_space_count, $level, $Kend ) = @_;
# The line is currently correct if there is no tabbing (recommended!)
# We may have to lop off some leading spaces and replace with tabs.
if ( $leading_space_count > 0 ) {
my $rOpts_indent_columns = $self->[_rOpts_indent_columns_];
my $rOpts_tabs = $self->[_rOpts_tabs_];
my $rOpts_entab_leading_whitespace =
$self->[_rOpts_entab_leading_whitespace_];
# Nothing to do if no tabs
if ( !( $rOpts_tabs || $rOpts_entab_leading_whitespace )
|| $rOpts_indent_columns <= 0 )
{
# nothing to do
}
# Handle entab option
elsif ($rOpts_entab_leading_whitespace) {
# Patch 12-nov-2018 based on report from Glenn. Extra padding was
# not correctly entabbed, nor were side comments: Increase leading
# space count for a padded line to get correct tabbing
if ( $line =~ /^(\s+)(.*)$/ ) {
my $spaces = length($1);
if ( $spaces > $leading_space_count ) {
$leading_space_count = $spaces;
}
}
my $space_count =
$leading_space_count % $rOpts_entab_leading_whitespace;
my $tab_count =
int( $leading_space_count / $rOpts_entab_leading_whitespace );
my $leading_string = "\t" x $tab_count . ' ' x $space_count;
if ( $line =~ /^\s{$leading_space_count,$leading_space_count}/ ) {
substr( $line, 0, $leading_space_count ) = $leading_string;
}
else {
# shouldn't happen - program error counting whitespace
# - skip entabbing
DEBUG_TABS
&& $self->warning(
"Error entabbing in valign_output_step_D: expected count=$leading_space_count\n"
);
}
}
# Handle option of one tab per level
else {
my $leading_string = ( "\t" x $level );
my $space_count =
$leading_space_count - $level * $rOpts_indent_columns;
# shouldn't happen:
if ( $space_count < 0 ) {
# But it could be an outdented comment
if ( $line !~ /^\s*#/ ) {
DEBUG_TABS
&& $self->warning(
"Error entabbing in valign_output_step_D: for level=$level count=$leading_space_count\n"
);
}
$leading_string = ( ' ' x $leading_space_count );
}
else {
$leading_string .= ( ' ' x $space_count );
}
if ( $line =~ /^\s{$leading_space_count,$leading_space_count}/ ) {
substr( $line, 0, $leading_space_count ) = $leading_string;
}
else {
# shouldn't happen - program error counting whitespace
# we'll skip entabbing
DEBUG_TABS
&& $self->warning(
"Error entabbing in valign_output_step_D: expected count=$leading_space_count\n"
);
}
}
}
my $file_writer_object = $self->[_file_writer_object_];
$file_writer_object->write_code_line( $line . "\n", $Kend );
return;
}
{ ## closure for sub get_leading_string
my @leading_string_cache;
sub initialize_leading_string_cache {
@leading_string_cache = ();
return;
}
sub get_leading_string {
# define the leading whitespace string for this line..
my ( $self, $leading_whitespace_count, $group_level ) = @_;
# Handle case of zero whitespace, which includes multi-line quotes
# (which may have a finite level; this prevents tab problems)
if ( $leading_whitespace_count <= 0 ) {
return "";
}
# look for previous result
elsif ( $leading_string_cache[$leading_whitespace_count] ) {
return $leading_string_cache[$leading_whitespace_count];
}
# must compute a string for this number of spaces
my $leading_string;
# Handle simple case of no tabs
my $rOpts_indent_columns = $self->[_rOpts_indent_columns_];
my $rOpts_tabs = $self->[_rOpts_tabs_];
my $rOpts_entab_leading_whitespace =
$self->[_rOpts_entab_leading_whitespace_];
if ( !( $rOpts_tabs || $rOpts_entab_leading_whitespace )
|| $rOpts_indent_columns <= 0 )
{
$leading_string = ( ' ' x $leading_whitespace_count );
}
# Handle entab option
elsif ($rOpts_entab_leading_whitespace) {
my $space_count =
$leading_whitespace_count % $rOpts_entab_leading_whitespace;
my $tab_count = int(
$leading_whitespace_count / $rOpts_entab_leading_whitespace );
$leading_string = "\t" x $tab_count . ' ' x $space_count;
}
# Handle option of one tab per level
else {
$leading_string = ( "\t" x $group_level );
my $space_count =
$leading_whitespace_count - $group_level * $rOpts_indent_columns;
# shouldn't happen:
if ( $space_count < 0 ) {
DEBUG_TABS
&& $self->warning(
"Error in get_leading_string: for level=$group_level count=$leading_whitespace_count\n"
);
# -- skip entabbing
$leading_string = ( ' ' x $leading_whitespace_count );
}
else {
$leading_string .= ( ' ' x $space_count );
}
}
$leading_string_cache[$leading_whitespace_count] = $leading_string;
return $leading_string;
}
} # end get_leading_string
##########################
# CODE SECTION 10: Summary
##########################
sub report_anything_unusual {
my $self = shift;
my $outdented_line_count = $self->[_outdented_line_count_];
if ( $outdented_line_count > 0 ) {
$self->write_logfile_entry(
"$outdented_line_count long lines were outdented:\n");
my $first_outdented_line_at = $self->[_first_outdented_line_at_];
$self->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_];
$self->write_logfile_entry(
" Last at output line $last_outdented_line_at\n");
}
$self->write_logfile_entry(
" use -noll to prevent outdenting, -l=n to increase line length\n"
);
$self->write_logfile_entry("\n");
}
return;
}
1;
Perl-Tidy-20210717/lib/Perl/Tidy/Debugger.pm 0000644 0001750 0001750 00000006710 14073571540 017303 0 ustar steve steve #####################################################################
#
# The Perl::Tidy::Debugger class shows line tokenization
#
#####################################################################
package Perl::Tidy::Debugger;
use strict;
use warnings;
our $VERSION = '20210717';
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;
}
sub really_open_debug_file {
my $self = shift;
my $debug_file = $self->{_debug_file};
my $is_encoded_data = $self->{_is_encoded_data};
my ( $fh, $filename ) =
Perl::Tidy::streamhandle( $debug_file, 'w', $is_encoded_data );
if ( !$fh ) {
Perl::Tidy::Warn("can't open $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;
}
sub close_debug_file {
my $self = shift;
my $fh = $self->{_fh};
if ( $self->{_debug_file_opened} ) {
if ( !eval { $self->{_fh}->close(); 1 } ) {
# ok, maybe no close function
}
}
return;
}
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 $input_line = $line_of_tokens->{_line_text};
my $rtoken_type = $line_of_tokens->{_rtoken_type};
my $rtokens = $line_of_tokens->{_rtokens};
my $rlevels = $line_of_tokens->{_rlevels};
my $rslevels = $line_of_tokens->{_rslevels};
my $rblock_type = $line_of_tokens->{_rblock_type};
my $input_line_number = $line_of_tokens->{_line_number};
my $line_type = $line_of_tokens->{_line_type};
my ( $j, $num );
my $token_str = "$input_line_number: ";
my $reconstructed_original = "$input_line_number: ";
my $block_str = "$input_line_number: ";
my $pattern = "";
my @next_char = ( '"', '"' );
my $i_next = 0;
unless ( $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];
$block_str .= "($rblock_type->[$j])";
$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 ' ' ) {
$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;
}
1;
Perl-Tidy-20210717/lib/Perl/Tidy/IOScalarArray.pm 0000644 0001750 0001750 00000005753 14073571547 020230 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 = '20210717';
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 <[1];
if ( $mode ne 'r' ) {
confess <[2]++;
return $self->[0]->[$i];
}
sub print {
my ( $self, $msg ) = @_;
my $mode = $self->[1];
if ( $mode ne 'w' ) {
confess <[0] }, $msg;
return;
}
sub close { return }
1;
Perl-Tidy-20210717/lib/Perl/Tidy/Tokenizer.pm 0000644 0001750 0001750 00001232507 14073571553 017543 0 ustar steve steve #####################################################################
#
# The Perl::Tidy::Tokenizer package is essentially a filter which
# reads lines of perl source code from a source object and provides
# corresponding tokenized lines through its get_line() method. Lines
# flow from the source_object to the caller like this:
#
# source_object --> LineBuffer_object --> Tokenizer --> calling routine
# get_line() get_line() get_line() line_of_tokens
#
# The source object can be any object with a get_line() method which
# supplies one line (a character string) perl call.
# The LineBuffer object is created by the Tokenizer.
# The Tokenizer returns a reference to a data structure 'line_of_tokens'
# containing one tokenized line for each call to its get_line() method.
#
# WARNING: This is not a real class. Only one tokenizer my be used.
#
########################################################################
package Perl::Tidy::Tokenizer;
use strict;
use warnings;
our $VERSION = '20210717';
use Perl::Tidy::LineBuffer;
use Carp;
# PACKAGE VARIABLES for processing an entire FILE.
# These must be package variables because most may get localized during
# processing. Most are initialized in sub prepare_for_a_new_file.
use vars qw{
$tokenizer_self
$last_nonblank_token
$last_nonblank_type
$last_nonblank_block_type
$statement_type
$in_attribute_list
$current_package
$context
%is_constant
%is_user_function
%user_function_prototype
%is_block_function
%is_block_list_function
%saw_function_definition
%saw_use_module
$brace_depth
$paren_depth
$square_bracket_depth
@current_depth
@total_depth
$total_depth
@nesting_sequence_number
@current_sequence_number
@paren_type
@paren_semicolon_count
@paren_structural_type
@brace_type
@brace_structural_type
@brace_context
@brace_package
@square_bracket_type
@square_bracket_structural_type
@depth_array
@nested_ternary_flag
@nested_statement_type
@starting_line_of_current_depth
};
# GLOBAL CONSTANTS for routines in this package,
# Initialized in a BEGIN block.
use vars qw{
%is_indirect_object_taker
%is_block_operator
%expecting_operator_token
%expecting_operator_types
%expecting_term_types
%expecting_term_token
%is_digraph
%is_file_test_operator
%is_trigraph
%is_tetragraph
%is_valid_token_type
%is_keyword
%is_code_block_token
%really_want_term
@opening_brace_names
@closing_brace_names
%is_keyword_taking_list
%is_keyword_taking_optional_arg
%is_keyword_rejecting_slash_as_pattern_delimiter
%is_keyword_rejecting_question_as_pattern_delimiter
%is_q_qq_qw_qx_qr_s_y_tr_m
%is_sub
%is_package
%is_comma_question_colon
%other_line_endings
$code_skipping_pattern_begin
$code_skipping_pattern_end
};
# GLOBAL VARIABLES which are constant after being configured by user-supplied
# parameters. They remain constant as a file is being processed.
my (
$rOpts_code_skipping,
$code_skipping_pattern_begin,
$code_skipping_pattern_end,
);
# 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
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_pod_ => $i++,
_in_skipped_ => $i++,
_in_attribute_list_ => $i++,
_in_quote_ => $i++,
_quote_target_ => $i++,
_line_start_quote_ => $i++,
_starting_level_ => $i++,
_know_starting_level_ => $i++,
_tabsize_ => $i++,
_indent_columns_ => $i++,
_look_for_hash_bang_ => $i++,
_trim_qw_ => $i++,
_continuation_indentation_ => $i++,
_outdent_labels_ => $i++,
_last_line_number_ => $i++,
_saw_perl_dash_P_ => $i++,
_saw_perl_dash_w_ => $i++,
_saw_use_strict_ => $i++,
_saw_v_string_ => $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++,
_line_buffer_object_ => $i++,
_debugger_object_ => $i++,
_diagnostics_object_ => $i++,
_logger_object_ => $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++,
_extended_syntax_ => $i++,
_maximum_level_ => $i++,
_true_brace_error_count_ => $i++,
_rOpts_maximum_level_errors_ => $i++,
_rOpts_maximum_unexpected_errors_ => $i++,
_rOpts_logfile_ => $i++,
_rOpts_ => $i++,
};
}
{ ## 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;
$self->_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 <{$opt_name};
unless ($param) { $param = $default }
$param =~ s/^\s*//; # allow leading spaces to be like format-skipping
if ( $param !~ /^#/ ) {
Die("ERROR: the $opt_name parameter '$param' must begin with '#'\n");
}
my $pattern = '^\s*' . $param . '\b';
if ( bad_pattern($pattern) ) {
Die(
"ERROR: the $opt_name parameter '$param' causes the invalid regex '$pattern'\n"
);
}
return $pattern;
}
sub check_options {
# Check Tokenizer parameters
my $rOpts = shift;
%is_sub = ();
$is_sub{'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;
}
}
$rOpts_code_skipping = $rOpts->{'code-skipping'};
$code_skipping_pattern_begin =
make_code_skipping_pattern( $rOpts, 'code-skipping-begin', '#<>V' );
return;
}
sub new {
my ( $class, @args ) = @_;
# Note: 'tabs' and 'indent_columns' are temporary and should be
# removed asap
my %defaults = (
source_object => undef,
debugger_object => undef,
diagnostics_object => undef,
logger_object => undef,
starting_level => undef,
indent_columns => 4,
tabsize => 8,
look_for_hash_bang => 0,
trim_qw => 1,
look_for_autoloader => 1,
look_for_selfloader => 1,
starting_line_number => 1,
extended_syntax => 0,
rOpts => {},
);
my %args = ( %defaults, @args );
# we are given an object with a get_line() method to supply source lines
my $source_object = $args{source_object};
my $rOpts = $args{rOpts};
# we create another object with a get_line() and peek_ahead() method
my $line_buffer_object = Perl::Tidy::LineBuffer->new($source_object);
# Tokenizer state data is as follows:
# _rhere_target_list_ reference to list of here-doc targets
# _here_doc_target_ the target string for a here document
# _here_quote_character_ the type of here-doc quoting (" ' ` or none)
# to determine if interpolation is done
# _quote_target_ character we seek if chasing a quote
# _line_start_quote_ line where we started looking for a long quote
# _in_here_doc_ flag indicating if we are in a here-doc
# _in_pod_ flag set if we are in pod documentation
# _in_skipped_ flag set if we are in a skipped section
# _in_error_ flag set if we saw severe error (binary in script)
# _in_data_ flag set if we are in __DATA__ section
# _in_end_ flag set if we are in __END__ section
# _in_format_ flag set if we are in a format description
# _in_attribute_list_ flag telling if we are looking for attributes
# _in_quote_ flag telling if we are chasing a quote
# _starting_level_ indentation level of first line
# _line_buffer_object_ object with get_line() method to supply source code
# _diagnostics_object_ place to write debugging information
# _unexpected_error_count_ error count used to limit output
# _lower_case_labels_at_ line numbers where lower case labels seen
# _hit_bug_ program bug detected
my $self = [];
$self->[_rhere_target_list_] = [];
$self->[_in_here_doc_] = 0;
$self->[_here_doc_target_] = "";
$self->[_here_quote_character_] = "";
$self->[_in_data_] = 0;
$self->[_in_end_] = 0;
$self->[_in_format_] = 0;
$self->[_in_error_] = 0;
$self->[_in_pod_] = 0;
$self->[_in_skipped_] = 0;
$self->[_in_attribute_list_] = 0;
$self->[_in_quote_] = 0;
$self->[_quote_target_] = "";
$self->[_line_start_quote_] = -1;
$self->[_starting_level_] = $args{starting_level};
$self->[_know_starting_level_] = defined( $args{starting_level} );
$self->[_tabsize_] = $args{tabsize};
$self->[_indent_columns_] = $args{indent_columns};
$self->[_look_for_hash_bang_] = $args{look_for_hash_bang};
$self->[_trim_qw_] = $args{trim_qw};
$self->[_continuation_indentation_] = $args{continuation_indentation};
$self->[_outdent_labels_] = $args{outdent_labels};
$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_v_string_] = 0;
$self->[_hit_bug_] = 0;
$self->[_look_for_autoloader_] = $args{look_for_autoloader};
$self->[_look_for_selfloader_] = $args{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->[_line_buffer_object_] = $line_buffer_object;
$self->[_debugger_object_] = $args{debugger_object};
$self->[_diagnostics_object_] = $args{diagnostics_object};
$self->[_logger_object_] = $args{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_] = "";
$self->[_rlower_case_labels_at_] = undef;
$self->[_extended_syntax_] = $args{extended_syntax};
$self->[_maximum_level_] = 0;
$self->[_true_brace_error_count_] = 0;
$self->[_rOpts_maximum_level_errors_] = $rOpts->{'maximum-level-errors'};
$self->[_rOpts_maximum_unexpected_errors_] =
$rOpts->{'maximum-unexpected-errors'};
$self->[_rOpts_logfile_] = $rOpts->{'logfile'};
$self->[_rOpts_] = $rOpts;
bless $self, $class;
$tokenizer_self = $self;
prepare_for_a_new_file();
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;
}
# interface to Perl::Tidy::Logger routines
sub warning {
my $msg = shift;
my $logger_object = $tokenizer_self->[_logger_object_];
if ($logger_object) {
$logger_object->warning($msg);
}
return;
}
sub complain {
my $msg = shift;
my $logger_object = $tokenizer_self->[_logger_object_];
if ($logger_object) {
$logger_object->complain($msg);
}
return;
}
sub write_logfile_entry {
my $msg = shift;
my $logger_object = $tokenizer_self->[_logger_object_];
if ($logger_object) {
$logger_object->write_logfile_entry($msg);
}
return;
}
sub interrupt_logfile {
my $logger_object = $tokenizer_self->[_logger_object_];
if ($logger_object) {
$logger_object->interrupt_logfile();
}
return;
}
sub resume_logfile {
my $logger_object = $tokenizer_self->[_logger_object_];
if ($logger_object) {
$logger_object->resume_logfile();
}
return;
}
sub increment_brace_error {
my $logger_object = $tokenizer_self->[_logger_object_];
if ($logger_object) {
$logger_object->increment_brace_error();
}
return;
}
sub report_definite_bug {
$tokenizer_self->[_hit_bug_] = 1;
my $logger_object = $tokenizer_self->[_logger_object_];
if ($logger_object) {
$logger_object->report_definite_bug();
}
return;
}
sub brace_warning {
my $msg = shift;
my $logger_object = $tokenizer_self->[_logger_object_];
if ($logger_object) {
$logger_object->brace_warning($msg);
}
return;
}
sub get_saw_brace_error {
my $logger_object = $tokenizer_self->[_logger_object_];
if ($logger_object) {
return $logger_object->get_saw_brace_error();
}
else {
return 0;
}
}
sub get_unexpected_error_count {
my ($self) = @_;
return $self->[_unexpected_error_count_];
}
# interface to Perl::Tidy::Diagnostics routines
sub write_diagnostics {
my $msg = shift;
if ( $tokenizer_self->[_diagnostics_object_] ) {
$tokenizer_self->[_diagnostics_object_]->write_diagnostics($msg);
}
return;
}
sub get_maximum_level {
return $tokenizer_self->[_maximum_level_];
}
sub report_tokenization_errors {
my ($self) = @_;
# Report any tokenization errors and return a flag '$severe_error'.
# Set $severe_error = 1 if the tokenizations 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)
my $severe_error = $self->[_in_error_];
my $maxle = $self->[_rOpts_maximum_level_errors_];
my $maxue = $self->[_rOpts_maximum_unexpected_errors_];
$maxle = 1 unless defined($maxle);
$maxue = 0 unless defined($maxue);
my $level = get_indentation_level();
if ( $level != $tokenizer_self->[_starting_level_] ) {
warning("final indentation level: $level\n");
my $level_diff = $tokenizer_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;
warning(<[_true_brace_error_count_] > 2 ) {
$severe_error = 1;
}
if ( $tokenizer_self->[_look_for_hash_bang_]
&& !$tokenizer_self->[_saw_hash_bang_] )
{
warning(
"hit EOF without seeing hash-bang line; maybe don't need -x?\n");
}
if ( $tokenizer_self->[_in_format_] ) {
warning("hit EOF while in format description\n");
}
if ( $tokenizer_self->[_in_skipped_] ) {
write_logfile_entry(
"hit EOF while in lines skipped with --code-skipping\n");
}
if ( $tokenizer_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 ( $tokenizer_self->[_saw_data_] || $tokenizer_self->[_saw_end_] ) {
write_logfile_entry(
"hit eof while in pod documentation (no =cut seen)\n\tthis can cause trouble with some pod utilities\n"
);
}
else {
complain(
"hit eof while in pod documentation (no =cut seen)\n\tthis can cause trouble with some pod utilities\n"
);
}
}
if ( $tokenizer_self->[_in_here_doc_] ) {
$severe_error = 1;
my $here_doc_target = $tokenizer_self->[_here_doc_target_];
my $started_looking_for_here_target_at =
$tokenizer_self->[_started_looking_for_here_target_at_];
if ($here_doc_target) {
warning(
"hit EOF in here document starting at line $started_looking_for_here_target_at with target: $here_doc_target\n"
);
}
else {
warning(
"hit EOF in here document starting at line $started_looking_for_here_target_at with empty target string\n"
);
}
my $nearly_matched_here_target_at =
$tokenizer_self->[_nearly_matched_here_target_at_];
if ($nearly_matched_here_target_at) {
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 ( $tokenizer_self->[_in_quote_] ) {
$severe_error = 1;
my $line_start_quote = $tokenizer_self->[_line_start_quote_];
my $quote_target = $tokenizer_self->[_quote_target_];
my $what =
( $tokenizer_self->[_in_attribute_list_] )
? "attribute list"
: "quote/pattern";
warning(
"hit EOF seeking end of $what starting at line $line_start_quote ending in $quote_target\n"
);
}
if ( $tokenizer_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 = $tokenizer_self->[_unexpected_error_count_];
if ( $maxue > 0 && $ue_count > $maxue ) {
warning(< -maxue=$maxue; use -maxue=0 to force formatting
EOM
$severe_error = 1;
}
unless ( $tokenizer_self->[_saw_perl_dash_w_] ) {
if ( $] < 5.006 ) {
write_logfile_entry("Suggest including '-w parameter'\n");
}
else {
write_logfile_entry("Suggest including 'use warnings;'\n");
}
}
if ( $tokenizer_self->[_saw_perl_dash_P_] ) {
write_logfile_entry("Use of -P parameter for defines is discouraged\n");
}
unless ( $tokenizer_self->[_saw_use_strict_] ) {
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 ( $tokenizer_self->[_rlower_case_labels_at_] ) {
my @lower_case_labels_at =
@{ $tokenizer_self->[_rlower_case_labels_at_] };
write_logfile_entry(
"Suggest using upper case characters in label(s)\n");
local $" = ')(';
write_logfile_entry(" defined at line(s): (@lower_case_labels_at)\n");
}
return $severe_error;
}
sub report_v_string {
# warn if this version can't handle v-strings
my $tok = shift;
unless ( $tokenizer_self->[_saw_v_string_] ) {
$tokenizer_self->[_saw_v_string_] =
$tokenizer_self->[_last_line_number_];
}
if ( $] < 5.006 ) {
warning(
"Found v-string '$tok' but v-strings are not implemented in your version of perl; see Camel 3 book ch 2\n"
);
}
return;
}
sub get_input_line_number {
return $tokenizer_self->[_last_line_number_];
}
# returns the next tokenized line
sub get_line {
my $self = shift;
# USES GLOBAL VARIABLES: $tokenizer_self, $brace_depth,
# $square_bracket_depth, $paren_depth
my $input_line = $tokenizer_self->[_line_buffer_object_]->get_line();
$tokenizer_self->[_line_of_text_] = $input_line;
return unless ($input_line);
my $input_line_number = ++$tokenizer_self->[_last_line_number_];
my $write_logfile_entry = sub {
my ($msg) = @_;
write_logfile_entry("Line $input_line_number: $msg");
};
# Find and remove what characters terminate this line, including any
# control r
my $input_line_separator = "";
if ( chomp($input_line) ) { $input_line_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 = $2 . $input_line_separator;
}
}
# for backwards compatibility we keep the line text terminated with
# a newline character
$input_line .= "\n";
$tokenizer_self->[_line_of_text_] = $input_line; # update
# 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, '.'
# 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,
_quote_character => '',
## _rtoken_type => undef,
## _rtokens => undef,
## _rlevels => undef,
## _rslevels => undef,
## _rblock_type => undef,
## _rcontainer_type => undef,
## _rcontainer_environment => undef,
## _rtype_sequence => undef,
## _rnesting_tokens => undef,
## _rci_levels => undef,
## _rnesting_blocks => undef,
## _starting_in_quote => 0,
## _ending_in_quote => 0,
};
# must print line unchanged if we are in a here document
if ( $tokenizer_self->[_in_here_doc_] ) {
$line_of_tokens->{_line_type} = 'HERE';
my $here_doc_target = $tokenizer_self->[_here_doc_target_];
my $here_quote_character = $tokenizer_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 ) {
$tokenizer_self->[_nearly_matched_here_target_at_] = undef;
$line_of_tokens->{_line_type} = 'HERE_END';
$write_logfile_entry->("Exiting HERE document $here_doc_target\n");
my $rhere_target_list = $tokenizer_self->[_rhere_target_list_];
if ( @{$rhere_target_list} ) { # there can be multiple here targets
( $here_doc_target, $here_quote_character ) =
@{ shift @{$rhere_target_list} };
$tokenizer_self->[_here_doc_target_] = $here_doc_target;
$tokenizer_self->[_here_quote_character_] =
$here_quote_character;
$write_logfile_entry->(
"Entering HERE document $here_doc_target\n");
$tokenizer_self->[_nearly_matched_here_target_at_] = undef;
$tokenizer_self->[_started_looking_for_here_target_at_] =
$input_line_number;
}
else {
$tokenizer_self->[_in_here_doc_] = 0;
$tokenizer_self->[_here_doc_target_] = "";
$tokenizer_self->[_here_quote_character_] = "";
}
}
# check for error of extra whitespace
# note for PERL6: leading whitespace is allowed
else {
$candidate_target =~ s/\s*$//;
$candidate_target =~ s/^\s*//;
if ( $candidate_target eq $here_doc_target ) {
$tokenizer_self->[_nearly_matched_here_target_at_] =
$input_line_number;
}
}
return $line_of_tokens;
}
# Print line unchanged if we are in a format section
elsif ( $tokenizer_self->[_in_format_] ) {
if ( $input_line =~ /^\.[\s#]*$/ ) {
# Decrement format depth count at a '.' after a 'format'
$tokenizer_self->[_in_format_]--;
# This is the end when count reaches 0
if ( !$tokenizer_self->[_in_format_] ) {
$write_logfile_entry->("Exiting format section\n");
$line_of_tokens->{_line_type} = 'FORMAT_END';
}
}
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).
$tokenizer_self->[_in_format_]++;
}
}
return $line_of_tokens;
}
# must print line unchanged if we are in pod documentation
elsif ( $tokenizer_self->[_in_pod_] ) {
$line_of_tokens->{_line_type} = 'POD';
if ( $input_line =~ /^=cut/ ) {
$line_of_tokens->{_line_type} = 'POD_END';
$write_logfile_entry->("Exiting POD section\n");
$tokenizer_self->[_in_pod_] = 0;
}
if ( $input_line =~ /^\#\!.*perl\b/ && !$tokenizer_self->[_in_end_] ) {
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 ( $tokenizer_self->[_in_skipped_] ) {
# NOTE: marked as the existing type 'FORMAT' to keep html working
$line_of_tokens->{_line_type} = 'FORMAT';
if ( $input_line =~ /$code_skipping_pattern_end/ ) {
$write_logfile_entry->("Exiting code-skipping section\n");
$tokenizer_self->[_in_skipped_] = 0;
}
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 ( $tokenizer_self->[_in_error_] ) {
$line_of_tokens->{_line_type} = 'ERROR';
return $line_of_tokens;
}
# print line unchanged if we are __DATA__ section
elsif ( $tokenizer_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';
$write_logfile_entry->("Entering POD section\n");
$tokenizer_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 ( $tokenizer_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';
$write_logfile_entry->("Entering POD section\n");
$tokenizer_self->[_in_pod_] = 1;
return $line_of_tokens;
}
else {
$line_of_tokens->{_line_type} = 'END';
return $line_of_tokens;
}
}
# check for a hash-bang line if we haven't seen one
if ( !$tokenizer_self->[_saw_hash_bang_] ) {
if ( $input_line =~ /^\#\!.*perl\b/ ) {
$tokenizer_self->[_saw_hash_bang_] = $input_line_number;
# check for -w and -P flags
if ( $input_line =~ /^\#\!.*perl\s.*-.*P/ ) {
$tokenizer_self->[_saw_perl_dash_P_] = 1;
}
if ( $input_line =~ /^\#\!.*perl\s.*-.*w/ ) {
$tokenizer_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'
)
&& !$tokenizer_self->[_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 ( $tokenizer_self->[_started_tokenizing_] ) {
warning(
"There seems to be a hash-bang after line 1; do you need to run with -x ?\n"
);
}
else {
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 ( $tokenizer_self->[_look_for_hash_bang_]
&& !$tokenizer_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_skipped_
# _in_pod_
# _in_quote_
my $ending_in_quote_last = $tokenizer_self->[_in_quote_];
tokenize_this_line($line_of_tokens);
# Now finish defining the return structure and return it
$line_of_tokens->{_ending_in_quote} = $tokenizer_self->[_in_quote_];
# handle severe error (binary data in script)
if ( $tokenizer_self->[_in_error_] ) {
$tokenizer_self->[_in_quote_] = 0; # to avoid any more messages
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 ( $tokenizer_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 ( $tokenizer_self->[_saw_data_] || $tokenizer_self->[_saw_end_] )
{
complain("=cut while not in pod ignored\n");
$tokenizer_self->[_in_pod_] = 0;
$line_of_tokens->{_line_type} = 'POD_END';
}
else {
$line_of_tokens->{_line_type} = 'POD_START';
warning(
"=cut starts a pod section .. this can fool pod utilities.\n"
);
$write_logfile_entry->("Entering POD section\n");
}
}
else {
$line_of_tokens->{_line_type} = 'POD_START';
$write_logfile_entry->("Entering POD section\n");
}
return $line_of_tokens;
}
# handle start of skipped section
if ( $tokenizer_self->[_in_skipped_] ) {
# NOTE: marked as the existing type 'FORMAT' to keep html working
$line_of_tokens->{_line_type} = 'FORMAT';
$write_logfile_entry->("Entering code-skipping section\n");
return $line_of_tokens;
}
# Update indentation levels for log messages.
# Skip blank lines and also block comments, unless a logfile is requested.
# Note that _line_of_text_ is the input line but trimmed from left to right.
my $lot = $tokenizer_self->[_line_of_text_];
if ( $lot && ( $self->[_rOpts_logfile_] || substr( $lot, 0, 1 ) ne '#' ) ) {
my $rlevels = $line_of_tokens->{_rlevels};
$line_of_tokens->{_guessed_indentation_level} =
guess_old_indentation_level($input_line);
}
# see if this line contains here doc targets
my $rhere_target_list = $tokenizer_self->[_rhere_target_list_];
if ( @{$rhere_target_list} ) {
my ( $here_doc_target, $here_quote_character ) =
@{ shift @{$rhere_target_list} };
$tokenizer_self->[_in_here_doc_] = 1;
$tokenizer_self->[_here_doc_target_] = $here_doc_target;
$tokenizer_self->[_here_quote_character_] = $here_quote_character;
$write_logfile_entry->("Entering HERE document $here_doc_target\n");
$tokenizer_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 ( $tokenizer_self->[_in_data_] ) {
$line_of_tokens->{_line_type} = 'DATA_START';
$write_logfile_entry->("Starting __DATA__ section\n");
$tokenizer_self->[_saw_data_] = 1;
# keep parsing after __DATA__ if use SelfLoader was seen
if ( $tokenizer_self->[_saw_selfloader_] ) {
$tokenizer_self->[_in_data_] = 0;
$write_logfile_entry->(
"SelfLoader seen, continuing; -nlsl deactivates\n");
}
return $line_of_tokens;
}
elsif ( $tokenizer_self->[_in_end_] ) {
$line_of_tokens->{_line_type} = 'END_START';
$write_logfile_entry->("Starting __END__ section\n");
$tokenizer_self->[_saw_end_] = 1;
# keep parsing after __END__ if use AutoLoader was seen
if ( $tokenizer_self->[_saw_autoloader_] ) {
$tokenizer_self->[_in_end_] = 0;
$write_logfile_entry->(
"AutoLoader seen, continuing; -nlal deactivates\n");
}
return $line_of_tokens;
}
# 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 ( !$tokenizer_self->[_started_tokenizing_]
&& $input_line !~ /^\s*$/
&& $input_line !~ /^\s*#/ )
{
$tokenizer_self->[_started_tokenizing_] = 1;
}
if ( $tokenizer_self->[_debugger_object_] ) {
$tokenizer_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 ( $tokenizer_self->[_in_format_] ) {
$write_logfile_entry->("Entering format section\n");
}
if ( $tokenizer_self->[_in_quote_]
and ( $tokenizer_self->[_line_start_quote_] < 0 ) )
{
#if ( ( my $quote_target = get_quote_target() ) !~ /^\s*$/ ) {
if ( ( my $quote_target = $tokenizer_self->[_quote_target_] ) !~
/^\s*$/ )
{
$tokenizer_self->[_line_start_quote_] = $input_line_number;
$write_logfile_entry->(
"Start multi-line quote or pattern ending in $quote_target\n");
}
}
elsif ( ( $tokenizer_self->[_line_start_quote_] >= 0 )
&& !$tokenizer_self->[_in_quote_] )
{
$tokenizer_self->[_line_start_quote_] = -1;
$write_logfile_entry->("End of multi-line quote or pattern\n");
}
# we are returning a line of CODE
return $line_of_tokens;
}
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.
#
# USES GLOBAL VARIABLES: $tokenizer_self
my $starting_level = 0;
# use value if given as parameter
if ( $tokenizer_self->[_know_starting_level_] ) {
$starting_level = $tokenizer_self->[_starting_level_];
}
# if we know there is a hash_bang line, the level must be zero
elsif ( $tokenizer_self->[_look_for_hash_bang_] ) {
$tokenizer_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
my $msg = "";
while ( $line =
$tokenizer_self->[_line_buffer_object_]->peek_ahead( $i++ ) )
{
# if first line is #! then assume starting level is zero
if ( $i == 1 && $line =~ /^\#\!/ ) {
$starting_level = 0;
last;
}
next if ( $line =~ /^\s*#/ ); # skip past comments
next if ( $line =~ /^\s*$/ ); # skip past blank lines
$starting_level = guess_old_indentation_level($line);
last;
}
$msg = "Line $i implies starting-indentation-level = $starting_level\n";
write_logfile_entry("$msg");
}
$tokenizer_self->[_starting_level_] = $starting_level;
reset_indentation_level($starting_level);
return;
}
sub guess_old_indentation_level {
my ($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: $tokenizer_self
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) * $tokenizer_self->[_tabsize_] }
if ($2) { $spaces += length($2) }
# correct for outdented labels
if ( $3 && $tokenizer_self->[_outdent_labels_] ) {
$spaces += $tokenizer_self->[_continuation_indentation_];
}
}
# compute indentation using the value of -i for this run.
# If -i=0 is used for this run (which is possible) it doesn't matter
# what we do here but we'll guess that the old run used 4 spaces per level.
my $indent_columns = $tokenizer_self->[_indent_columns_];
$indent_columns = 4 if ( !$indent_columns );
$level = int( $spaces / $indent_columns );
return ($level);
}
# This is a currently unused debug routine
sub dump_functions {
my $fh = *STDOUT;
foreach my $pkg ( keys %is_user_function ) {
$fh->print("\nnon-constant subs in package $pkg\n");
foreach my $sub ( keys %{ $is_user_function{$pkg} } ) {
my $msg = "";
if ( $is_block_list_function{$pkg}{$sub} ) {
$msg = 'block_list';
}
if ( $is_block_function{$pkg}{$sub} ) {
$msg = 'block';
}
$fh->print("$sub $msg\n");
}
}
foreach my $pkg ( keys %is_constant ) {
$fh->print("\nconstants and constant subs in package $pkg\n");
foreach my $sub ( keys %{ $is_constant{$pkg} } ) {
$fh->print("$sub\n");
}
}
return;
}
sub prepare_for_a_new_file {
# 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 = '';
# scalars for remembering statement types across multiple lines
$statement_type = ''; # '' or 'use' or 'sub..' or 'case..'
$in_attribute_list = 0;
# scalars for remembering where we are in the file
$current_package = "main";
$context = UNKNOWN_CONTEXT;
# hashes used to remember function information
%is_constant = (); # user-defined constants
%is_user_function = (); # user-defined functions
%user_function_prototype = (); # their prototypes
%is_block_function = ();
%is_block_list_function = ();
%saw_function_definition = ();
%saw_use_module = ();
# variables used to track depths of various containers
# and report nesting errors
$paren_depth = 0;
$brace_depth = 0;
$square_bracket_depth = 0;
@current_depth = (0) x scalar @closing_brace_names;
$total_depth = 0;
@total_depth = ();
@nesting_sequence_number = ( 0 .. @closing_brace_names - 1 );
@current_sequence_number = ();
@paren_type = ();
@paren_semicolon_count = ();
@paren_structural_type = ();
@brace_type = ();
@brace_structural_type = ();
@brace_context = ();
@brace_package = ();
@square_bracket_type = ();
@square_bracket_structural_type = ();
@depth_array = ();
@nested_ternary_flag = ();
@nested_statement_type = ();
@starting_line_of_current_depth = ();
$paren_type[$paren_depth] = '';
$paren_semicolon_count[$paren_depth] = 0;
$paren_structural_type[$brace_depth] = '';
$brace_type[$brace_depth] = ';'; # identify opening brace as code block
$brace_structural_type[$brace_depth] = '';
$brace_context[$brace_depth] = UNKNOWN_CONTEXT;
$brace_package[$paren_depth] = $current_package;
$square_bracket_type[$square_bracket_depth] = '';
$square_bracket_structural_type[$square_bracket_depth] = '';
initialize_tokenizer_state();
return;
}
{ ## 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_container_type = []; # paren types, such as if, elsif, ..
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, $indented_if_level );
# TV5: SCALARS for tracking indentation level.
# Initialized once and continually updated as lines are
# processed.
my (
$nesting_token_string, $nesting_type_string,
$nesting_block_string, $nesting_block_flag,
$nesting_list_string, $nesting_list_flag,
$ci_string_in_tokenizer, $continuation_string_in_tokenizer,
$in_statement_continuation, $level_in_tokenizer,
$slevel_in_tokenizer, $rslevel_stack,
);
# 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_last_nonblank_block_type, $last_last_nonblank_container_type,
$last_last_nonblank_type_sequence, $last_nonblank_prototype,
);
# ----------------------------------------------------------------
# beginning of tokenizer variable access and manipulation routines
# ----------------------------------------------------------------
sub initialize_tokenizer_state {
# TV1: initialized on each call
# TV2: initialized on each call
# TV3:
$in_quote = 0;
$quote_type = 'Q';
$quote_character = "";
$quote_pos = 0;
$quote_depth = 0;
$quoted_string_1 = "";
$quoted_string_2 = "";
$allowed_quote_modifiers = "";
# TV4:
$id_scan_state = '';
$identifier = '';
$want_paren = "";
$indented_if_level = 0;
# TV5:
$nesting_token_string = "";
$nesting_type_string = "";
$nesting_block_string = '1'; # initially in a block
$nesting_block_flag = 1;
$nesting_list_string = '0'; # initially not in a list
$nesting_list_flag = 0; # initially not in a list
$ci_string_in_tokenizer = "";
$continuation_string_in_tokenizer = "0";
$in_statement_continuation = 0;
$level_in_tokenizer = 0;
$slevel_in_tokenizer = 0;
$rslevel_stack = [];
# TV6:
$last_nonblank_container_type = '';
$last_nonblank_type_sequence = '';
$last_last_nonblank_token = ';';
$last_last_nonblank_type = ';';
$last_last_nonblank_block_type = '';
$last_last_nonblank_container_type = '';
$last_last_nonblank_type_sequence = '';
$last_nonblank_prototype = "";
return;
}
sub save_tokenizer_state {
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_container_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, $indented_if_level ];
my $rTV5 = [
$nesting_token_string, $nesting_type_string,
$nesting_block_string, $nesting_block_flag,
$nesting_list_string, $nesting_list_flag,
$ci_string_in_tokenizer, $continuation_string_in_tokenizer,
$in_statement_continuation, $level_in_tokenizer,
$slevel_in_tokenizer, $rslevel_stack,
];
my $rTV6 = [
$last_nonblank_container_type,
$last_nonblank_type_sequence,
$last_last_nonblank_token,
$last_last_nonblank_type,
$last_last_nonblank_block_type,
$last_last_nonblank_container_type,
$last_last_nonblank_type_sequence,
$last_nonblank_prototype,
];
return [ $rTV1, $rTV2, $rTV3, $rTV4, $rTV5, $rTV6 ];
}
sub restore_tokenizer_state {
my ($rstate) = @_;
my ( $rTV1, $rTV2, $rTV3, $rTV4, $rTV5, $rTV6 ) = @{$rstate};
(
$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_container_type,
$routput_type_sequence, $routput_type_sequence,
) = @{$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, $indented_if_level ) =
@{$rTV4};
(
$nesting_token_string, $nesting_type_string,
$nesting_block_string, $nesting_block_flag,
$nesting_list_string, $nesting_list_flag,
$ci_string_in_tokenizer, $continuation_string_in_tokenizer,
$in_statement_continuation, $level_in_tokenizer,
$slevel_in_tokenizer, $rslevel_stack,
) = @{$rTV5};
(
$last_nonblank_container_type,
$last_nonblank_type_sequence,
$last_last_nonblank_token,
$last_last_nonblank_type,
$last_last_nonblank_block_type,
$last_last_nonblank_container_type,
$last_last_nonblank_type_sequence,
$last_nonblank_prototype,
) = @{$rTV6};
return;
}
sub get_indentation_level {
# patch to avoid reporting error if indented if is not terminated
if ($indented_if_level) { return $level_in_tokenizer - 1 }
return $level_in_tokenizer;
}
sub reset_indentation_level {
$level_in_tokenizer = $slevel_in_tokenizer = shift;
push @{$rslevel_stack}, $slevel_in_tokenizer;
return;
}
sub peeked_ahead {
my $flag = shift;
$peeked_ahead = defined($flag) ? $flag : $peeked_ahead;
return $peeked_ahead;
}
# ------------------------------------------------------------
# end of tokenizer variable access and manipulation routines
# ------------------------------------------------------------
# ------------------------------------------------------------
# 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 ($replacement_text) = @_;
# quick check
return unless ( $replacement_text =~ /<[_logger_object_];
# localize all package variables
local (
$tokenizer_self, $last_nonblank_token,
$last_nonblank_type, $last_nonblank_block_type,
$statement_type, $in_attribute_list,
$current_package, $context,
%is_constant, %is_user_function,
%user_function_prototype, %is_block_function,
%is_block_list_function, %saw_function_definition,
$brace_depth, $paren_depth,
$square_bracket_depth, @current_depth,
@total_depth, $total_depth,
@nesting_sequence_number, @current_sequence_number,
@paren_type, @paren_semicolon_count,
@paren_structural_type, @brace_type,
@brace_structural_type, @brace_context,
@brace_package, @square_bracket_type,
@square_bracket_structural_type, @depth_array,
@starting_line_of_current_depth, @nested_ternary_flag,
@nested_statement_type,
);
# save all lexical variables
my $rstate = save_tokenizer_state();
_decrement_count(); # avoid error check for multiple tokenizers
# make a new tokenizer
my $rOpts = {};
my $rpending_logfile_message;
my $source_object = Perl::Tidy::LineSource->new(
input_file => \$replacement_text,
rOpts => $rOpts,
rpending_logfile_message => $rpending_logfile_message,
);
my $tokenizer = Perl::Tidy::Tokenizer->new(
source_object => $source_object,
logger_object => $logger_object,
starting_line_number => $input_line_number,
);
# scan the replacement text
1 while ( $tokenizer->get_line() );
# remove any here doc targets
my $rht = undef;
if ( $tokenizer_self->[_in_here_doc_] ) {
$rht = [];
push @{$rht},
[
$tokenizer_self->[_here_doc_target_],
$tokenizer_self->[_here_quote_character_]
];
if ( $tokenizer_self->[_rhere_target_list_] ) {
push @{$rht}, @{ $tokenizer_self->[_rhere_target_list_] };
$tokenizer_self->[_rhere_target_list_] = undef;
}
$tokenizer_self->[_in_here_doc_] = undef;
}
# now its safe to report errors
my $severe_error = $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;
}
sub scan_bare_identifier {
( $i, $tok, $type, $prototype ) =
scan_bare_identifier_do( $input_line, $i, $tok, $type, $prototype,
$rtoken_map, $max_token_index );
return;
}
sub scan_identifier {
( $i, $tok, $type, $id_scan_state, $identifier ) =
scan_identifier_do( $i, $id_scan_state, $identifier, $rtokens,
$max_token_index, $expecting, $paren_type[$paren_depth] );
return;
}
use constant VERIFY_FASTSCAN => 0;
my %fast_scan_context;
BEGIN {
%fast_scan_context = (
'$' => SCALAR_CONTEXT,
'*' => SCALAR_CONTEXT,
'@' => LIST_CONTEXT,
'%' => LIST_CONTEXT,
'&' => UNKNOWN_CONTEXT,
);
}
sub scan_identifier_fast {
# 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.
my $i_begin = $i;
my $tok_begin = $tok;
my $fast_scan_type;
###############################
# quick scan with leading sigil
###############################
if ( !$id_scan_state
&& $i + 1 <= $max_token_index
&& $fast_scan_context{$tok} )
{
$context = $fast_scan_context{$tok};
# look for $var, @var, ...
if ( $rtoken_type->[ $i + 1 ] eq 'w' ) {
my $pretype_next = "";
my $i_next = $i + 2;
if ( $i_next <= $max_token_index ) {
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 + 1 ];
$tok = $identifier;
$type = 'i';
$i = $i + 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 + 1 ] eq '{'
&& ( $tok_begin eq '@'
|| $tok_begin eq '%' )
)
{
$identifier = $tok;
$type = 't';
$fast_scan_type = $type;
}
}
############################
# Quick scan with leading ->
# Look for ->[ and ->{
############################
elsif (
$tok eq '->'
&& $i < $max_token_index
&& ( $rtokens->[ $i + 1 ] eq '{'
|| $rtokens->[ $i + 1 ] eq '[' )
)
{
$type = $tok;
$fast_scan_type = $type;
$identifier = $tok;
$context = UNKNOWN_CONTEXT;
}
#######################################
# 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 $fast_scan_type = $type;
my $i_simple = $i;
my $context_simple = $context;
$tok = $tok_begin;
$i = $i_begin;
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 < 0;
sub scan_number_fast {
# 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 = "";
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 = scan_number();
if ( $type ne $type_simple
|| ( $i != $i_simple && $i <= $max_token_index )
|| $number ne $number_simple )
{
print STDERR < 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,
'>' => sub {
error_if_expecting_TERM()
if ( $expecting == TERM );
},
'|' => sub {
error_if_expecting_TERM()
if ( $expecting == TERM );
},
'$' => sub {
# start looking for a scalar
error_if_expecting_OPERATOR("Scalar")
if ( $expecting == OPERATOR );
scan_identifier_fast();
if ( $identifier eq '$^W' ) {
$tokenizer_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_token eq '(' )
&& $is_indirect_object_taker{ $paren_type[$paren_depth] } )
|| ( $last_nonblank_type eq 'w'
|| $last_nonblank_type eq 'U' ) # possible object
)
{
$type = 'Z';
}
},
'(' => sub {
++$paren_depth;
$paren_semicolon_count[$paren_depth] = 0;
if ($want_paren) {
$container_type = $want_paren;
$want_paren = "";
}
elsif ( $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' ) {
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 ) =
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;
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";
}
}
if ($hint) {
interrupt_logfile();
warning($hint);
resume_logfile();
}
} ## end if ( $next_nonblank_token...
} ## end else [ if ( $last_last_nonblank_token...
} ## end if ( $expecting == OPERATOR...
}
$paren_type[$paren_depth] = $container_type;
( $type_sequence, $indent_flag ) =
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 ')' ) {
warning(
"Syntax error? found token '$last_nonblank_type' then '('\n"
);
}
$paren_structural_type[$paren_depth] = $type;
},
')' => sub {
( $type_sequence, $indent_flag ) =
decrease_nesting_depth( PAREN, $rtoken_map->[$i_tok] );
if ( $paren_structural_type[$paren_depth] eq '{' ) {
$type = '}';
}
$container_type = $paren_type[$paren_depth];
# restore statement type as 'sub' at closing paren of a signature
# so that a subsequent ':' is identified as an attribute
if ( $container_type =~ /^sub\b/ ) {
$statement_type = $container_type;
}
# /^(for|foreach)$/
if ( $is_for_foreach{ $paren_type[$paren_depth] } ) {
my $num_sc = $paren_semicolon_count[$paren_depth];
if ( $num_sc > 0 && $num_sc != 2 ) {
warning("Expected 2 ';' in 'for(;;)' but saw $num_sc\n");
}
}
if ( $paren_depth > 0 ) { $paren_depth-- }
},
',' => sub {
if ( $last_nonblank_type eq ',' ) {
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 '{' )
{
warning("Unexpected leading ',' after a '('\n");
}
# patch for operator_expected: note if we are in the list (use.t)
if ( $statement_type eq 'use' ) { $statement_type = '_use' }
},
';' => sub {
$context = UNKNOWN_CONTEXT;
$statement_type = '';
$want_paren = "";
# /^(for|foreach)$/
if ( $is_for_foreach{ $paren_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 == $depth_array[PAREN][BRACE][$paren_depth]
&& $square_bracket_depth ==
$depth_array[PAREN][SQUARE_BRACKET][$paren_depth] )
{
$type = 'f';
$paren_semicolon_count[$paren_depth]++;
}
}
},
'"' => sub {
error_if_expecting_OPERATOR("String")
if ( $expecting == OPERATOR );
$in_quote = 1;
$type = 'Q';
$allowed_quote_modifiers = "";
},
"'" => sub {
error_if_expecting_OPERATOR("String")
if ( $expecting == OPERATOR );
$in_quote = 1;
$type = 'Q';
$allowed_quote_modifiers = "";
},
'`' => sub {
error_if_expecting_OPERATOR("String")
if ( $expecting == OPERATOR );
$in_quote = 1;
$type = 'Q';
$allowed_quote_modifiers = "";
},
'/' => sub {
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 ) =
guess_if_pattern_or_division( $i, $rtokens, $rtoken_map,
$max_token_index );
if ($msg) {
write_diagnostics("DIVIDE:$msg\n");
write_logfile_entry($msg);
}
}
else { $is_pattern = ( $expecting == TERM ) }
if ($is_pattern) {
$in_quote = 1;
$type = 'Q';
$allowed_quote_modifiers = '[msixpodualngc]';
}
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 ( is_possible_numerator( $i, $rtokens, $max_token_index ) < 0 ) {
# #write_diagnostics( "DIVIDE? $input_line\n" );
#}
}
},
'{' => sub {
# 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 = "";
# ATTRS: for a '{' following an attribute list, reset
# things to look like we just saw the sub name
if ( $statement_type =~ /^sub\b/ ) {
$last_nonblank_token = $statement_type;
$last_nonblank_type = 'i';
$statement_type = "";
}
# 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 = $paren_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';
}
# check for syntax error here;
unless ( $is_blocktype_with_paren{$last_nonblank_token} ) {
if ( $tokenizer_self->[_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( ' ', sort keys %is_blocktype_with_paren );
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 ) {
warning(
"syntax error at '$want_paren .. {' -- missing \$ loop variable\n"
);
}
$want_paren = "";
}
# 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 = 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] = '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;
}
}
}
$brace_type[ ++$brace_depth ] = $block_type;
$brace_package[$brace_depth] = $current_package;
$brace_structural_type[$brace_depth] = $type;
$brace_context[$brace_depth] = $context;
( $type_sequence, $indent_flag ) =
increase_nesting_depth( BRACE, $rtoken_map->[$i_tok] );
},
'}' => sub {
$block_type = $brace_type[$brace_depth];
if ($block_type) { $statement_type = '' }
if ( defined( $brace_package[$brace_depth] ) ) {
$current_package = $brace_package[$brace_depth];
}
# can happen on brace error (caught elsewhere)
else {
}
( $type_sequence, $indent_flag ) =
decrease_nesting_depth( BRACE, $rtoken_map->[$i_tok] );
if ( $brace_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;
}
$context = $brace_context[$brace_depth];
if ( $brace_depth > 0 ) { $brace_depth--; }
},
'&' => sub { # 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' ) {
scan_identifier_fast();
}
}
else {
}
},
'<' => sub { # angle operator or less than?
if ( $expecting != OPERATOR ) {
( $i, $type ) =
find_angle_operator_termination( $input_line, $i, $rtoken_map,
$expecting, $max_token_index );
## This message is not very helpful and quite confusing if the above
## routine decided not to write a message with the line number.
## if ( $type eq '<' && $expecting == TERM ) {
## error_if_expecting_TERM();
## interrupt_logfile();
## warning("Unterminated <> operator?\n");
## resume_logfile();
## }
}
else {
}
},
'?' => sub { # ?: 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 ) =
guess_if_pattern_or_conditional( $i, $rtokens, $rtoken_map,
$max_token_index );
if ($msg) { write_logfile_entry($msg) }
}
else { $is_pattern = ( $expecting == TERM ) }
if ($is_pattern) {
$in_quote = 1;
$type = 'Q';
$allowed_quote_modifiers = '[msixpodualngc]';
}
else {
( $type_sequence, $indent_flag ) =
increase_nesting_depth( QUESTION_COLON,
$rtoken_map->[$i_tok] );
}
},
'*' => sub { # typeglob, or multiply?
if ( $expecting == UNKNOWN && $last_nonblank_type eq 'Z' ) {
if ( $next_type ne 'b'
&& $next_type ne '('
&& $next_type ne '#' ) # Fix c036
{
$expecting = TERM;
}
}
if ( $expecting == TERM ) {
scan_identifier_fast();
}
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++;
}
}
}
},
'.' => sub { # what kind of . ?
if ( $expecting != OPERATOR ) {
scan_number();
if ( $type eq '.' ) {
error_if_expecting_TERM()
if ( $expecting == TERM );
}
}
else {
}
},
':' => sub {
# 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
elsif ( $statement_type =~ /^sub\b/ ) {
$type = 'A';
$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 ( $paren_type[$paren_depth] =~ /^sub\b/
&& !is_balanced_closing_container(QUESTION_COLON) )
{
$type = 'A';
$in_attribute_list = 1;
}
# check for scalar attribute, such as
# my $foo : shared = 1;
elsif ($is_my_our_state{$statement_type}
&& $current_depth[QUESTION_COLON] == 0 )
{
$type = 'A';
$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';
}
# otherwise, it should be part of a ?/: operator
else {
( $type_sequence, $indent_flag ) =
decrease_nesting_depth( QUESTION_COLON,
$rtoken_map->[$i_tok] );
if ( $last_nonblank_token eq '?' ) {
warning("Syntax error near ? :\n");
}
}
},
'+' => sub { # what kind of plus?
if ( $expecting == TERM ) {
my $number = 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' }
}
},
'@' => sub {
error_if_expecting_OPERATOR("Array")
if ( $expecting == OPERATOR );
scan_identifier_fast();
},
'%' => sub { # 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 ) {
scan_identifier_fast();
}
},
'[' => sub {
$square_bracket_type[ ++$square_bracket_depth ] =
$last_nonblank_token;
( $type_sequence, $indent_flag ) =
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 = '{';
}
$square_bracket_structural_type[$square_bracket_depth] = $type;
},
']' => sub {
( $type_sequence, $indent_flag ) =
decrease_nesting_depth( SQUARE_BRACKET, $rtoken_map->[$i_tok] );
if ( $square_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 ( $square_bracket_type[$square_bracket_depth] eq '~~' ) {
$tok = $square_bracket_type[$square_bracket_depth];
}
if ( $square_bracket_depth > 0 ) { $square_bracket_depth--; }
},
'-' => sub { # what kind of minus?
if ( ( $expecting != OPERATOR )
&& $is_file_test_operator{$next_tok} )
{
my ( $next_nonblank_token, $i_next ) =
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 = 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';
}
}
},
'^' => sub {
# check for special variables like ${^WARNING_BITS}
if ( $expecting == TERM ) {
# FIXME: this should work but will not catch errors
# because we also have to be sure that previous token is
# a type character ($,@,%).
if ( $last_nonblank_token eq '{'
&& ( $next_tok !~ /^\d/ )
&& ( $next_tok =~ /^\w/ ) )
{
if ( $next_tok eq 'W' ) {
$tokenizer_self->[_saw_perl_dash_w_] = 1;
}
$tok = $tok . $next_tok;
$i = $i + 1;
$type = 'w';
}
else {
unless ( error_if_expecting_TERM() ) {
# Something like this is valid but strange:
# undef ^I;
complain("The '^' seems unusual here\n");
}
}
}
},
'::' => sub { # probably a sub call
scan_bare_identifier();
},
'<<' => sub { # maybe a here-doc?
## This check removed because it could be a deprecated here-doc with
## no specified target. See example in log 16 Sep 2020.
## return
## unless ( $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
)
= find_here_doc( $expecting, $i, $rtokens, $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 );
complain("Long here-target: '$truncated' ...\n");
}
elsif ( !$here_doc_target ) {
warning(
'Use of bare << to mean <<"" is deprecated' . "\n" )
unless ($here_quote_character);
}
elsif ( $here_doc_target !~ /^[A-Z_]\w+$/ ) {
complain(
"Unconventional here-target: '$here_doc_target'\n");
}
}
elsif ( $expecting == TERM ) {
unless ($saw_error) {
# shouldn't happen..
warning("Program bug; didn't find here doc target\n");
report_definite_bug();
}
}
}
else {
}
},
'<<~' => sub { # a here-doc, new type added in v26
return
unless ( $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
)
= find_here_doc( $expecting, $i, $rtokens, $rtoken_map,
$max_token_index );
if ($found_target) {
if ( length($here_doc_target) > 80 ) {
my $truncated = substr( $here_doc_target, 0, 80 );
complain("Long here-target: '$truncated' ...\n");
}
elsif ( $here_doc_target !~ /^[A-Z_]\w+$/ ) {
complain(
"Unconventional here-target: '$here_doc_target'\n");
}
# Note that we put a leading space on the here quote
# character indicate that it may be preceded by spaces
$here_quote_character = " " . $here_quote_character;
push @{$rhere_target_list},
[ $here_doc_target, $here_quote_character ];
$type = 'h';
}
elsif ( $expecting == TERM ) {
unless ($saw_error) {
# shouldn't happen..
warning("Program bug; didn't find here doc target\n");
report_definite_bug();
}
}
}
else {
}
},
'->' => sub {
# if -> points to a bare word, we must scan for an identifier,
# otherwise something like ->y would look like the y operator
# NOTE: this will currently allow things like
# '->@array' '->*VAR' '->%hash'
# to get parsed as identifiers, even though these are not currently
# allowed syntax. To catch syntax errors like this we could first
# check that the next character and skip this call if it is one of
# ' @ % * '. A disadvantage with doing this is that this would
# have to be fixed if the perltidy syntax is ever extended to make
# any of these valid. So for now this check is not done.
scan_identifier_fast();
},
# type = 'pp' for pre-increment, '++' for post-increment
'++' => sub {
if ( $expecting == TERM ) { $type = 'pp' }
elsif ( $expecting == UNKNOWN ) {
my ( $next_nonblank_token, $i_next ) =
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 ) =
find_next_nonblank_token( $max_token_index,
$rtokens, $max_token_index );
}
if ( $next_nonblank_token eq '$' ) { $type = 'pp' }
}
},
'=>' => sub {
if ( $last_nonblank_type eq $tok ) {
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' }
},
# type = 'mm' for pre-decrement, '--' for post-decrement
'--' => sub {
if ( $expecting == TERM ) { $type = 'mm' }
elsif ( $expecting == UNKNOWN ) {
my ( $next_nonblank_token, $i_next ) =
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 ) =
find_next_nonblank_token( $max_token_index,
$rtokens, $max_token_index );
}
if ( $next_nonblank_token eq '$' ) { $type = 'mm' }
}
},
'&&' => sub {
error_if_expecting_TERM()
if ( $expecting == TERM && $last_nonblank_token ne ',' ); #c015
},
'||' => sub {
error_if_expecting_TERM()
if ( $expecting == TERM && $last_nonblank_token ne ',' ); #c015
},
'//' => sub {
error_if_expecting_TERM()
if ( $expecting == TERM );
},
};
# ------------------------------------------------------------
# end hash of code for handling individual token types
# ------------------------------------------------------------
my %matching_start_token = ( '}' => '{', ']' => '[', ')' => '(' );
# These block types terminate statements and do not need a trailing
# semicolon
# patched for SWITCH/CASE/
my %is_zero_continuation_block_type;
@_ = 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{@_} = (1) x scalar(@_);
my %is_not_zero_continuation_block_type;
@_ = qw(sort grep map do eval);
@is_not_zero_continuation_block_type{@_} = (1) x scalar(@_);
my %is_logical_container;
@_ = qw(if elsif unless while and or err not && ! || for foreach);
@is_logical_container{@_} = (1) x scalar(@_);
my %is_binary_type;
@_ = qw(|| &&);
@is_binary_type{@_} = (1) x scalar(@_);
my %is_binary_keyword;
@_ = qw(and or err eq ne cmp);
@is_binary_keyword{@_} = (1) x scalar(@_);
# 'L' is token for opening { at hash key
my %is_opening_type;
@_ = qw< L { ( [ >;
@is_opening_type{@_} = (1) x scalar(@_);
# 'R' is token for closing } at hash key
my %is_closing_type;
@_ = qw< R } ) ] >;
@is_closing_type{@_} = (1) x scalar(@_);
my %is_redo_last_next_goto;
@_ = qw(redo last next goto);
@is_redo_last_next_goto{@_} = (1) x scalar(@_);
my %is_use_require;
@_ = qw(use require);
@is_use_require{@_} = (1) x scalar(@_);
# This hash holds the array index in $tokenizer_self for these keywords:
# Fix for issue c035: removed 'format' from this hash
my %is_END_DATA = (
'__END__' => _in_end_,
'__DATA__' => _in_data_,
);
# 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
my %quote_modifiers = (
's' => '[msixpodualngcer]',
'y' => '[cdsr]',
'tr' => '[cdsr]',
'm' => '[msixpodualngc]',
'qr' => '[msixpodualn]',
'q' => "",
'qq' => "",
'qw' => "",
'qx' => "",
);
# 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,
);
use constant DEBUG_TOKENIZE => 0;
sub tokenize_this_line {
# This routine breaks a line of perl code into tokens which are of use in
# indentation and reformatting. One of my goals has been to define tokens
# 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.
#
# The tokens and their types are returned in arrays. See previous
# routine for their names.
#
# See also the array "valid_token_types" in the BEGIN section for an
# up-to-date list.
#
# 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.
#
# -----------------------------------------------------------------------
#
# How to add NEW_TOKENS:
#
# New token types will undoubtedly be needed in the future both to keep up
# with changes in perl and to help adapt the tokenizer to other applications.
#
# 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):
#
# *. Try to talk somebody else into doing it! If not, ..
#
# *. Make a backup of your current version in case things don't work out!
#
# *. 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.
#
# *. For another example, search for the smartmatch operator '~~'
# with your editor to see where updates were made for it.
#
# -----------------------------------------------------------------------
my $line_of_tokens = shift;
my ($untrimmed_input_line) = $line_of_tokens->{_line_text};
# patch while coding change is underway
# make callers private data to allow access
# $tokenizer_self = $caller_tokenizer_self;
# extract line number for use in error messages
$input_line_number = $line_of_tokens->{_line_number};
# reinitialize for multi-line quote
$line_of_tokens->{_starting_in_quote} = $in_quote && $quote_type eq 'Q';
# check for 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
if ( !$in_quote
&& ( operator_expected( [ 'b', '=', 'b' ] ) == TERM ) )
{
$tokenizer_self->[_in_pod_] = 1;
return;
}
}
$input_line = $untrimmed_input_line;
chomp $input_line;
# Set a flag to indicate if we might be at an __END__ or __DATA__ line
# This will be used below to avoid quoting a bare word followed by
# a fat comma.
my $is_END_or_DATA;
# trim start of this line unless we are 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
unless ( $in_quote && ( $quote_type eq 'Q' ) ) {
$input_line =~ s/^\s+//; # trim left end
$is_END_or_DATA = substr( $input_line, 0, 1 ) eq '_'
&& $input_line =~ /^\s*__(END|DATA)__\s*$/;
}
# update the copy of the line for use in error messages
# This must be exactly what we give the pre_tokenizer
$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_container_type = []; # paren types, such as if, elsif, ..
$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;
# tokenization is done in two stages..
# stage 1 is a very simple pre-tokenization
my $max_tokens_wanted = 0; # this signals pre_tokenize to get all tokens
# optimize for a full-line comment
if ( !$in_quote && substr( $input_line, 0, 1 ) eq '#' ) {
$max_tokens_wanted = 1; # no use tokenizing a comment
# and check for skipped section
if ( $rOpts_code_skipping
&& $input_line =~ /$code_skipping_pattern_begin/ )
{
$tokenizer_self->[_in_skipped_] = 1;
return;
}
}
# start by breaking the line into pre-tokens
( $rtokens, $rtoken_map, $rtoken_type ) =
pre_tokenize( $input_line, $max_tokens_wanted );
$max_token_index = scalar( @{$rtokens} ) - 1;
push( @{$rtokens}, ' ', ' ', ' ' ); # extra whitespace simplifies logic
push( @{$rtoken_map}, 0, 0, 0 ); # shouldn't be referenced
push( @{$rtoken_type}, 'b', 'b', 'b' );
# initialize for main loop
foreach my $ii ( 0 .. $max_token_index + 3 ) {
$routput_token_type->[$ii] = "";
$routput_block_type->[$ii] = "";
$routput_container_type->[$ii] = "";
$routput_type_sequence->[$ii] = "";
$routput_indent_flag->[$ii] = 0;
}
$i = -1;
$i_tok = -1;
# ------------------------------------------------------------
# begin main tokenization loop
# ------------------------------------------------------------
# we are looking at each pre-token of one line and combining them
# into tokens
while ( ++$i <= $max_token_index ) {
if ($in_quote) { # continue looking for end of a quote
$type = $quote_type;
unless ( @{$routput_token_list} )
{ # initialize if continuation line
push( @{$routput_token_list}, $i );
$routput_token_type->[$i] = $type;
}
$tok = $quote_character if ($quote_character);
# scan for the end of the quote or pattern
(
$i, $in_quote, $quote_character, $quote_pos, $quote_depth,
$quoted_string_1, $quoted_string_2
)
= do_quote(
$i, $in_quote, $quote_character,
$quote_pos, $quote_depth, $quoted_string_1,
$quoted_string_2, $rtokens, $rtoken_map,
$max_token_index
);
# all done if we didn't find it
last if ($in_quote);
# save pattern and replacement text for rescanning
my $qs1 = $quoted_string_1;
my $qs2 = $quoted_string_2;
# re-initialize for next search
$quote_character = '';
$quote_pos = 0;
$quote_type = 'Q';
$quoted_string_1 = "";
$quoted_string_2 = "";
last if ( ++$i > $max_token_index );
# 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 = 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) ) {
last if ( ++$i > $max_token_index );
}
# 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 {
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
last if ( ++$i > $max_token_index );
}
}
else {
# example file: rokicki4.pl
# This error might also be triggered if my quote
# modifier characters are incomplete
write_logfile_entry(
"Note: found word $str at quote modifier location\n"
);
}
}
# re-initialize
$allowed_quote_modifiers = "";
}
}
unless ( $type eq 'b' || $tok eq 'CORE::' ) {
# try to catch some common errors
if ( ( $type eq 'n' ) && ( $tok ne '0' ) ) {
if ( $last_nonblank_token eq 'eq' ) {
complain("Should 'eq' be '==' here ?\n");
}
elsif ( $last_nonblank_token eq 'ne' ) {
complain("Should 'ne' be '!=' here ?\n");
}
}
$last_last_nonblank_token = $last_nonblank_token;
$last_last_nonblank_type = $last_nonblank_type;
$last_last_nonblank_block_type = $last_nonblank_block_type;
$last_last_nonblank_container_type =
$last_nonblank_container_type;
$last_last_nonblank_type_sequence =
$last_nonblank_type_sequence;
$last_nonblank_token = $tok;
$last_nonblank_type = $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;
# 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_token eq '->' ) {
if ( $last_nonblank_type eq 'w'
|| $last_nonblank_type eq 'i'
&& substr( $last_nonblank_token, 0, 1 ) eq '$' )
{
$last_nonblank_token = '->' . $last_nonblank_token;
$last_nonblank_type = 'i';
}
}
}
# store previous token type
if ( $i_tok >= 0 ) {
$routput_token_type->[$i_tok] = $type;
$routput_block_type->[$i_tok] = $block_type;
$routput_container_type->[$i_tok] = $container_type;
$routput_type_sequence->[$i_tok] = $type_sequence;
$routput_indent_flag->[$i_tok] = $indent_flag;
}
my $pre_tok = $rtokens->[$i]; # get the next pre-token
my $pre_type = $rtoken_type->[$i]; # and type
$tok = $pre_tok;
$type = $pre_type; # to be modified as necessary
$block_type = ""; # blank for all tokens except code block braces
$container_type = ""; # blank for all tokens except some parens
$type_sequence = ""; # blank for all tokens except ?/:
$indent_flag = 0;
$prototype = ""; # blank for all tokens except user defined subs
$i_tok = $i;
# this pre-token will start an output token
push( @{$routput_token_list}, $i_tok );
# continue gathering identifier if necessary
# but do not start on blanks and comments
if ( $id_scan_state && $pre_type ne 'b' && $pre_type ne '#' ) {
if ( $is_sub{$id_scan_state} || $is_package{$id_scan_state} ) {
scan_id();
}
else {
scan_identifier();
}
last if ($id_scan_state);
next if ( ( $i > 0 ) || $type );
# didn't find any token; start over
$type = $pre_type;
$tok = $pre_tok;
}
# handle whitespace tokens..
next if ( $type eq 'b' );
my $prev_tok = $i > 0 ? $rtokens->[ $i - 1 ] : ' ';
my $prev_type = $i > 0 ? $rtoken_type->[ $i - 1 ] : 'b';
# Build larger tokens where possible, since we are not in a quote.
#
# First try to assemble digraphs. 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
my $test_tok = $tok . $rtokens->[ $i + 1 ];
my $combine_ok = $is_digraph{$test_tok};
# check for special cases which cannot be combined
if ($combine_ok) {
# '//' 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
# token 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' ) {
my $next_type = $rtokens->[ $i + 1 ];
my $expecting =
operator_expected( [ $prev_type, $tok, $next_type ] );
# Patched for RT#101547, was 'unless ($expecting==OPERATOR)'
$combine_ok = 0 if ( $expecting == TERM );
}
# Patch for RT #114359: Missparsing 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 (
$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
elsif ( $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 ];
DEBUG_TOKENIZE && do {
local $" = ')(';
my @debug_list = (
$last_nonblank_token, $tok,
$next_tok, $brace_depth,
$brace_type[$brace_depth], $paren_depth,
$paren_type[$paren_depth]
);
print STDOUT "TOKENIZE:(@debug_list)\n";
};
# Turn off attribute list on first non-blank, non-bareword.
# Added '#' to fix c038.
if ( $pre_type ne 'w' && $pre_type ne '#' ) {
$in_attribute_list = 0;
}
###############################################################
# We have the next token, $tok.
# Now we have to examine this token and decide what it is
# and define its $type
#
# section 1: bare words
###############################################################
if ( $pre_type eq 'w' ) {
$expecting =
operator_expected( [ $prev_type, $tok, $next_type ] );
# Patch for c043, part 3: A bareword after '->' expects a TERM
# FIXME: It would be cleaner to give method calls a new type 'M'
# and update sub operator_expected to handle this.
if ( $last_nonblank_type eq '->' ) {
$expecting = TERM;
}
my ( $next_nonblank_token, $i_next ) =
find_next_nonblank_token( $i, $rtokens, $max_token_index );
# ATTRS: handle sub and variable attributes
if ($in_attribute_list) {
# 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 ) = 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. Note that type 'w' would also work.
if ( $i > $i_beg ) {
$type = 'q';
next;
}
# 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';
next;
}
# handle bareword not followed by open paren
else {
$type = 'w';
next;
}
}
# quote a word followed by => operator
# unless the word __END__ or __DATA__ and the only word on
# the line.
if ( !$is_END_or_DATA && $next_nonblank_token eq '=' ) {
if ( $rtokens->[ $i_next + 1 ] eq '>' ) {
if ( $is_constant{$current_package}{$tok} ) {
$type = 'C';
}
elsif ( $is_user_function{$current_package}{$tok} ) {
$type = 'U';
$prototype =
$user_function_prototype{$current_package}{$tok};
}
elsif ( $tok =~ /^v\d+$/ ) {
$type = 'v';
report_v_string($tok);
}
else {
# Bareword followed by a fat comma ... see 'git18.in'
# 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.
if ( $expecting == OPERATOR && $tok =~ /^x\d+$/ ) {
$type = 'n';
}
else {
# git #18
$type = 'w';
error_if_expecting_OPERATOR();
}
}
next;
}
}
# 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 qoute operator
if (
$next_nonblank_token eq '}'
&& (
$last_nonblank_type eq 'L'
|| ( $last_nonblank_type eq 'm'
&& $last_last_nonblank_type eq 'L' )
)
)
{
$type = 'w';
next;
}
# Scan a bare word following a -> as an identifir; it could
# have a long package name. Fixes c037, c041.
if ( $last_nonblank_token eq '->' ) {
scan_bare_identifier();
# Patch for c043, part 4; use type 'w' after a '->'.
# This is just a safety check on sub scan_bare_identifier,
# which should get this case correct.
$type = 'w';
next;
}
# 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 .= '::';
}
# Decide if 'sub :' can be the start of a sub attribute list.
# We will decide based on if the colon is followed by a
# bareword which is not a keyword.
my $sub_attribute_ok_here;
if ( $is_sub{$tok_kw}
&& $expecting != OPERATOR
&& $next_nonblank_token eq ':' )
{
my ( $nn_nonblank_token, $i_nn ) =
find_next_nonblank_token( $i_next + 1,
$rtokens, $max_token_index );
$sub_attribute_ok_here =
$nn_nonblank_token =~ /^\w/
&& $nn_nonblank_token !~ /^\d/
&& !$is_keyword{$nn_nonblank_token};
}
# handle operator x (now we know it isn't $x=)
if ( $expecting == OPERATOR
&& substr( $tok, 0, 1 ) eq 'x'
&& $tok =~ /^x\d*$/ )
{
if ( $tok eq 'x' ) {
if ( $rtokens->[ $i + 1 ] eq '=' ) { # x=
$tok = 'x=';
$type = $tok;
$i++;
}
else {
$type = 'x';
}
}
# NOTE: mark something like x4 as an integer for now
# It gets fixed downstream. This is easier than
# splitting the pretoken.
else {
$type = 'n';
}
}
elsif ( $tok_kw eq 'CORE::' ) {
$type = $tok = $tok_kw;
$i += 2;
}
elsif ( ( $tok eq 'strict' )
and ( $last_nonblank_token eq 'use' ) )
{
$tokenizer_self->[_saw_use_strict_] = 1;
scan_bare_identifier();
}
elsif ( ( $tok eq 'warnings' )
and ( $last_nonblank_token eq 'use' ) )
{
$tokenizer_self->[_saw_perl_dash_w_] = 1;
# scan as identifier, so that we pick up something like:
# use warnings::register
scan_bare_identifier();
}
elsif (
$tok eq 'AutoLoader'
&& $tokenizer_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/
)
)
{
write_logfile_entry("AutoLoader seen, -nlal deactivates\n");
$tokenizer_self->[_saw_autoloader_] = 1;
$tokenizer_self->[_look_for_autoloader_] = 0;
scan_bare_identifier();
}
elsif (
$tok eq 'SelfLoader'
&& $tokenizer_self->[_look_for_selfloader_]
&& ( $last_nonblank_token eq 'use'
|| $input_line =~ /^\s*(use|require)\s+SelfLoader\b/
|| $input_line =~ /\bISA\s*=.*\bSelfLoader\b/ )
)
{
write_logfile_entry("SelfLoader seen, -nlsl deactivates\n");
$tokenizer_self->[_saw_selfloader_] = 1;
$tokenizer_self->[_look_for_selfloader_] = 0;
scan_bare_identifier();
}
elsif ( ( $tok eq 'constant' )
and ( $last_nonblank_token eq 'use' ) )
{
scan_bare_identifier();
my ( $next_nonblank_token, $i_next ) =
find_next_nonblank_token( $i, $rtokens,
$max_token_index );
if ($next_nonblank_token) {
if ( $is_keyword{$next_nonblank_token} ) {
# 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_token ne 'qw' ) {
warning(
"Attempting to define constant '$next_nonblank_token' which is a perl keyword\n"
);
}
}
else {
$is_constant{$current_package}{$next_nonblank_token}
= 1;
}
}
}
# various quote operators
elsif ( $is_q_qq_qw_qx_qr_s_y_tr_m{$tok} ) {
##NICOL PATCH
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'
unless (
$tok eq 'qw'
&& ( $last_nonblank_token =~ /^([\]\}\&]|\-\>)/
|| $is_for_foreach{$want_paren} )
)
{
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' && $tokenizer_self->[_trim_qw_] )
? 'q'
: 'Q';
$quote_type = $type;
}
# check for a statement label
elsif (
( $next_nonblank_token eq ':' )
&& ( $rtokens->[ $i_next + 1 ] ne ':' )
&& ( $i_next <= $max_token_index ) # colon on same line
&& !$sub_attribute_ok_here # like 'sub : lvalue' ?
&& label_ok()
)
{
if ( $tok !~ /[A-Z]/ ) {
push @{ $tokenizer_self->[_rlower_case_labels_at_] },
$input_line_number;
}
$type = 'J';
$tok .= ':';
$i = $i_next;
next;
}
# 'sub' or alias
elsif ( $is_sub{$tok_kw} ) {
error_if_expecting_OPERATOR()
if ( $expecting == OPERATOR );
initialize_subname();
scan_id();
}
# 'package'
elsif ( $is_package{$tok_kw} ) {
error_if_expecting_OPERATOR()
if ( $expecting == OPERATOR );
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
$tokenizer_self->[_in_format_] = 1;
last;
}
# 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 ( $is_END_DATA{$tok_kw} ) {
$type = ';'; # make tokenizer look for TERM next
# Remember that we are in one of these three sections
$tokenizer_self->[ $is_END_DATA{$tok_kw} ] = 1;
last;
}
elsif ( $is_keyword{$tok_kw} ) {
$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 '('
if ( $is_for_foreach{$tok} ) {
if ( new_statement_ok() ) {
$want_paren = $tok;
}
}
# recognize 'use' statements, which are special
elsif ( $is_use_require{$tok} ) {
$statement_type = $tok;
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 misplaced 'elsif' and 'else', but allow isolated
# else or elsif blocks to be formatted. This is indicated
# by a last noblank token of ';'
elsif ( $tok eq 'elsif' ) {
if ( $last_nonblank_token ne ';'
&& $last_nonblank_block_type !~
/^(if|elsif|unless)$/ )
{
warning(
"expecting '$tok' to follow one of 'if|elsif|unless'\n"
);
}
}
elsif ( $tok eq 'else' ) {
# patched for SWITCH/CASE
if (
$last_nonblank_token ne ';'
&& $last_nonblank_block_type !~
/^(if|elsif|unless|case|when)$/
# patch to avoid an unwanted error message for
# the case of a parenless 'case' (RT 105484):
# switch ( 1 ) { case x { 2 } else { } }
&& $statement_type !~
/^(if|elsif|unless|case|when)$/
)
{
warning(
"expecting '$tok' to follow one of 'if|elsif|unless|case|when'\n"
);
}
}
elsif ( $tok eq 'continue' ) {
if ( $last_nonblank_token ne ';'
&& $last_nonblank_block_type !~
/(^(\{|\}|;|while|until|for|foreach)|:$)/ )
{
# note: ';' '{' and '}' in list above
# because continues can follow bare blocks;
# ':' is labeled block
#
############################################
# NOTE: This check has been deactivated because
# continue has an alternative usage for given/when
# blocks in perl 5.10
## warning("'$tok' should follow a block\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
}
#
# indent trailing if/unless/while/until
# outdenting will be handled by later indentation loop
## DEACTIVATED: unfortunately this can cause some unwanted indentation like:
##$opt_o = 1
## if !(
## $opt_b
## || $opt_c
## || $opt_d
## || $opt_f
## || $opt_i
## || $opt_l
## || $opt_o
## || $opt_x
## );
## if ( $tok =~ /^(if|unless|while|until)$/
## && $next_nonblank_token ne '(' )
## {
## $indent_flag = 1;
## }
}
# 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';
next;
}
# something else --
else {
scan_bare_identifier();
if ( $statement_type eq 'use'
&& $last_nonblank_token eq 'use' )
{
$saw_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;
# FIXME: this should eventually be generalized
if ( $saw_use_module{$current_package}->{'RPerl'}
&& $tok =~ /^sse_(mul|div|add|sub)$/ )
{
}
# 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 !~ /::$/ ) {
complain(<[ $i + 1 ];
if ( $next_tok eq '(' ) {
# Fix part 2 for git #63. Leave type as 'w' to keep
# the type the same as if the -> were not separated
$type = 'U' unless ( $last_nonblank_type eq '->' );
}
# 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'
&& $brace_type[$brace_depth] eq 'switch'
)
|| ( $tok eq 'when'
&& $brace_type[$brace_depth] eq 'given' )
)
{
$statement_type = $tok; # next '{' is block
$type = 'k'; # for keyword syntax coloring
}
# 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 ( $next_nonblank_token eq '('
&& ( $tok eq 'switch' || $tok eq 'given' ) )
{
$type = 'k'; # for keyword syntax coloring
}
}
}
}
###############################################################
# section 2: strings of digits
###############################################################
elsif ( $pre_type eq 'd' ) {
$expecting =
operator_expected( [ $prev_type, $tok, $next_type ] );
error_if_expecting_OPERATOR("Number")
if ( $expecting == OPERATOR );
my $number = scan_number_fast();
if ( !defined($number) ) {
# shouldn't happen - we should always get a number
warning("non-number beginning with digit--program bug\n");
report_definite_bug();
}
}
###############################################################
# section 3: all other tokens
###############################################################
else {
last if ( $tok eq '#' );
my $code = $tokenization_code->{$tok};
if ($code) {
$expecting =
operator_expected( [ $prev_type, $tok, $next_type ] );
$code->();
redo if $in_quote;
}
}
}
# -----------------------------
# end of main tokenization loop
# -----------------------------
if ( $i_tok >= 0 ) {
$routput_token_type->[$i_tok] = $type;
$routput_block_type->[$i_tok] = $block_type;
$routput_container_type->[$i_tok] = $container_type;
$routput_type_sequence->[$i_tok] = $type_sequence;
$routput_indent_flag->[$i_tok] = $indent_flag;
}
unless ( ( $type eq 'b' ) || ( $type eq '#' ) ) {
$last_last_nonblank_token = $last_nonblank_token;
$last_last_nonblank_type = $last_nonblank_type;
$last_last_nonblank_block_type = $last_nonblank_block_type;
$last_last_nonblank_container_type = $last_nonblank_container_type;
$last_last_nonblank_type_sequence = $last_nonblank_type_sequence;
$last_nonblank_token = $tok;
$last_nonblank_type = $type;
$last_nonblank_block_type = $block_type;
$last_nonblank_container_type = $container_type;
$last_nonblank_type_sequence = $type_sequence;
$last_nonblank_prototype = $prototype;
}
# 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);
brace_warning("resetting level to 0 at $1 $2\n");
}
}
# all done tokenizing this line ...
# now prepare the final list of tokens and types
my @token_type = (); # stack of output token types
my @block_type = (); # stack of output code block types
my @container_type = (); # stack of output code container types
my @type_sequence = (); # stack of output type sequence numbers
my @tokens = (); # output tokens
my @levels = (); # structural brace levels of output tokens
my @slevels = (); # secondary nesting levels of output tokens
my @nesting_tokens = (); # string of tokens leading to this depth
my @nesting_types = (); # string of token types leading to this depth
my @nesting_blocks = (); # string of block types leading to this depth
my @nesting_lists = (); # string of list types leading to this depth
my @ci_string = (); # string needed to compute continuation indentation
my @container_environment = (); # BLOCK or LIST
my $container_environment = '';
my $im = -1; # previous $i value
my $num;
# Count the number of '1's in the string (previously sub ones_count)
my $ci_string_sum = ( my $str = $ci_string_in_tokenizer ) =~ tr/1/0/;
# Computing Token Indentation
#
# The final section of the tokenizer forms tokens and also computes
# parameters needed to find indentation. It is much easier to do it
# in the tokenizer than elsewhere. Here is a brief description of how
# indentation is computed. Perl::Tidy computes indentation as the sum
# of 2 terms:
#
# (1) structural indentation, such as if/else/elsif blocks
# (2) continuation indentation, such as long parameter call lists.
#
# These are occasionally called primary and secondary indentation.
#
# Structural indentation is introduced by tokens of type '{', although
# the actual tokens might be '{', '(', or '['. Structural indentation
# is of two types: BLOCK and non-BLOCK. Default structural indentation
# is 4 characters if the standard indentation scheme is used.
#
# Continuation indentation is introduced whenever a line at BLOCK level
# is broken before its termination. Default continuation indentation
# is 2 characters in the standard indentation scheme.
#
# Both types of indentation may be nested arbitrarily deep and
# interlaced. The distinction between the two is somewhat arbitrary.
#
# For each token, we will define two variables which would apply if
# the current statement were broken just before that token, so that
# that token started a new line:
#
# $level = the structural indentation level,
# $ci_level = the continuation indentation level
#
# The total indentation will be $level * (4 spaces) + $ci_level * (2 spaces),
# assuming defaults. However, in some special cases it is customary
# to modify $ci_level from this strict value.
#
# The total structural indentation is easy to compute by adding and
# subtracting 1 from a saved value as types '{' and '}' are seen. The
# running value of this variable is $level_in_tokenizer.
#
# The total continuation is much more difficult to compute, and requires
# several variables. These variables are:
#
# $ci_string_in_tokenizer = a string of 1's and 0's indicating, for
# each indentation level, if there are intervening open secondary
# structures just prior to that level.
# $continuation_string_in_tokenizer = a string of 1's and 0's indicating
# if the last token at that level is "continued", meaning that it
# is not the first token of an expression.
# $nesting_block_string = a string of 1's and 0's indicating, for each
# indentation level, if the level is of type BLOCK or not.
# $nesting_block_flag = the most recent 1 or 0 of $nesting_block_string
# $nesting_list_string = a string of 1's and 0's indicating, for each
# indentation level, if it is appropriate for list formatting.
# If so, continuation indentation is used to indent long list items.
# $nesting_list_flag = the most recent 1 or 0 of $nesting_list_string
# @{$rslevel_stack} = a stack of total nesting depths at each
# structural indentation level, where "total nesting depth" means
# the nesting depth that would occur if every nesting token -- '{', '[',
# and '(' -- , regardless of context, is used to compute a nesting
# depth.
#my $nesting_block_flag = ($nesting_block_string =~ /1$/);
#my $nesting_list_flag = ($nesting_list_string =~ /1$/);
my ( $ci_string_i, $level_i, $nesting_block_string_i,
$nesting_list_string_i, $nesting_token_string_i,
$nesting_type_string_i, );
foreach my $i ( @{$routput_token_list} )
{ # scan the list of pre-tokens indexes
# self-checking for valid token types
my $type = $routput_token_type->[$i];
my $forced_indentation_flag = $routput_indent_flag->[$i];
# See if we should undo the $forced_indentation_flag.
# Forced indentation after 'if', 'unless', 'while' and 'until'
# expressions without trailing parens is optional and doesn't
# always look good. It is usually okay for a trailing logical
# expression, but if the expression is a function call, code block,
# or some kind of list it puts in an unwanted extra indentation
# level which is hard to remove.
#
# Example where extra indentation looks ok:
# return 1
# if $det_a < 0 and $det_b > 0
# or $det_a > 0 and $det_b < 0;
#
# Example where extra indentation is not needed because
# the eval brace also provides indentation:
# print "not " if defined eval {
# reduce { die if $b > 2; $a + $b } 0, 1, 2, 3, 4;
# };
#
# The following rule works fairly well:
# Undo the flag if the end of this line, or start of the next
# line, is an opening container token or a comma.
# This almost always works, but if not after another pass it will
# be stable.
if ( $forced_indentation_flag && $type eq 'k' ) {
my $ixlast = -1;
my $ilast = $routput_token_list->[$ixlast];
my $toklast = $routput_token_type->[$ilast];
if ( $toklast eq '#' ) {
$ixlast--;
$ilast = $routput_token_list->[$ixlast];
$toklast = $routput_token_type->[$ilast];
}
if ( $toklast eq 'b' ) {
$ixlast--;
$ilast = $routput_token_list->[$ixlast];
$toklast = $routput_token_type->[$ilast];
}
if ( $toklast =~ /^[\{,]$/ ) {
$forced_indentation_flag = 0;
}
else {
( $toklast, my $i_next ) =
find_next_nonblank_token( $max_token_index, $rtokens,
$max_token_index );
if ( $toklast =~ /^[\{,]$/ ) {
$forced_indentation_flag = 0;
}
}
}
# if we are already in an indented if, see if we should outdent
if ($indented_if_level) {
# don't try to nest trailing if's - shouldn't happen
if ( $type eq 'k' ) {
$forced_indentation_flag = 0;
}
# check for the normal case - outdenting at next ';'
elsif ( $type eq ';' ) {
if ( $level_in_tokenizer == $indented_if_level ) {
$forced_indentation_flag = -1;
$indented_if_level = 0;
}
}
# handle case of missing semicolon
elsif ( $type eq '}' ) {
if ( $level_in_tokenizer == $indented_if_level ) {
$indented_if_level = 0;
# TBD: This could be a subroutine call
$level_in_tokenizer--;
if ( @{$rslevel_stack} > 1 ) {
pop( @{$rslevel_stack} );
}
if ( length($nesting_block_string) > 1 )
{ # true for valid script
chop $nesting_block_string;
chop $nesting_list_string;
}
}
}
}
my $tok = $rtokens->[$i]; # the token, but ONLY if same as pretoken
$level_i = $level_in_tokenizer;
# 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
if ( !$is_valid_token_type{$type} ) {
my $val = ord($type);
warning(
"unexpected character decimal $val ($type) in script\n");
$tokenizer_self->[_in_error_] = 1;
}
# ----------------------------------------------------------------
# TOKEN TYPE PATCHES
# output __END__, __DATA__, and format as type 'k' instead of ';'
# to make html colors correct, etc.
my $fix_type = $type;
if ( $type eq ';' && $tok =~ /\w/ ) { $fix_type = 'k' }
# output anonymous 'sub' as keyword
if ( $type eq 't' && $is_sub{$tok} ) { $fix_type = 'k' }
# -----------------------------------------------------------------
$nesting_token_string_i = $nesting_token_string;
$nesting_type_string_i = $nesting_type_string;
$nesting_block_string_i = $nesting_block_string;
$nesting_list_string_i = $nesting_list_string;
# set primary indentation levels based on structural braces
# Note: these are set so that the leading braces have a HIGHER
# level than their CONTENTS, which is convenient for indentation
# Also, define continuation indentation for each token.
if ( $type eq '{' || $type eq 'L' || $forced_indentation_flag > 0 )
{
# use environment before updating
$container_environment =
$nesting_block_flag ? 'BLOCK'
: $nesting_list_flag ? 'LIST'
: "";
# if the difference between total nesting levels is not 1,
# there are intervening non-structural nesting types between
# this '{' and the previous unclosed '{'
my $intervening_secondary_structure = 0;
if ( @{$rslevel_stack} ) {
$intervening_secondary_structure =
$slevel_in_tokenizer - $rslevel_stack->[-1];
}
# Continuation Indentation
#
# Having tried setting continuation indentation both in the formatter and
# in the tokenizer, I can say that setting it in the tokenizer is much,
# much easier. The formatter already has too much to do, and can't
# make decisions on line breaks without knowing what 'ci' will be at
# arbitrary locations.
#
# But a problem with setting the continuation indentation (ci) here
# in the tokenizer is that we do not know where line breaks will actually
# be. As a result, we don't know if we should propagate continuation
# indentation to higher levels of structure.
#
# For nesting of only structural indentation, we never need to do this.
# For example, in a long if statement, like this
#
# if ( !$output_block_type[$i]
# && ($in_statement_continuation) )
# { <--outdented
# do_something();
# }
#
# the second line has ci but we do normally give the lines within the BLOCK
# any ci. This would be true if we had blocks nested arbitrarily deeply.
#
# But consider something like this, where we have created a break after
# an opening paren on line 1, and the paren is not (currently) a
# structural indentation token:
#
# my $file = $menubar->Menubutton(
# qw/-text File -underline 0 -menuitems/ => [
# [
# Cascade => '~View',
# -menuitems => [
# ...
#
# The second line has ci, so it would seem reasonable to propagate it
# down, giving the third line 1 ci + 1 indentation. This suggests the
# following rule, which is currently used to propagating ci down: if there
# are any non-structural opening parens (or brackets, or braces), before
# an opening structural brace, then ci is propagated down, and otherwise
# not. The variable $intervening_secondary_structure contains this
# information for the current token, and the string
# "$ci_string_in_tokenizer" is a stack of previous values of this
# variable.
# save the current states
push( @{$rslevel_stack}, 1 + $slevel_in_tokenizer );
$level_in_tokenizer++;
if ( $level_in_tokenizer > $tokenizer_self->[_maximum_level_] )
{
$tokenizer_self->[_maximum_level_] = $level_in_tokenizer;
}
if ($forced_indentation_flag) {
# break BEFORE '?' when there is forced indentation
if ( $type eq '?' ) { $level_i = $level_in_tokenizer; }
if ( $type eq 'k' ) {
$indented_if_level = $level_in_tokenizer;
}
# do not change container environment here if we are not
# at a real list. Adding this check prevents "blinkers"
# often near 'unless" clauses, such as in the following
# code:
## next
## unless -e (
## $archive =
## File::Spec->catdir( $_, "auto", $root, "$sub$lib_ext" )
## );
$nesting_block_string .= "$nesting_block_flag";
}
else {
if ( $routput_block_type->[$i] ) {
$nesting_block_flag = 1;
$nesting_block_string .= '1';
}
else {
$nesting_block_flag = 0;
$nesting_block_string .= '0';
}
}
# we will use continuation indentation within containers
# which are not blocks and not logical expressions
my $bit = 0;
if ( !$routput_block_type->[$i] ) {
# propagate flag down at nested open parens
if ( $routput_container_type->[$i] eq '(' ) {
$bit = 1 if $nesting_list_flag;
}
# use list continuation if not a logical grouping
# /^(if|elsif|unless|while|and|or|not|&&|!|\|\||for|foreach)$/
else {
$bit = 1
unless
$is_logical_container{ $routput_container_type->[$i]
};
}
}
$nesting_list_string .= $bit;
$nesting_list_flag = $bit;
$ci_string_in_tokenizer .=
( $intervening_secondary_structure != 0 ) ? '1' : '0';
$ci_string_sum =
( my $str = $ci_string_in_tokenizer ) =~ tr/1/0/;
$continuation_string_in_tokenizer .=
( $in_statement_continuation > 0 ) ? '1' : '0';
# Sometimes we want to give an opening brace continuation indentation,
# and sometimes not. For code blocks, we don't do it, so that the leading
# '{' gets outdented, like this:
#
# if ( !$output_block_type[$i]
# && ($in_statement_continuation) )
# { <--outdented
#
# For other types, we will give them continuation indentation. For example,
# here is how a list looks with the opening paren indented:
#
# @LoL =
# ( [ "fred", "barney" ], [ "george", "jane", "elroy" ],
# [ "homer", "marge", "bart" ], );
#
# This looks best when 'ci' is one-half of the indentation (i.e., 2 and 4)
my $total_ci = $ci_string_sum;
if (
!$routput_block_type->[$i] # patch: skip for BLOCK
&& ($in_statement_continuation)
&& !( $forced_indentation_flag && $type eq ':' )
)
{
$total_ci += $in_statement_continuation
unless ( substr( $ci_string_in_tokenizer, -1 ) eq '1' );
}
$ci_string_i = $total_ci;
$in_statement_continuation = 0;
}
elsif ($type eq '}'
|| $type eq 'R'
|| $forced_indentation_flag < 0 )
{
# only a nesting error in the script would prevent popping here
if ( @{$rslevel_stack} > 1 ) { pop( @{$rslevel_stack} ); }
$level_i = --$level_in_tokenizer;
# 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';
chop $nesting_list_string;
$nesting_list_flag =
substr( $nesting_list_string, -1 ) eq '1';
chop $ci_string_in_tokenizer;
$ci_string_sum =
( my $str = $ci_string_in_tokenizer ) =~ tr/1/0/;
$in_statement_continuation =
chop $continuation_string_in_tokenizer;
# zero continuation flag at terminal BLOCK '}' which
# ends a statement.
if ( $routput_block_type->[$i] ) {
# ...These include non-anonymous subs
# note: could be sub ::abc { or sub 'abc
if ( $routput_block_type->[$i] =~ m/^sub\s*/gc ) {
# note: older versions of perl require the /gc modifier
# here or else the \G does not work.
if ( $routput_block_type->[$i] =~ /\G('|::|\w)/gc )
{
$in_statement_continuation = 0;
}
}
# ...and include all block types except user subs with
# block prototypes and these: (sort|grep|map|do|eval)
# /^(\}|\{|BEGIN|END|CHECK|INIT|AUTOLOAD|DESTROY|UNITCHECK|continue|;|if|elsif|else|unless|while|until|for|foreach)$/
elsif (
$is_zero_continuation_block_type{
$routput_block_type->[$i]
}
)
{
$in_statement_continuation = 0;
}
# ..but these are not terminal types:
# /^(sort|grep|map|do|eval)$/ )
elsif (
$is_not_zero_continuation_block_type{
$routput_block_type->[$i]
}
)
{
}
# ..and a block introduced by a label
# /^\w+\s*:$/gc ) {
elsif ( $routput_block_type->[$i] =~ /:$/ ) {
$in_statement_continuation = 0;
}
# user function with block prototype
else {
$in_statement_continuation = 0;
}
}
# If we are in a list, then
# we must set continuation indentation at the closing
# paren of something like this (paren after $check):
# assert(
# __LINE__,
# ( not defined $check )
# or ref $check
# or $check eq "new"
# or $check eq "old",
# );
elsif ( $tok eq ')' ) {
$in_statement_continuation = 1
if $routput_container_type->[$i] =~ /^[;,\{\}]$/;
}
elsif ( $tok eq ';' ) { $in_statement_continuation = 0 }
}
# use environment after updating
$container_environment =
$nesting_block_flag ? 'BLOCK'
: $nesting_list_flag ? 'LIST'
: "";
$ci_string_i = $ci_string_sum + $in_statement_continuation;
$nesting_block_string_i = $nesting_block_string;
$nesting_list_string_i = $nesting_list_string;
}
# not a structural indentation type..
else {
$container_environment =
$nesting_block_flag ? 'BLOCK'
: $nesting_list_flag ? 'LIST'
: "";
# zero the continuation indentation at certain tokens so
# that they will be at the same level as its container. For
# commas, this simplifies the -lp indentation logic, which
# counts commas. For ?: it makes them stand out.
if ($nesting_list_flag) {
## $type =~ /^[,\?\:]$/
if ( $is_comma_question_colon{$type} ) {
$in_statement_continuation = 0;
}
}
# be sure binary operators get continuation indentation
if (
$container_environment
&& ( $type eq 'k' && $is_binary_keyword{$tok}
|| $is_binary_type{$type} )
)
{
$in_statement_continuation = 1;
}
# continuation indentation is sum of any open ci from previous
# levels plus the current level
$ci_string_i = $ci_string_sum + $in_statement_continuation;
# update continuation flag ...
# if this isn't a blank or comment..
if ( $type ne 'b' && $type ne '#' ) {
# and we are in a BLOCK
if ($nesting_block_flag) {
# the next token after a ';' and label starts a new stmt
if ( $type eq ';' || $type eq 'J' ) {
$in_statement_continuation = 0;
}
# otherwise, we are continuing the current statement
else {
$in_statement_continuation = 1;
}
}
# if we are not in a BLOCK..
else {
# do not use continuation indentation if not list
# environment (could be within if/elsif clause)
if ( !$nesting_list_flag ) {
$in_statement_continuation = 0;
}
# otherwise, the token after a ',' starts a new term
# Patch FOR RT#99961; no continuation after a ';'
# This is needed because perltidy currently marks
# a block preceded by a type character like % or @
# as a non block, to simplify formatting. But these
# are actually blocks and can have semicolons.
# See code_block_type() and is_non_structural_brace().
elsif ( $type eq ',' || $type eq ';' ) {
$in_statement_continuation = 0;
}
# otherwise, we are continuing the current term
else {
$in_statement_continuation = 1;
}
}
}
}
if ( $level_in_tokenizer < 0 ) {
unless ( $tokenizer_self->[_saw_negative_indentation_] ) {
$tokenizer_self->[_saw_negative_indentation_] = 1;
warning("Starting negative indentation\n");
}
}
# set secondary nesting levels based on all containment token types
# Note: these are set so that the nesting depth is the depth
# of the PREVIOUS TOKEN, which is convenient for setting
# the strength of token bonds
my $slevel_i = $slevel_in_tokenizer;
# /^[L\{\(\[]$/
if ( $is_opening_type{$type} ) {
$slevel_in_tokenizer++;
$nesting_token_string .= $tok;
$nesting_type_string .= $type;
}
# /^[R\}\)\]]$/
elsif ( $is_closing_type{$type} ) {
$slevel_in_tokenizer--;
my $char = chop $nesting_token_string;
if ( $char ne $matching_start_token{$tok} ) {
$nesting_token_string .= $char . $tok;
$nesting_type_string .= $type;
}
else {
chop $nesting_type_string;
}
}
push( @block_type, $routput_block_type->[$i] );
push( @ci_string, $ci_string_i );
push( @container_environment, $container_environment );
push( @container_type, $routput_container_type->[$i] );
push( @levels, $level_i );
push( @nesting_tokens, $nesting_token_string_i );
push( @nesting_types, $nesting_type_string_i );
push( @slevels, $slevel_i );
push( @token_type, $fix_type );
push( @type_sequence, $routput_type_sequence->[$i] );
push( @nesting_blocks, $nesting_block_string );
push( @nesting_lists, $nesting_list_string );
# now form the previous token
if ( $im >= 0 ) {
$num =
$rtoken_map->[$i] - $rtoken_map->[$im]; # how many characters
if ( $num > 0 ) {
push( @tokens,
substr( $input_line, $rtoken_map->[$im], $num ) );
}
}
$im = $i;
}
$num = length($input_line) - $rtoken_map->[$im]; # make the last token
if ( $num > 0 ) {
push( @tokens, substr( $input_line, $rtoken_map->[$im], $num ) );
}
$tokenizer_self->[_in_attribute_list_] = $in_attribute_list;
$tokenizer_self->[_in_quote_] = $in_quote;
$tokenizer_self->[_quote_target_] =
$in_quote ? matching_end_token($quote_character) : "";
$tokenizer_self->[_rhere_target_list_] = $rhere_target_list;
$line_of_tokens->{_rtoken_type} = \@token_type;
$line_of_tokens->{_rtokens} = \@tokens;
$line_of_tokens->{_rblock_type} = \@block_type;
$line_of_tokens->{_rcontainer_type} = \@container_type;
$line_of_tokens->{_rcontainer_environment} = \@container_environment;
$line_of_tokens->{_rtype_sequence} = \@type_sequence;
$line_of_tokens->{_rlevels} = \@levels;
$line_of_tokens->{_rslevels} = \@slevels;
$line_of_tokens->{_rnesting_tokens} = \@nesting_tokens;
$line_of_tokens->{_rci_levels} = \@ci_string;
$line_of_tokens->{_rnesting_blocks} = \@nesting_blocks;
return;
}
} # end tokenize_this_line
#########i#############################################################
# Tokenizer routines which assist in identifying token types
#######################################################################
# hash lookup table of operator expected values
my %op_expected_table;
# exceptions to perl's weird parsing rules after type 'Z'
my %is_weird_parsing_rule_exception;
BEGIN {
# Always expecting TERM following these types:
# note: this is identical to '@value_requestor_type' defined later.
my @q = qw(
; ! + x & ? F J - p / Y : % f U ~ A G j L * . | ^ < = [ m { \ > t
|| >= != mm *= => .. !~ == && |= .= pp -= =~ += <= %= ^= x= ~~ ** << /=
&= // >> ~. &. |. ^.
... **= <<= >>= &&= ||= //= <=> !~~ &.= |.= ^.= <<~
);
push @q, ',';
push @q, '('; # for completeness, not currently a token type
@{op_expected_table}{@q} = (TERM) x scalar(@q);
# Always UNKNOWN following these types:
# Fix for c030: added '->' to this list
@q = qw( w -> );
@{op_expected_table}{@q} = (UNKNOWN) x scalar(@q);
# 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:
@q = qw( -- C h R ++ ] Q <> ); ## n v 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} = (OPERATOR) x scalar(@q);
}
use constant DEBUG_OPERATOR_EXPECTED => 0;
sub operator_expected {
# Returns a parameter indicating what types of tokens can occur next
# Call format:
# $op_expected = operator_expected( [ $prev_type, $tok, $next_type ] );
# where
# $prev_type is the type of the previous token (blank or not)
# $tok is the current token
# $next_type is the type of the next token (blank or not)
# 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.
my ($rarg) = @_;
my $msg = "";
##############
# Table lookup
##############
# Many types are can be obtained by a table lookup given the previous type.
# This typically handles half or more of the calls.
my $op_expected = $op_expected_table{$last_nonblank_type};
if ( defined($op_expected) ) {
$msg = "Table lookup";
goto RETURN;
}
######################
# Handle special cases
######################
$op_expected = UNKNOWN;
my ( $prev_type, $tok, $next_type ) = @{$rarg};
# Types 'k', '}' and 'Z' depend on context
# FIXME: Types 'i', 'n', 'v', 'q' currently also temporarily depend on
# context but that dependence could eventually be eliminated with better
# token type definition
# identifier...
if ( $last_nonblank_type eq 'i' ) {
$op_expected = OPERATOR;
# FIXME: it would be cleaner to make this a special type
# expecting VERSION or {} after package NAMESPACE
# TODO: maybe mark these words as type 'Y'?
if ( $statement_type =~ /^package\b/
&& $last_nonblank_token =~ /^package\b/ )
{
$op_expected = TERM;
}
}
# keyword...
elsif ( $last_nonblank_type eq 'k' ) {
$op_expected = TERM;
if ( $expecting_operator_token{$last_nonblank_token} ) {
$op_expected = OPERATOR;
}
elsif ( $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}
)
{
$op_expected = OPERATOR;
}
# Patch to allow a ? following 'split' to be a depricated 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.
elsif ($tok eq '?'
&& $last_nonblank_token eq 'split' )
{
$op_expected = UNKNOWN;
}
}
} ## end type 'k'
# 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 '}'.
elsif ( $last_nonblank_type eq '}' ) {
$op_expected = UNKNOWN;
# handle something after 'do' and 'eval'
if ( $is_block_operator{$last_nonblank_token} ) {
# something like $a = do { BLOCK } / 2;
$op_expected = OPERATOR; # block mode following }
}
elsif ( $last_nonblank_token =~ /^(\)|\$|\-\>)/ ) {
$op_expected = OPERATOR;
if ( $last_nonblank_token eq '$' ) { $op_expected = UNKNOWN }
}
# 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;
elsif ( $last_nonblank_token eq '~~' ) {
$op_expected = 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).
else {
# patch for dor.t (defined or).
if ( $tok eq '/'
&& $next_type eq '/'
&& $last_nonblank_token eq ']' )
{
$op_expected = 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.
elsif ( $tok eq '?' ) {
$op_expected = UNKNOWN;
}
else {
$op_expected = TERM;
}
}
} ## end type '}'
# 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)
elsif ( $last_nonblank_type =~ /^[nv]$/ ) {
$op_expected = OPERATOR;
if ( $statement_type eq 'use' ) {
$op_expected = UNKNOWN;
}
}
# quote...
# FIXME: labeled prototype words should probably be given type 'A' or maybe
# 'J'; not 'q'; or maybe mark as type 'Y'
elsif ( $last_nonblank_type eq 'q' ) {
$op_expected = OPERATOR;
if ( $last_nonblank_token eq 'prototype' )
##|| $last_nonblank_token eq 'switch' )
{
$op_expected = TERM;
}
}
# file handle or similar
elsif ( $last_nonblank_type eq 'Z' ) {
$op_expected = UNKNOWN;
# angle.t
if ( $last_nonblank_token =~ /^\w/ ) {
$op_expected = UNKNOWN;
}
# The 'weird parsing rules' of next section do not work for '<' and '?'
# It is best to mark them as unknown. Test case:
# print $fh ;
elsif ( $is_weird_parsing_rule_exception{$tok} ) {
$op_expected = 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" );
elsif ($prev_type eq 'b'
&& $next_type ne 'b' )
{
$op_expected = TERM;
}
# Note that '?' and '<' have been moved above
# ( $tok =~ /^([x\/\+\-\*\%\&\.\?\<]|\>\>)$/ ) {
elsif ( $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' ) {
complain(
"operator in possible indirect object location not recommended\n"
);
}
$op_expected = OPERATOR;
}
}
# anything else...
else {
$op_expected = UNKNOWN;
}
RETURN:
DEBUG_OPERATOR_EXPECTED && do {
print STDOUT
"OPERATOR_EXPECTED: $msg: returns $op_expected for last type $last_nonblank_type token $last_nonblank_token\n";
};
return $op_expected;
} ## end of sub operator_expected
sub new_statement_ok {
# return true if the current token can start a new statement
# USES GLOBAL VARIABLES: $last_nonblank_type
return label_ok() # a label would be ok here
|| $last_nonblank_type eq 'J'; # or we follow a label
}
sub label_ok {
# Decide if a bare word followed by a colon here is a label
# USES GLOBAL VARIABLES: $last_nonblank_token, $last_nonblank_type,
# $brace_depth, @brace_type
# if it follows an opening or closing code block curly brace..
if ( ( $last_nonblank_token eq '{' || $last_nonblank_token eq '}' )
&& $last_nonblank_type eq $last_nonblank_token )
{
# it is a label if and only if the curly encloses a code block
return $brace_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' );
}
}
sub code_block_type {
# 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, @brace_type
# handle case of multiple '{'s
# print "BLOCK_TYPE EXAMINING: type=$last_nonblank_type tok=$last_nonblank_token\n";
my ( $i, $rtokens, $rtoken_type, $max_token_index ) = @_;
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 ( $brace_type[$brace_depth] ) {
return decide_if_code_block( $i, $rtokens, $rtoken_type,
$max_token_index );
}
# cannot start a code block within an anonymous hash
else {
return "";
}
}
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 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 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, look at previous token. This must be a code block if
# it follows any of these:
# /^(BEGIN|END|CHECK|INIT|AUTOLOAD|DESTROY|UNITCHECK|continue|if|elsif|else|unless|do|while|until|eval|for|foreach|map|grep|sort)$/
elsif ( $is_code_block_token{$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 peren)
if ( $last_nonblank_token =~ /^(if|unless)$/
&& $last_nonblank_type eq 'k' )
{
return "";
}
else {
return $last_nonblank_token;
}
}
# or a sub or package BLOCK
elsif ( ( $last_nonblank_type eq 'i' || $last_nonblank_type eq 't' )
&& $last_nonblank_token =~ /^(sub|package)\b/ )
{
return $last_nonblank_token;
}
# or a sub alias
elsif (( $last_nonblank_type eq 'i' || $last_nonblank_type eq 't' )
&& ( $is_sub{$last_nonblank_token} ) )
{
return 'sub';
}
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 "" if ( $statement_type eq 'use' );
return 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 = $paren_type[$paren_depth];
if ( $paren_type && $paren_type =~ /^(map|grep|sort)$/ ) {
# We will mark this as a code block but use type 't' instead
# of the name of the contining 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 "";
}
}
# 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 "";
}
}
sub decide_if_code_block {
# USES GLOBAL VARIABLES: $last_nonblank_token
my ( $i, $rtokens, $rtoken_type, $max_token_index ) = @_;
my ( $next_nonblank_token, $i_next ) =
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 = "";
}
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 ];
}
my ( $rpre_tokens, $rpre_types ) =
peek_ahead_for_n_nonblank_pre_tokens(20); # 20 is arbitrary but
# generous, and prevents
# wasting lots of
# time in mangled files
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;
my $next = $pre_types[$j];
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++;
}
if ( $j > $jbeg ) {
$j++ if $pre_types[$j] eq 'b';
# Patched for RT #95708
if (
# it is a comma which is not a pattern delimeter except for qw
(
$pre_types[$j] eq ','
&& $pre_tokens[$jbeg] !~ /^(s|m|y|tr|qr|q|qq|qx)$/
)
# or a =>
|| ( $pre_types[$j] eq '=' && $pre_types[ ++$j ] eq '>' )
)
{
$code_block_type = "";
}
}
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 .= " " if ( $code_block_type =~ /^\w/ );
}
}
return $code_block_type;
}
sub report_unexpected {
# report unexpected token type and show where it is
# USES GLOBAL VARIABLES: $tokenizer_self
my ( $found, $expecting, $i_tok, $last_nonblank_i, $rpretoken_map,
$rpretoken_type, $input_line )
= @_;
if ( ++$tokenizer_self->[_unexpected_error_count_] <= MAX_NAG_MESSAGES ) {
my $msg = "found $found where $expecting expected";
my $pos = $rpretoken_map->[$i_tok];
interrupt_logfile();
my $input_line_number = $tokenizer_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 = "";
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+$//;
warning( $numbered_line . "\n" );
warning( $underline . "\n" );
warning( $msg . $trailer . "\n" );
resume_logfile();
}
return;
}
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}
return (
$last_nonblank_token =~ /^([\$\@\*\&\%\)]|->|::)/
# 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\]])$/
);
}
#########i#############################################################
# 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
#
# $depth_array[$a][$b][ $current_depth[$a] ] = $current_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 ( $aa, $pos ) = @_;
# USES GLOBAL VARIABLES: $tokenizer_self, @current_depth,
# @current_sequence_number, @depth_array, @starting_line_of_current_depth,
# $statement_type
$current_depth[$aa]++;
$total_depth++;
$total_depth[$aa][ $current_depth[$aa] ] = $total_depth;
my $input_line_number = $tokenizer_self->[_last_line_number_];
my $input_line = $tokenizer_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.
$nesting_sequence_number[$aa] += scalar(@closing_brace_names);
my $seqno = $nesting_sequence_number[$aa];
$current_sequence_number[$aa][ $current_depth[$aa] ] = $seqno;
$starting_line_of_current_depth[$aa][ $current_depth[$aa] ] =
[ $input_line_number, $input_line, $pos ];
for my $bb ( 0 .. @closing_brace_names - 1 ) {
next if ( $bb == $aa );
$depth_array[$aa][$bb][ $current_depth[$aa] ] = $current_depth[$bb];
}
# set a flag for indenting a nested ternary statement
my $indent = 0;
if ( $aa == QUESTION_COLON ) {
$nested_ternary_flag[ $current_depth[$aa] ] = 0;
if ( $current_depth[$aa] > 1 ) {
if ( $nested_ternary_flag[ $current_depth[$aa] - 1 ] == 0 ) {
my $pdepth = $total_depth[$aa][ $current_depth[$aa] - 1 ];
if ( $pdepth == $total_depth - 1 ) {
$indent = 1;
$nested_ternary_flag[ $current_depth[$aa] - 1 ] = -1;
}
}
}
}
$nested_statement_type[$aa][ $current_depth[$aa] ] = $statement_type;
$statement_type = "";
return ( $seqno, $indent );
}
sub is_balanced_closing_container {
# Return true if a closing container can go here without error
# Return false if not
my ($aa) = @_;
# cannot close if there was no opening
return unless ( $current_depth[$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
unless ( $depth_array[$aa][$bb][ $current_depth[$aa] ] ==
$current_depth[$bb] );
}
# OK, everything will be balanced
return 1;
}
sub decrease_nesting_depth {
my ( $aa, $pos ) = @_;
# USES GLOBAL VARIABLES: $tokenizer_self, @current_depth,
# @current_sequence_number, @depth_array, @starting_line_of_current_depth
# $statement_type
my $seqno = 0;
my $input_line_number = $tokenizer_self->[_last_line_number_];
my $input_line = $tokenizer_self->[_line_of_text_];
my $outdent = 0;
$total_depth--;
if ( $current_depth[$aa] > 0 ) {
# set a flag for un-indenting after seeing a nested ternary statement
$seqno = $current_sequence_number[$aa][ $current_depth[$aa] ];
if ( $aa == QUESTION_COLON ) {
$outdent = $nested_ternary_flag[ $current_depth[$aa] ];
}
$statement_type = $nested_statement_type[$aa][ $current_depth[$aa] ];
# check that any brace types $bb contained within are balanced
for my $bb ( 0 .. @closing_brace_names - 1 ) {
next if ( $bb == $aa );
unless ( $depth_array[$aa][$bb][ $current_depth[$aa] ] ==
$current_depth[$bb] )
{
my $diff =
$current_depth[$bb] -
$depth_array[$aa][$bb][ $current_depth[$aa] ];
# don't whine too many times
my $saw_brace_error = 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 ) )
)
{
interrupt_logfile();
my $rsl =
$starting_line_of_current_depth[$aa]
[ $current_depth[$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 = '';
}
else {
$ess = 's';
}
my $bname =
( $diff > 0 )
? $opening_brace_names[$bb]
: $closing_brace_names[$bb];
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 =
$starting_line_of_current_depth[$bb]
[ $current_depth[$bb] ];
my $ml = $rml->[0];
$msg .=
" The most recent un-matched $bname is on line $ml\n";
write_error_indicator_pair( @{$rml}, '^' );
}
write_error_indicator_pair( @{$rel}, '^' );
warning($msg);
resume_logfile();
}
increment_brace_error();
}
}
$current_depth[$aa]--;
}
else {
my $saw_brace_error = 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
indicate_error( $msg, $input_line_number, $input_line, $pos, '^' );
}
increment_brace_error();
# keep track of errors in braces alone (ignoring ternary nesting errors)
$tokenizer_self->[_true_brace_error_count_]++
if ( $closing_brace_names[$aa] ne "':'" );
}
return ( $seqno, $outdent );
}
sub check_final_nesting_depths {
# USES GLOBAL VARIABLES: @current_depth, @starting_line_of_current_depth
for my $aa ( 0 .. @closing_brace_names - 1 ) {
if ( $current_depth[$aa] ) {
my $rsl =
$starting_line_of_current_depth[$aa][ $current_depth[$aa] ];
my $sl = $rsl->[0];
my $msg = <<"EOM";
Final nesting depth of $opening_brace_names[$aa]s is $current_depth[$aa]
The most recent un-matched $opening_brace_names[$aa] is on line $sl
EOM
indicate_error( $msg, @{$rsl}, '^' );
increment_brace_error();
}
}
return;
}
#########i#############################################################
# Tokenizer routines for looking ahead in input stream
#######################################################################
sub peek_ahead_for_n_nonblank_pre_tokens {
# returns next n pretokens if they exist
# returns undef's if hits eof without seeing any pretokens
# USES GLOBAL VARIABLES: $tokenizer_self
my $max_pretokens = shift;
my $line;
my $i = 0;
my ( $rpre_tokens, $rmap, $rpre_types );
while ( $line =
$tokenizer_self->[_line_buffer_object_]->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;
}
return ( $rpre_tokens, $rpre_types );
}
# look ahead for next non-blank, non-comment line of code
sub peek_ahead_for_nonblank_token {
# USES GLOBAL VARIABLES: $tokenizer_self
my ( $rtokens, $max_token_index ) = @_;
my $line;
my $i = 0;
while ( $line =
$tokenizer_self->[_line_buffer_object_]->peek_ahead( $i++ ) )
{
$line =~ s/^\s*//; # trim leading blanks
next if ( length($line) <= 0 ); # skip blank
next if ( $line =~ /^#/ ); # skip comment
my ( $rtok, $rmap, $rtype ) =
pre_tokenize( $line, 2 ); # only need 2 pre-tokens
my $j = $max_token_index + 1;
foreach my $tok ( @{$rtok} ) {
last if ( $tok =~ "\n" );
$rtokens->[ ++$j ] = $tok;
}
last;
}
return;
}
#########i#############################################################
# Tokenizer guessing routines for ambiguous situations
#######################################################################
sub guess_if_pattern_or_conditional {
# this routine is called when we have encountered a ? following an
# unknown bareword, and we must decide if it starts a pattern or not
# input parameters:
# $i - token index of the ? starting possible pattern
# output parameters:
# $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 ( $i, $rtokens, $rtoken_map, $max_token_index ) = @_;
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";
}
else {
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 = '';
my $quote_pos = 0;
my $quoted_string;
(
$i, $in_quote, $quote_character, $quote_pos, $quote_depth,
$quoted_string
)
= follow_quoted_string( $ibeg, $in_quote, $rtokens, $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";
# we found an ending ?, so we bias towards a pattern
}
else {
# 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";
}
elsif ( pattern_expected( $i, $rtokens, $max_token_index ) >= 0 ) {
$is_pattern = 1;
$msg .= "pattern (found ending ? and pattern expected)\n";
}
else {
$msg .= "pattern (uncertain, but found ending ?)\n";
}
}
}
return ( $is_pattern, $msg );
}
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);
}
sub guess_if_pattern_or_division {
# 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
# input parameters:
# $i - token index of the / starting possible pattern
# output parameters:
# $is_pattern = 0 if probably division, =1 if probably a pattern
# msg = a warning or diagnostic message
# USES GLOBAL VARIABLES: $last_nonblank_token
my ( $i, $rtokens, $rtoken_map, $max_token_index ) = @_;
my $is_pattern = 0;
my $msg = "guessing that / after $last_nonblank_token starts a ";
if ( $i >= $max_token_index ) {
$msg .= "division (no end to pattern found on the line)\n";
}
else {
my $ibeg = $i;
my $divide_possible =
is_possible_numerator( $i, $rtokens, $max_token_index );
if ( $divide_possible < 0 ) {
$msg = "pattern (division not possible here)\n";
$is_pattern = 1;
goto RETURN;
}
$i = $ibeg + 1;
my $next_token = $rtokens->[$i]; # first token after slash
# One of the things we can look at is the spacing around the 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.
my $is_pattern_by_spacing =
( $i > 1 && $next_token ne ' ' && $rtokens->[ $i - 2 ] eq ' ' );
# look for a possible ending / on this line..
my $in_quote = 1;
my $quote_depth = 0;
my $quote_character = '';
my $quote_pos = 0;
my $quoted_string;
(
$i, $in_quote, $quote_character, $quote_pos, $quote_depth,
$quoted_string
)
= follow_quoted_string( $ibeg, $in_quote, $rtokens, $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
# division
if ( $divide_possible >= 0 ) {
$is_pattern = 0;
$msg .= "division (no ending / on this line)\n";
}
else {
# assuming a multi-line pattern ... this is risky, but division
# does not seem possible. If this fails, it would either be due
# to a syntax error in the code, or the division_expected logic
# needs to be fixed.
$msg = "multi-line pattern (division not possible)\n";
$is_pattern = 1;
}
}
# we found an ending /, so we bias slightly towards a pattern
else {
my $pattern_expected =
pattern_expected( $i, $rtokens, $max_token_index );
if ( $pattern_expected >= 0 ) {
# pattern looks possible...
if ( $divide_possible >= 0 ) {
# Both pattern and divide can work here...
# Increase weight of divide if a pure number follows
$divide_possible += $next_token =~ /^\d+$/;
# 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;
}
# A very common bare word in pattern expressions is 'ok'
elsif ( $is_known_function{$last_nonblank_token} ) {
$msg .=
"pattern (division works too but saw '$last_nonblank_token')\n";
$is_pattern = 1;
}
# If one rule is more definite, use it
elsif ( $divide_possible > $pattern_expected ) {
$msg .=
"division (more likely based on following tokens)\n";
$is_pattern = 0;
}
# otherwise, use the spacing rule
elsif ($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;
}
}
# divide_possible < 0 means divide can not work here
else {
$is_pattern = 1;
$msg .= "pattern (division not possible)\n";
}
}
# pattern does not look possible...
else {
if ( $divide_possible >= 0 ) {
$is_pattern = 0;
$msg .= "division (pattern not possible)\n";
}
# Neither pattern nor divide look possible...go by spacing
else {
if ($is_pattern_by_spacing) {
$msg .= "pattern (guess on spacing)\n";
$is_pattern = 1;
}
else {
$msg .= "division (guess on spacing)\n";
$is_pattern = 0;
}
}
}
}
}
RETURN:
return ( $is_pattern, $msg );
}
# try to resolve here-doc vs. shift by looking ahead for
# non-code or the end token (currently only looks for end token)
# returns 1 if it is probably a here doc, 0 if not
sub guess_if_here_doc {
# This is how many lines we will search for a target as part of the
# guessing strategy. It is a constant because there is probably
# little reason to change it.
# USES GLOBAL VARIABLES: $tokenizer_self, $current_package
# %is_constant,
my $HERE_DOC_WINDOW = 40;
my $next_token = shift;
my $here_doc_expected = 0;
my $line;
my $k = 0;
my $msg = "checking <<";
while ( $line =
$tokenizer_self->[_line_buffer_object_]->peek_ahead( $k++ ) )
{
chomp $line;
if ( $line =~ /^$next_token$/ ) {
$msg .= " -- found target $next_token ahead $k lines\n";
$here_doc_expected = 1; # got it
last;
}
last if ( $k >= $HERE_DOC_WINDOW );
}
unless ($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 ( !$is_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";
}
}
}
write_logfile_entry($msg);
return $here_doc_expected;
}
#########i#############################################################
# Tokenizer Routines for scanning identifiers and related items
#######################################################################
sub scan_bare_identifier_do {
# this routine is called to scan a token starting with an alphanumeric
# variable or package separator, :: or '.
# USES GLOBAL VARIABLES: $current_package, $last_nonblank_token,
# $last_nonblank_type,@paren_type, $paren_depth
my ( $input_line, $i, $tok, $type, $prototype, $rtoken_map,
$max_token_index )
= @_;
my $i_begin = $i;
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-- }
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*((?:\w*(?:'|::)))*(?:(?:->)?(\w+))?/gc ) {
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 = "";
if ( defined($2) ) { $sub_name = $2; }
if ( defined($1) ) {
$package = $1;
# 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 ( $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';
# warn if this version can't handle v-strings
report_v_string($tok);
}
elsif ( $is_constant{$package}{$sub_name} ) {
$type = 'C';
}
# 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';
}
# 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 ( $is_block_function{$package}{$tok} ) {
# $tok='eval'; # patch to do braces like eval - doesn't work
# $type = 'k';
#}
# FIXME: This could become a separate type to allow for different
# future behavior:
elsif ( $is_block_function{$package}{$sub_name} ) {
$type = 'G';
}
elsif ( $is_block_list_function{$package}{$sub_name} ) {
$type = 'G';
}
elsif ( $is_user_function{$package}{$sub_name} ) {
$type = 'U';
$prototype = $user_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{ $paren_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 ) {
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';
}
}
}
# 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) {
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
warning("didn't find identifier after leading ::\n");
}
return ( $i, $tok, $type, $prototype );
}
sub scan_id_do {
# This is the new scanner and will eventually replace scan_identifier.
# Only type 'sub' and 'package' are implemented.
# Token types $ * % @ & -> are not yet implemented.
#
# Scan identifier following a type token.
# 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.
# USES GLOBAL VARIABLES: $current_package, $last_nonblank_token, $in_attribute_list,
# $statement_type, $tokenizer_self
my ( $input_line, $i, $tok, $rtokens, $rtoken_map, $id_scan_state,
$max_token_index )
= @_;
use constant DEBUG_NSCAN => 0;
my $type = '';
my ( $i_beg, $pos_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 = '';
}
# 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 '#' ) {
unless ( $tok eq '$' ) {
$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
unless ($blank_line) {
if ( $is_sub{$id_scan_state} ) {
( $i, $tok, $type, $id_scan_state ) = 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 ) =
do_scan_package( $input_line, $i, $i_beg, $tok, $type, $rtokens,
$rtoken_map, $max_token_index );
$id_scan_state = '';
}
else {
warning("invalid token in scan_id: $tok\n");
$id_scan_state = '';
}
}
if ( $id_scan_state && ( !defined($type) || !$type ) ) {
# shouldn't happen:
warning(
"Program bug in scan_id: undefined type but scan_state=$id_scan_state\n"
);
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 );
}
sub check_prototype {
my ( $proto, $package, $subname ) = @_;
return unless ( defined($package) && defined($subname) );
if ( defined($proto) ) {
$proto =~ s/^\s*\(\s*//;
$proto =~ s/\s*\)$//;
if ($proto) {
$is_user_function{$package}{$subname} = 1;
$user_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 =~ /\&$/ ) {
$is_block_function{$package}{$subname} = 1;
}
# right curly braces of prototypes NOT ending in
# '&' may NOT be followed by an operator
elsif ( $proto !~ /\&$/ ) {
$is_block_list_function{$package}{$subname} = 1;
}
}
}
else {
$is_constant{$package}{$subname} = 1;
}
}
else {
$is_user_function{$package}{$subname} = 1;
}
return;
}
sub do_scan_package {
# do_scan_package parses a package name
# it 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 ( $input_line, $i, $i_beg, $tok, $type, $rtokens, $rtoken_map,
$max_token_index )
= @_;
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 = '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) { 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 ) =
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
if ( $next_nonblank_token =~ /^([v\.\d;\{\}\#])|v\d|\d+$/ ) {
$statement_type = $tok;
}
else {
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 );
}
sub scan_identifier_do {
# 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.
# USES GLOBAL VARIABLES: $context, $last_nonblank_token,
# $last_nonblank_type
my ( $i, $id_scan_state, $identifier, $rtokens, $max_token_index,
$expecting, $container_type )
= @_;
use constant DEBUG_SCAN_ID => 0;
my $i_begin = $i;
my $type = '';
my $tok_begin = $rtokens->[$i_begin];
if ( $tok_begin eq ':' ) { $tok_begin = '::' }
my $id_scan_state_begin = $id_scan_state;
my $identifier_begin = $identifier;
my $tok = $tok_begin;
my $message = "";
my $tok_is_blank; # a flag to speed things up
my $in_prototype_or_signature =
$container_type && $container_type =~ /^sub\b/;
# these flags will be used to help figure out the type:
my $saw_alpha;
my $saw_type;
# allow old package separator (') except in 'use' statement
my $allow_tick = ( $last_nonblank_token ne 'use' );
#########################################################
# 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 ( $tok eq '$' || $tok eq '*' ) {
$id_scan_state = '$';
$context = SCALAR_CONTEXT;
}
elsif ( $tok eq '%' || $tok eq '@' ) {
$id_scan_state = '$';
$context = LIST_CONTEXT;
}
elsif ( $tok eq '&' ) {
$id_scan_state = '&';
}
elsif ( $tok eq 'sub' or $tok eq 'package' ) {
$saw_alpha = 0; # 'sub' is considered type info here
$id_scan_state = '$';
$identifier .= ' '; # need a space to separate sub from sub name
}
elsif ( $tok eq '::' ) {
$id_scan_state = 'A';
}
elsif ( $tok =~ /^\w/ ) {
$id_scan_state = ':';
$saw_alpha = 1;
}
elsif ( $tok eq '->' ) {
$id_scan_state = '$';
}
else {
# shouldn't happen
my ( $a, $b, $c ) = caller;
warning("Program Bug: scan_identifier given bad token = $tok \n");
warning(" called from sub $a line: $c\n");
report_definite_bug();
}
$saw_type = !$saw_alpha;
}
else {
$i--;
$saw_alpha = ( $tok =~ /^\w/ );
$saw_type = ( $tok =~ /([\$\%\@\*\&])/ );
}
###############################
# loop to gather the identifier
###############################
my $i_save = $i;
while ( $i < $max_token_index ) {
my $last_tok_is_blank = $tok_is_blank;
if ($tok_is_blank) { $tok_is_blank = undef }
else { $i_save = $i }
$tok = $rtokens->[ ++$i ];
# patch to make digraph :: if necessary
if ( ( $tok eq ':' ) && ( $rtokens->[ $i + 1 ] eq ':' ) ) {
$tok = '::';
$i++;
}
########################
# Starting variable name
########################
if ( $id_scan_state eq '$' ) {
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 = '';
last;
}
}
elsif ( $tok =~ /^\w/ ) { # alphanumeric ..
$saw_alpha = 1;
$id_scan_state = ':'; # now need ::
$identifier .= $tok;
}
elsif ( $tok eq '::' ) {
$id_scan_state = 'A';
$identifier .= $tok;
}
# POSTDEFREF ->@ ->% ->& ->*
elsif ( ( $tok =~ /^[\@\%\&\*]$/ ) && $identifier =~ /\-\>$/ ) {
$identifier .= $tok;
}
elsif ( $tok eq "'" && $allow_tick ) { # alphanumeric ..
$saw_alpha = 1;
$id_scan_state = ':'; # 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 '#' ) {
# 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 =~ /\$$/ )
)
{
$identifier .= $tok; # keep same state, a $ could follow
}
else {
# otherwise it is a side comment
if ( $identifier eq '->' ) { }
elsif ( $id_scan_state eq '$' ) { $type = 't' }
else { $type = 'i' }
$i = $i_save;
$id_scan_state = '';
last;
}
}
elsif ( $tok eq '{' ) {
# check for something like ${#} or ${©}
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 = '';
last;
}
# skip something like ${xxx} or ->{
$id_scan_state = '';
# if this is the first token of a line, any tokens for this
# identifier have already been accumulated
if ( $identifier eq '$' || $i == 0 ) { $identifier = ''; }
$i = $i_save;
last;
}
# space ok after leading $ % * & @
elsif ( $tok =~ /^\s*$/ ) {
$tok_is_blank = 1;
if ( $identifier =~ /^[\$\%\*\&\@]/ ) {
if ( length($identifier) > 1 ) {
$id_scan_state = '';
$i = $i_save;
$type = 'i'; # probably punctuation variable
last;
}
else {
# 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.
if ( $identifier !~ /^[\@\$]$/ ) {
$message =
"Space in identifier, following $identifier\n";
}
}
}
# else:
# space after '->' is ok
}
elsif ( $tok eq '^' ) {
# check for some special variables like $^W
if ( $identifier =~ /^[\$\*\@\%]$/ ) {
$identifier .= $tok;
$id_scan_state = 'A';
# Perl accepts '$^]' or '@^]', but
# there must not be a space before the ']'.
my $next1 = $rtokens->[ $i + 1 ];
if ( $next1 eq ']' ) {
$i++;
$identifier .= $next1;
$id_scan_state = "";
last;
}
}
else {
$id_scan_state = '';
}
}
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 = "";
$type = "";
}
# 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 '$' && $tok eq '#' ) {
$type = 't';
}
$i = $i_save;
}
$id_scan_state = '';
last;
}
# check for various punctuation variables
if ( $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;
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 = ''; }
}
$id_scan_state = '';
last;
}
}
###################################
# looking for alphanumeric after ::
###################################
elsif ( $id_scan_state eq 'A' ) {
$tok_is_blank = $tok =~ /^\s*$/;
if ( $tok =~ /^\w/ ) { # found it
$identifier .= $tok;
$id_scan_state = ':'; # now need ::
$saw_alpha = 1;
}
elsif ( $tok eq "'" && $allow_tick ) {
$identifier .= $tok;
$id_scan_state = ':'; # now need ::
$saw_alpha = 1;
}
elsif ( $tok_is_blank && $identifier =~ /^sub / ) {
$id_scan_state = '(';
$identifier .= $tok;
}
elsif ( $tok eq '(' && $identifier =~ /^sub / ) {
$id_scan_state = ')';
$identifier .= $tok;
}
else {
$id_scan_state = '';
$i = $i_save;
last;
}
}
###################################
# looking for :: after alphanumeric
###################################
elsif ( $id_scan_state eq ':' ) { # looking for :: after alpha
$tok_is_blank = $tok =~ /^\s*$/;
if ( $tok eq '::' ) { # got it
$identifier .= $tok;
$id_scan_state = 'A'; # now require alpha
}
elsif ( $tok =~ /^\w/ ) { # more alphanumeric is ok here
$identifier .= $tok;
$id_scan_state = ':'; # now need ::
$saw_alpha = 1;
}
elsif ( $tok eq "'" && $allow_tick ) { # tick
if ( $is_keyword{$identifier} ) {
$id_scan_state = ''; # that's all
$i = $i_save;
}
else {
$identifier .= $tok;
}
}
elsif ( $tok_is_blank && $identifier =~ /^sub / ) {
$id_scan_state = '(';
$identifier .= $tok;
}
elsif ( $tok eq '(' && $identifier =~ /^sub / ) {
$id_scan_state = ')';
$identifier .= $tok;
}
else {
$id_scan_state = ''; # that's all
$i = $i_save;
last;
}
}
##############################
# looking for '(' of prototype
##############################
elsif ( $id_scan_state eq '(' ) {
if ( $tok eq '(' ) { # got it
$identifier .= $tok;
$id_scan_state = ')'; # now find the end of it
}
elsif ( $tok =~ /^\s*$/ ) { # blank - keep going
$identifier .= $tok;
$tok_is_blank = 1;
}
else {
$id_scan_state = ''; # that's all - no prototype
$i = $i_save;
last;
}
}
##############################
# looking for ')' of prototype
##############################
elsif ( $id_scan_state eq ')' ) {
$tok_is_blank = $tok =~ /^\s*$/;
if ( $tok eq ')' ) { # got it
$identifier .= $tok;
$id_scan_state = ''; # all done
last;
}
elsif ( $tok =~ /^[\s\$\%\\\*\@\&\;]/ ) {
$identifier .= $tok;
}
else { # probable error in script, but keep going
warning("Unexpected '$tok' while seeking end of prototype\n");
$identifier .= $tok;
}
}
###################
# Starting sub call
###################
elsif ( $id_scan_state eq '&' ) {
if ( $tok =~ /^[\$\w]/ ) { # alphanumeric ..
$id_scan_state = ':'; # now need ::
$saw_alpha = 1;
$identifier .= $tok;
}
elsif ( $tok eq "'" && $allow_tick ) { # alphanumeric ..
$id_scan_state = ':'; # now need ::
$saw_alpha = 1;
$identifier .= $tok;
}
elsif ( $tok =~ /^\s*$/ ) { # allow space
$tok_is_blank = 1;
}
elsif ( $tok eq '::' ) { # leading ::
$id_scan_state = 'A'; # accept alpha next
$identifier .= $tok;
}
elsif ( $tok eq '{' ) {
if ( $identifier eq '&' || $i == 0 ) { $identifier = ''; }
$i = $i_save;
$id_scan_state = '';
last;
}
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 = '';
$i = $i_save;
$type = '&';
}
$id_scan_state = '';
last;
}
}
######################
# unknown state - quit
######################
else { # can get here due to error in initialization
$id_scan_state = '';
$i = $i_save;
last;
}
} ## end of main loop
if ( $id_scan_state eq ')' ) {
warning("Hit end of line while seeking ) to end prototype\n");
}
# once we enter the actual identifier, it may not extend beyond
# the end of the current line
if ( $id_scan_state =~ /^[A\:\(\)]/ ) {
$id_scan_state = '';
}
# Patch: the deprecated variable $# does not combine with anything on the
# next line.
if ( $identifier eq '$#' ) { $id_scan_state = '' }
if ( $i < 0 ) { $i = 0 }
# Be sure a token type is defined
if ( !$type ) {
if ($saw_type) {
if ($saw_alpha) {
if ( $identifier =~ /^->/ && $last_nonblank_type eq '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 !~ /^(sub |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';
}
else {
$type = '';
} # this can happen on a restart
}
# See if we formed an identifier...
if ($identifier) {
$tok = $identifier;
if ($message) { write_logfile_entry($message) }
}
# did not find an identifier, back up
else {
$tok = $tok_begin;
$i = $i_begin;
}
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 );
}
{ ## 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);
}
# 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 = "";
$subname_saved = "";
return;
}
use constant {
SUB_CALL => 1,
PAREN_CALL => 2,
PROTOTYPE_CALL => 3,
};
sub do_scan_sub {
# do_scan_sub parses 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,
# $in_attribute_list, %saw_function_definition,
# $statement_type
my ($rinput_hash) = @_;
my $input_line = $rinput_hash->{input_line};
my $i = $rinput_hash->{i};
my $i_beg = $rinput_hash->{i_beg};
my $tok = $rinput_hash->{tok};
my $type = $rinput_hash->{type};
my $rtokens = $rinput_hash->{rtokens};
my $rtoken_map = $rinput_hash->{rtoken_map};
my $id_scan_state = $rinput_hash->{id_scan_state};
my $max_token_index = $rinput_hash->{max_token_index};
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 = ""; # 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 ) {
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 =
$current_sequence_number[BRACE][ $current_depth[BRACE] ];
$seqno = 1 unless ( defined($seqno) );
$package = $seqno;
if ( $warn_if_lexical{$subname} ) {
warning(
"'my' sub '$subname' matches a builtin name and may not be handled correctly in this perltidy version.\n"
);
}
}
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 = '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
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;
}
$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 = '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';
$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) { 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 ) eq ' ' )
{
$i--;
}
# check for multiple definitions of a sub
( $next_nonblank_token, my $i_next ) =
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 ) =
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 ( $saw_function_definition{$subname}{$package}
&& $subname !~ /^[A-Z]+$/ )
{
my $lno = $saw_function_definition{$subname}{$package};
if ( $package =~ /^\d/ ) {
warning(
"already saw definition of lexical 'sub $subname' at line $lno\n"
);
}
else {
warning(
"already saw definition of 'sub $subname' in package '$package' at line $lno\n"
);
}
}
$saw_function_definition{$subname}{$package} =
$tokenizer_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';
}
}
elsif ($next_nonblank_token) { # EOF technically ok
$subname = "" unless defined($subname);
warning(
"expecting ':' or ';' or '{' after definition or declaration of sub '$subname' but saw '$next_nonblank_token'\n"
);
}
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 );
}
}
#########i###############################################################
# Tokenizer utility routines which may use CONSTANTS but no other GLOBALS
#########################################################################
sub find_next_nonblank_token {
my ( $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
if ( $i >= $max_token_index ) {
if ( !peeked_ahead() ) {
peeked_ahead(1);
peek_ahead_for_nonblank_token( $rtokens, $max_token_index );
}
}
my $next_nonblank_token = $rtokens->[ ++$i ];
return ( " ", $i ) unless defined($next_nonblank_token);
if ( $next_nonblank_token =~ /^\s*$/ ) {
$next_nonblank_token = $rtokens->[ ++$i ];
return ( " ", $i ) unless defined($next_nonblank_token);
}
return ( $next_nonblank_token, $i );
}
sub is_possible_numerator {
# Look at the next non-comment character and decide if it could be a
# numerator. Return
# 1 - yes
# 0 - can't tell
# -1 - no
my ( $i, $rtokens, $max_token_index ) = @_;
my $is_possible_numerator = 0;
my $next_token = $rtokens->[ $i + 1 ];
if ( $next_token eq '=' ) { $i++; } # handle /=
my ( $next_nonblank_token, $i_next ) =
find_next_nonblank_token( $i, $rtokens, $max_token_index );
if ( $next_nonblank_token eq '#' ) {
( $next_nonblank_token, $i_next ) =
find_next_nonblank_token( $max_token_index, $rtokens,
$max_token_index );
}
if ( $next_nonblank_token =~ /(\(|\$|\w|\.|\@)/ ) {
$is_possible_numerator = 1;
}
elsif ( $next_nonblank_token =~ /^\s*$/ ) {
$is_possible_numerator = 0;
}
else {
$is_possible_numerator = -1;
}
return $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);
}
sub pattern_expected {
# 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 ( $i, $rtokens, $max_token_index ) = @_;
my $is_pattern = 0;
my $next_token = $rtokens->[ $i + 1 ];
if ( $next_token =~ /^[msixpodualgc]/ ) {
$i++;
} # skip possible modifier
my ( $next_nonblank_token, $i_next ) =
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;
}
}
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 = "";
}
return ( $next_nonblank_token, $i );
}
sub find_angle_operator_termination {
# We are looking at a '<' and want to know if it is an angle operator.
# We are to return:
# $i = pretoken index of ending '>' if found, current $i otherwise
# $type = 'Q' if found, '>' otherwise
my ( $input_line, $i_beg, $rtoken_map, $expecting, $max_token_index ) = @_;
my $i = $i_beg;
my $type = '<';
pos($input_line) = 1 + $rtoken_map->[$i];
my $filter;
# 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 { warning("Program Bug in find_angle_operator_termination\n") }
# To illustrate what we might be looking at, in case we are
# guessing, here are some examples of valid angle operators
# (or file globs):
#
#
# <$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 ) );
# 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#####
#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) {
warning(
"Possible tokinization error..please check this line\n");
report_possible_bug();
}
# 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 ) {
}
# 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
## 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*>$/ ) {
write_diagnostics("ANGLE (contains identifier): $str\n");
}
# Not sure..
else {
# Let's try a Brace Test: any braces inside must balance
my $br = 0;
while ( $str =~ /\{/g ) { $br++ }
while ( $str =~ /\}/g ) { $br-- }
my $sb = 0;
while ( $str =~ /\[/g ) { $sb++ }
while ( $str =~ /\]/g ) { $sb-- }
my $pr = 0;
while ( $str =~ /\(/g ) { $pr++ }
while ( $str =~ /\)/g ) { $pr-- }
# if braces do not balance - not angle operator
if ( $br || $sb || $pr ) {
$i = $i_beg;
$type = '<';
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 {
write_diagnostics(
"ANGLE-Guessing yes: $str expecting=$expecting\n");
write_logfile_entry("Guessing angle operator here: $str\n");
}
}
}
# didn't find ending >
else {
if ( $expecting == TERM ) {
warning("No ending > for angle operator\n");
}
}
}
return ( $i, $type );
}
sub scan_number_do {
# scan a number in any of the formats that Perl accepts
# Underbars (_) are allowed in decimal numbers.
# input parameters -
# $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
# output parameters -
# $i - last pre_token index of the number just scanned
# number - the number (characters); or undef if not a number
my ( $input_line, $i, $rtoken_map, $input_type, $max_token_index ) = @_;
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]/ ) {
warning("Program bug - scan_number given character $first_char\n");
report_definite_bug();
return ( $i, $type, $number );
}
# handle v-string without leading 'v' character ('Two Dot' rule)
# (vstring.t)
# Here is the format prior to including underscores:
## if ( $input_line =~ /\G((\d+)?\.\d+(\.\d+)+)/g ) {
pos($input_line) = $pos_beg;
if ( $input_line =~ /\G((\d[_\d]*)?\.[\d_]+(\.[\d_]+)+)/g ) {
$pos = pos($input_line);
my $numc = $pos - $pos_beg;
$number = substr( $input_line, $pos_beg, $numc );
$type = 'v';
report_v_string($number);
}
# handle octal, hex, binary
if ( !defined($number) ) {
pos($input_line) = $pos_beg;
# Perl 5.22 added floating point literals, like '0x0.b17217f7d1cf78p0'
# For reference, the format prior to hex floating point is:
# /\G[+-]?0(([xX][0-9a-fA-F_]+)|([0-7_]+)|([bB][01_]+))/g )
# (hex) (octal) (binary)
if (
$input_line =~
/\G[+-]?0( # leading [signed] 0
# a hex float, i.e. '0x0.b17217f7d1cf78p0'
([xX][0-9a-fA-F_]* # X and optional leading digits
(\.([0-9a-fA-F][0-9a-fA-F_]*)?)? # optional decimal and fraction
[Pp][+-]?[0-9a-fA-F] # REQUIRED exponent with digit
[0-9a-fA-F_]*) # optional Additional exponent digits
# or hex integer
|([xX][0-9a-fA-F_]+)
# or octal fraction
|([oO]?[0-7_]+ # string of octal digits
(\.([0-7][0-7_]*)?)? # optional decimal and fraction
[Pp][+-]?[0-7] # REQUIRED exponent, no underscore
[0-7_]*) # Additional exponent digits with underscores
# or octal integer
|([oO]?[0-7_]+) # string of octal digits
# or a binary float
|([bB][01_]* # 'b' with string of binary digits
(\.([01][01_]*)?)? # optional decimal and fraction
[Pp][+-]?[01] # Required exponent indicator, no underscore
[01_]*) # additional exponent bits
# or binary integer
|([bB][01_]+) # 'b' with string of binary digits
)/gx
)
{
$pos = pos($input_line);
my $numc = $pos - $pos_beg;
$number = substr( $input_line, $pos_beg, $numc );
$type = 'n';
}
}
# handle decimal
if ( !defined($number) ) {
pos($input_line) = $pos_beg;
if ( $input_line =~ /\G([+-]?[\d_]*(\.[\d_]*)?([Ee][+-]?(\d+))?)/g ) {
$pos = pos($input_line);
# watch out for things like 0..40 which would give 0. by this;
if ( ( substr( $input_line, $pos - 1, 1 ) eq '.' )
&& ( substr( $input_line, $pos, 1 ) eq '.' ) )
{
$pos--;
}
my $numc = $pos - $pos_beg;
$number = substr( $input_line, $pos_beg, $numc );
$type = 'n';
}
}
# filter out non-numbers like e + - . e2 .e3 +e6
# the rule: at least one digit, and any 'e' must be preceded by a digit
if (
$number !~ /\d/ # no digits
|| ( $number =~ /^(.*)[eE]/
&& $1 !~ /\d/ ) # or no digits before the 'e'
)
{
$number = undef;
$type = $input_type;
return ( $i, $type, $number );
}
# Found a number; now we must convert back from character position
# to pre_token index. An error here implies user syntax error.
# An example would be an invalid octal number like '009'.
my $error;
( $i, $error ) =
inverse_pretoken_map( $i, $pos, $rtoken_map, $max_token_index );
if ($error) { warning("Possibly invalid number\n") }
return ( $i, $type, $number );
}
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;
}
}
return ( $i, $error );
}
sub find_here_doc {
# find the target of a here document, if any
# input parameters:
# $i - token index of the second < of <<
# ($i must be less than the last token index if this is called)
# output parameters:
# $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 ( $expecting, $i, $rtokens, $rtoken_map, $max_token_index ) = @_;
my $ibeg = $i;
my $found_target = 0;
my $here_doc_target = '';
my $here_quote_character = '';
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 = 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
)
= follow_quoted_string( $i_next_nonblank, $in_quote, $rtokens,
$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 ) {
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;
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 = 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;
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 );
}
sub do_quote {
# 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 (
$i, $in_quote, $quote_character,
$quote_pos, $quote_depth, $quoted_string_1,
$quoted_string_2, $rtokens, $rtoken_map,
$max_token_index
) = @_;
my $in_quote_starting = $in_quote;
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
)
= follow_quoted_string( $i, $in_quote, $rtokens, $quote_character,
$quote_pos, $quote_depth, $max_token_index );
$quoted_string_2 .= $quoted_string;
if ( $in_quote == 1 ) {
if ( $quote_character =~ /[\{\[\<\(]/ ) { $i++; }
$quote_character = '';
}
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
)
= follow_quoted_string( $ibeg, $in_quote, $rtokens, $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 );
}
sub follow_quoted_string {
# scan for a specific token, skipping escaped characters
# if the quote character is blank, use the first non-blank character
# input parameters:
# $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
# output parameters:
# $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 ( $i_beg, $in_quote, $rtokens, $beginning_tok, $quote_pos, $quote_depth,
$max_token_index )
= @_;
my ( $tok, $end_tok );
my $i = $i_beg - 1;
my $quoted_string = "";
0 && do {
print STDOUT
"QUOTE entering with quote_pos = $quote_pos i=$i beginning_tok =$beginning_tok\n";
};
# get the corresponding end token
if ( $beginning_tok !~ /^\s*$/ ) {
$end_tok = matching_end_token($beginning_tok);
}
# a blank token means we must 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 ( $tok !~ /^\s*$/ ) {
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);
$quote_depth = 1;
last;
}
}
else {
$allow_quote_comments = 1;
}
}
}
# 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 ( $beginning_tok =~ /\w/ ) {
# Note this because it is not recommended practice except
# for obfuscated perl contests
if ( $in_quote == 1 ) {
write_logfile_entry(
"Note: alphanumeric quote delimiter ($beginning_tok) \n");
}
while ( $i < $max_token_index ) {
if ( $quote_pos == 0 || ( $i < 0 ) ) {
$tok = $rtokens->[ ++$i ];
if ( $tok eq '\\' ) {
# 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;
unless ( defined($tok) && defined($end_tok) && defined($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 );
$quote_depth--;
if ( $quote_depth == 0 ) {
$in_quote--;
last;
}
}
else {
if ( $old_pos <= length($tok) ) {
$quoted_string .= substr( $tok, $old_pos );
}
}
}
}
########################################################################
# 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 '\\' ) {
# retain backslash unless it hides the beginning or end token
$tok = $rtokens->[ ++$i ];
$quoted_string .= '\\'
unless ( $tok eq $end_tok || $tok eq $beginning_tok );
}
$quoted_string .= $tok;
}
}
if ( $i > $max_token_index ) { $i = $max_token_index }
return ( $i, $in_quote, $beginning_tok, $quote_pos, $quote_depth,
$quoted_string );
}
sub indicate_error {
my ( $msg, $line_number, $input_line, $pos, $carrat ) = @_;
interrupt_logfile();
warning($msg);
write_error_indicator_pair( $line_number, $input_line, $pos, $carrat );
resume_logfile();
return;
}
sub write_error_indicator_pair {
my ( $line_number, $input_line, $pos, $carrat ) = @_;
my ( $offset, $numbered_line, $underline ) =
make_numbered_line( $line_number, $input_line, $pos );
$underline = write_on_underline( $underline, $pos - $offset, $carrat );
warning( $numbered_line . "\n" );
$underline =~ s/\s*$//;
warning( $underline . "\n" );
return;
}
sub make_numbered_line {
# Given an input line, its line number, and a 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 ( $lineno, $str, $pos ) = @_;
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 = " " x length($numbered_line);
return ( $offset, $numbered_line, $underline );
}
sub write_on_underline {
# 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.
my ( $underline, $pos, $pos_chr ) = @_;
# check for error..shouldn't happen
unless ( ( $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);
}
sub pre_tokenize {
# Break a string, $str, into a sequence of preliminary tokens. We
# are interested in these types of tokens:
# words (type='w'), example: 'max_tokens_wanted'
# digits (type = 'd'), example: '0755'
# whitespace (type = 'b'), example: ' '
# any other single character (i.e. punct; type = the character itself).
# We cannot do better than this yet because we might be in a quoted
# string or pattern. Caller sets $max_tokens_wanted to 0 to get all
# tokens.
my ( $str, $max_tokens_wanted ) = @_;
# we return references to these 3 arrays:
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
do {
# whitespace
if ( $str =~ /\G(\s+)/gc ) { push @type, 'b'; }
# numbers
# note that this must come before words!
elsif ( $str =~ /\G(\d+)/gc ) { push @type, 'd'; }
# words
elsif ( $str =~ /\G(\w+)/gc ) { push @type, 'w'; }
# single-character punctuation
elsif ( $str =~ /\G(\W)/gc ) { push @type, $1; }
# that's all..
else {
return ( \@tokens, \@token_map, \@type );
}
push @tokens, $1;
push @token_map, pos($str);
} while ( --$max_tokens_wanted != 0 );
return ( \@tokens, \@token_map, \@type );
}
sub show_tokens {
# this is an old debug routine
# not called, but 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;
}
{ ## closure for sub matching end token
my %matching_end_token;
BEGIN {
%matching_end_token = (
'{' => '}',
'(' => ')',
'[' => ']',
'<' => '>',
);
}
sub matching_end_token {
# return closing character for a pattern
my $beginning_token = shift;
if ( $matching_end_token{$beginning_token} ) {
return $matching_end_token{$beginning_token};
}
return ($beginning_token);
}
}
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)
M (unused, but reserved for subroutine definition name)
P (unused, but -html uses it to label pod text)
t type indicater 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, '.'
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;
}
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);
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)
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
{ } ( ) [ ] ; + - / * | % ! 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);
# 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.
@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);
# 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
switch
case
default
given
when
err
say
isa
catch
);
# 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 );
@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)
@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 = %expecting_term_types;
# 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 qw qx qr s y tr m);
@is_q_qq_qw_qx_qr_s_y_tr_m{@q} = (1) x scalar(@q);
@q = qw(package);
@is_package{@q} = (1) x scalar(@q);
@q = qw( ? : );
push @q, ',';
@is_comma_question_colon{@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
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
while
given
when
);
@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 (depricated) pattern delimiter. In the future, they might be used
# to give a warning about ambiguous syntax before a /.
# Note: split has been omitted (see not 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 delmited 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);
}
1;
Perl-Tidy-20210717/lib/Perl/Tidy/LineSink.pm 0000644 0001750 0001750 00000007042 14073571551 017274 0 ustar steve steve #####################################################################
#
# the Perl::Tidy::LineSink class supplies a write_line method for
# actual file writing
#
#####################################################################
package Perl::Tidy::LineSink;
use strict;
use warnings;
our $VERSION = '20210717';
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,
line_separator => undef,
rOpts => undef,
rpending_logfile_message => undef,
is_encoded_data => undef,
);
my %args = ( %defaults, @args );
my $output_file = $args{output_file};
my $line_separator = $args{line_separator};
my $rOpts = $args{rOpts};
my $rpending_logfile_message = $args{rpending_logfile_message};
my $is_encoded_data = $args{is_encoded_data};
my $fh = undef;
my $output_file_open = 0;
if ( $rOpts->{'format'} eq 'tidy' ) {
( $fh, $output_file ) =
Perl::Tidy::streamhandle( $output_file, 'w', $is_encoded_data );
unless ($fh) { Perl::Tidy::Die("Cannot write to output stream\n"); }
$output_file_open = 1;
}
# in order to check output syntax when standard output is used,
# or when it is an object, we have to make a copy of the file
if ( $output_file eq '-' || ref $output_file ) {
if ( $rOpts->{'check-syntax'} ) {
# Turning off syntax check when standard output is used.
# The reason is that temporary files cause problems on
# on many systems.
$rOpts->{'check-syntax'} = 0;
${$rpending_logfile_message} .= < $fh,
_output_file => $output_file,
_output_file_open => $output_file_open,
_line_separator => $line_separator,
_is_encoded_data => $is_encoded_data,
}, $class;
}
sub set_line_separator {
my ( $self, $val ) = @_;
$self->{_line_separator} = $val;
return;
}
sub write_line {
my ( $self, $line ) = @_;
my $fh = $self->{_fh};
my $line_separator = $self->{_line_separator};
if ( defined($line_separator) ) {
chomp $line;
$line .= $line_separator;
}
$fh->print($line) if ( $self->{_output_file_open} );
return;
}
sub close_output_file {
my $self = shift;
# Only close physical files, not STDOUT and other objects
my $output_file = $self->{_output_file};
if ( $output_file ne '-' && !ref $output_file ) {
$self->{_fh}->close() if $self->{_output_file_open};
}
return;
}
1;
Perl-Tidy-20210717/lib/Perl/Tidy/Diagnostics.pm 0000644 0001750 0001750 00000005355 14073571544 020036 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.
#
# NOTE: This feature is deactivated in final releases but can be
# reactivated for debugging by un-commenting the 'I' options flag
#
#####################################################################
package Perl::Tidy::Diagnostics;
use strict;
use warnings;
our $VERSION = '20210717';
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 => "",
_input_file => "",
_fh => undef,
}, $class;
}
sub set_input_file {
my ( $self, $input_file ) = @_;
$self->{_input_file} = $input_file;
return;
}
sub write_diagnostics {
my ( $self, $msg ) = @_;
unless ( $self->{_write_diagnostics_count} ) {
open( $self->{_fh}, ">", "DIAGNOSTICS" )
or Perl::Tidy::Die("couldn't open DIAGNOSTICS: $!\n");
}
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;
my $input_line_number = Perl::Tidy::Tokenizer::get_input_line_number();
$fh->print("$input_line_number:\t$msg");
$self->{_write_diagnostics_count}++;
return;
}
1;
Perl-Tidy-20210717/lib/Perl/Tidy/IndentationItem.pm 0000644 0001750 0001750 00000017016 14073571550 020654 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 = '20210717';
BEGIN {
# Array index names
my $i = 0;
use constant {
_spaces_ => $i++,
_level_ => $i++,
_ci_level_ => $i++,
_available_spaces_ => $i++,
_closed_ => $i++,
_comma_count_ => $i++,
_sequence_number_ => $i++,
_index_ => $i++,
_have_child_ => $i++,
_recoverable_spaces_ => $i++,
_align_paren_ => $i++,
_marked_ => $i++,
_stack_depth_ => $i++,
_starting_index_K_ => $i++,
_arrow_count_ => $i++,
};
}
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?
# sequence_number => # output batch number
# 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_paren => # do we want to try to align
# # with an opening structure?
# marked => # if visited by corrector logic
# stack_depth => # indentation nesting depth
# starting_index_K => # first token index K of this level
# arrow_count => # how many =>'s
my $self = [];
$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->[_sequence_number_] = $input_hash{gnu_sequence_number};
$self->[_index_] = $input_hash{index};
$self->[_have_child_] = 0;
$self->[_recoverable_spaces_] = 0;
$self->[_align_paren_] = $input_hash{align_paren};
$self->[_marked_] = 0;
$self->[_stack_depth_] = $input_hash{stack_depth};
$self->[_starting_index_K_] = $input_hash{starting_index_K};
$self->[_arrow_count_] = 0;
bless $self, $class;
return $self;
}
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 ( $item, $spaces_needed ) = @_;
my $available_spaces = $item->get_available_spaces();
my $deleted_spaces =
( $available_spaces > $spaces_needed )
? $spaces_needed
: $available_spaces;
$item->decrease_available_spaces($deleted_spaces);
$item->decrease_SPACES($deleted_spaces);
$item->set_recoverable_spaces(0);
return $deleted_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 ( $item, $spaces_needed ) = @_;
my $available_spaces = $item->get_available_spaces();
my $deleted_spaces =
( $available_spaces > $spaces_needed )
? $spaces_needed
: $available_spaces;
$item->decrease_available_spaces($deleted_spaces);
$item->decrease_SPACES($deleted_spaces);
$item->increase_recoverable_spaces($deleted_spaces);
return $deleted_spaces;
}
sub get_stack_depth {
return $_[0]->[_stack_depth_];
}
sub get_spaces {
return $_[0]->[_spaces_];
}
sub get_marked {
return $_[0]->[_marked_];
}
sub set_marked {
my ( $self, $value ) = @_;
if ( defined($value) ) {
$self->[_marked_] = $value;
}
return $self->[_marked_];
}
sub get_available_spaces {
return $_[0]->[_available_spaces_];
}
sub decrease_SPACES {
my ( $self, $value ) = @_;
if ( defined($value) ) {
$self->[_spaces_] -= $value;
}
return $self->[_spaces_];
}
sub decrease_available_spaces {
my ( $self, $value ) = @_;
if ( defined($value) ) {
$self->[_available_spaces_] -= $value;
}
return $self->[_available_spaces_];
}
sub get_align_paren {
return $_[0]->[_align_paren_];
}
sub get_recoverable_spaces {
return $_[0]->[_recoverable_spaces_];
}
sub set_recoverable_spaces {
my ( $self, $value ) = @_;
if ( defined($value) ) {
$self->[_recoverable_spaces_] = $value;
}
return $self->[_recoverable_spaces_];
}
sub increase_recoverable_spaces {
my ( $self, $value ) = @_;
if ( defined($value) ) {
$self->[_recoverable_spaces_] += $value;
}
return $self->[_recoverable_spaces_];
}
sub get_ci_level {
return $_[0]->[_ci_level_];
}
sub get_level {
return $_[0]->[_level_];
}
sub get_sequence_number {
return $_[0]->[_sequence_number_];
}
sub get_index {
return $_[0]->[_index_];
}
sub get_starting_index_K {
return $_[0]->[_starting_index_K_];
}
sub set_have_child {
my ( $self, $value ) = @_;
if ( defined($value) ) {
$self->[_have_child_] = $value;
}
return $self->[_have_child_];
}
sub get_have_child {
return $_[0]->[_have_child_];
}
sub set_arrow_count {
my ( $self, $value ) = @_;
if ( defined($value) ) {
$self->[_arrow_count_] = $value;
}
return $self->[_arrow_count_];
}
sub get_arrow_count {
return $_[0]->[_arrow_count_];
}
sub set_comma_count {
my ( $self, $value ) = @_;
if ( defined($value) ) {
$self->[_comma_count_] = $value;
}
return $self->[_comma_count_];
}
sub get_comma_count {
return $_[0]->[_comma_count_];
}
sub set_closed {
my ( $self, $value ) = @_;
if ( defined($value) ) {
$self->[_closed_] = $value;
}
return $self->[_closed_];
}
sub get_closed {
return $_[0]->[_closed_];
}
1;
Perl-Tidy-20210717/lib/Perl/Tidy/HtmlWriter.pm 0000644 0001750 0001750 00000142407 14073571546 017672 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 = '20210717';
use File::Basename;
# class variables
use vars qw{
%html_color
%html_bold
%html_italic
%token_short_names
%short_to_long_names
$rOpts
$css_filename
$css_linkname
$missing_html_entities
$missing_pod_html
};
# replace unsafe characters with HTML entity representation if HTML::Entities
# is available
#{ eval "use HTML::Entities"; $missing_html_entities = $@; }
BEGIN {
if ( !eval { require HTML::Entities; 1 } ) {
$missing_html_entities = $@ ? $@ : 1;
}
if ( !eval { require Pod::Html; 1 } ) {
$missing_pod_html = $@ ? $@ : 1;
}
}
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, @args );
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_file_opened = 0;
my $html_fh;
( $html_fh, my $html_filename ) =
Perl::Tidy::streamhandle( $html_file, 'w' );
unless ($html_fh) {
Perl::Tidy::Warn("can't open $html_file: $!\n");
return;
}
$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 {
##eval "use Pod::Html";
#if ($@) {
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'} ) {
unless ($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'};
unless ($title) {
( $title, my $path ) = fileparse($input_file);
}
my $toc_item_count = 0;
my $in_toc_package = "";
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;
}
sub close_object {
my ($object) = @_;
# returns true if close works, false if not
# failure probably means there is no close method
return eval { $object->close(); 1 };
}
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} = "";
}
};
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;
};
# start the table of contents on the first item
unless ( ${$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} ];
unless ($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
unless ( ${$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;
}
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
%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',
'M' => 'm',
'P' => 'pd',
'A' => 'co',
);
# These token types will all be called identifiers for now
# FIXME: could separate user defined modules as separate type
my @identifier = qw< i t U C Y Z G :: 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);
}
sub make_getopt_long_names {
my ( $class, $rgetopt_names ) = @_;
while ( my ( $short_name, $name ) = each %short_to_long_names ) {
push @{$rgetopt_names}, "html-color-$name=s";
push @{$rgetopt_names}, "html-italic-$name!";
push @{$rgetopt_names}, "html-bold-$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;
}
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
while ( my ( $short_name, $long_name ) = each %short_to_long_names ) {
${$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;
}
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 ForestGreen => "#228B22";
use constant SaddleBrown => "#8B4513";
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
while ( my ( $short_name, $long_name ) = each %short_to_long_names ) {
$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
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
my $css_filename = $css_linkname;
unless ( -e $css_filename ) {
write_style_sheet_file($css_filename);
}
}
$missing_html_entities = 1 unless $rOpts->{'html-entities'};
return;
}
sub write_style_sheet_file {
my $css_filename = shift;
my $fh;
unless ( $fh = IO::File->new("> $css_filename") ) {
Perl::Tidy::Die("can't open $css_filename: $!\n");
}
write_style_sheet_data($fh);
close_object($fh);
return;
}
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 .= ' ' } # 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;
}
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;
}
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;
}
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;
}
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 $input_file = $self->{_input_file};
my $title = $self->{_title};
my $success_flag = 0;
# don't try to use pod2html if no pod
unless ($pod_string) {
return $success_flag;
}
# Pod::Html requires a real temporary filename
my ( $fh_tmp, $tmpfile ) = File::Temp::tempfile();
unless ($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);
$fh_tmp->close();
# 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";
}
}
# "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' );
unless ($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");
goto RETURN;
}
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 (@_) {
$html_fh->print($_) unless ($no_print);
if ($in_toc) { push @toc, $_ }
}
};
# 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 = "";
if ( $rOpts->{'timestamp'} ) {
my $date = localtime;
$timestamp = "on $date";
}
while ( my $line = $fh_tmp->getline() ) {
if ( $line =~ /^\s*\s*$/i ) {
##my $date = localtime;
##$html_print->("\n");
$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 = map { $_ .= "\n" } split /\n/, $toc_string;
my @toc = map { $_ . "\n" } split /\n/, $toc_string;
$html_print->(@toc);
}
$in_toc = "";
$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 = map { $_ .= "\n" } split /\n/, $toc_string;
my @toc = map { $_ . "\n" } split /\n/, $toc_string;
$html_print->(@toc);
}
$in_toc = "";
$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} ) {
unless ( $self->{_pod_cut_count} > 1 ) {
$html_print->('
');
}
while ( my $rpre_string = shift( @{$rpre_string_stack} ) ) {
$html_print->('');
$html_print->( ${$rpre_string} );
$html_print->('');
}
}
$html_print->($line);
}
else {
$html_print->($line);
}
}
$success_flag = 1;
unless ($saw_body) {
Perl::Tidy::Warn("Did not see in pod2html output\n");
$success_flag = 0;
}
unless ($saw_body_end) {
Perl::Tidy::Warn("Did not see in pod2html output\n");
$success_flag = 0;
}
unless ($saw_index) {
Perl::Tidy::Warn("Did not find INDEX END in pod2html output\n");
$success_flag = 0;
}
RETURN:
close_object($html_fh);
# 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 ) {
unless ( unlink($tmpfile) ) {
Perl::Tidy::Warn("couldn't unlink temporary file $tmpfile: $!\n");
$success_flag = 0;
}
}
if ( $success_flag && $rOpts->{'frames'} ) {
$self->make_frame( \@toc );
}
return $success_flag;
}
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 $input_file = $self->{_input_file};
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 = "";
# 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 ) = fileparse($toc_filename);
my ( $src_basename, $src_path ) = 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 =
write_toc_html( $title, $toc_filename, $src_basename, $rtoc,
$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:$!\n");
# 3. Then use the original html filename for the frame
write_frame_html(
$title, $html_filename, $top_basename,
$toc_basename, $src_basename, $src_frame_name
);
return;
}
sub write_toc_html {
# write a separate html table of contents file for frames
my ( $title, $toc_filename, $src_basename, $rtoc, $src_frame_name ) = @_;
my $fh = IO::File->new( $toc_filename, 'w' )
or Perl::Tidy::Die("Cannot open $toc_filename:$!\n");
$fh->print(<
$title
$title
EOM
my $first_anchor =
change_anchor_names( $rtoc, $src_basename, "$src_frame_name" );
$fh->print( join "", @{$rtoc} );
$fh->print(<
EOM
return;
}
sub write_frame_html {
# write an html file to be the table of contents frame
my (
$title, $frame_filename, $top_basename,
$toc_basename, $src_basename, $src_frame_name
) = @_;
my $fh = IO::File->new( $frame_filename, 'w' )
or Perl::Tidy::Die("Cannot open $toc_basename:$!\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;
}
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";
unless ($first_anchor) { $first_anchor = $href }
}
}
return $first_anchor;
}
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
close_object($html_fh);
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());
}
# use css embedded in this file
elsif ( !$rOpts->{'nohtml-style-sheets'} ) {
$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 = "";
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
close_object($html_fh);
if ( $rOpts->{'frames'} ) {
##my @toc = map { $_ .= "\n" } split /\n/, ${$rtoc_string};
my @toc = map { $_ . "\n" } split /\n/, ${$rtoc_string};
$self->make_frame( \@toc );
}
return;
}
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};
for ( my $j = 0 ; $j < @{$rtoken_type} ; $j++ ) {
$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} ) {
unless ( $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];
unless ($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' );
}
}
${$rlast_level} = $level;
#-------------------------------------------------------
# Intercept a sub name here; split it
# into keyword 'sub' and sub name; and add an
# entry in the toc
#-------------------------------------------------------
if ( $type eq 'i' && $token =~ /^(sub\s+)(\w.*)$/ ) {
$token = $self->markup_html_element( $1, 'k' );
push @colored_tokens, $token;
$token = $2;
$type = 'M';
# but don't include sub declarations in the toc;
# these wlll have leading token types 'i;'
my $signature = join "", @{$rtoken_type};
unless ( $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
#-------------------------------------------------------
if ( $type eq 'i' && $token =~ /^(package\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 );
}
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;
}
sub escape_html {
my $token = shift;
if ($missing_html_entities) {
$token =~ s/\&/&/g;
$token =~ s/\/>/g;
$token =~ s/\"/"/g;
}
else {
HTML::Entities::encode_entities($token);
}
return $token;
}
sub finish_formatting {
# called after last line
my $self = shift;
$self->close_html_file();
return;
}
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 = "";
}
my ($rcolored_tokens) =
$self->markup_tokens( $rtokens, $rtoken_type, $rlevels );
$html_line .= join '', @{$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 '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/ ) {
$line_character = 'P';
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} = "";
$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 ) ? " "
: ( $line_number < 100 ) ? " "
: ( $line_number < 1000 ) ? " "
: "";
$html_line = $extra_space . $line_number . " " . $html_line;
}
# write the line
$html_pre_fh->print("$html_line\n");
return;
}
1;
Perl-Tidy-20210717/lib/Perl/Tidy/LineBuffer.pm 0000644 0001750 0001750 00000004462 14073571551 017604 0 ustar steve steve #####################################################################
#
# The Perl::Tidy::LineBuffer class supplies a 'get_line()'
# method for returning the next line to be parsed, as well as a
# 'peek_ahead()' method
#
# The input parameter is an object with a 'get_line()' method
# which returns the next line to be parsed
#
#####################################################################
package Perl::Tidy::LineBuffer;
use strict;
use warnings;
our $VERSION = '20210717';
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 < $line_source_object,
_rlookahead_buffer => [],
}, $class;
}
sub peek_ahead {
my ( $self, $buffer_index ) = @_;
my $line = undef;
my $line_source_object = $self->{_line_source_object};
my $rlookahead_buffer = $self->{_rlookahead_buffer};
if ( $buffer_index < scalar( @{$rlookahead_buffer} ) ) {
$line = $rlookahead_buffer->[$buffer_index];
}
else {
$line = $line_source_object->get_line();
push( @{$rlookahead_buffer}, $line );
}
return $line;
}
sub get_line {
my $self = shift;
my $line = undef;
my $line_source_object = $self->{_line_source_object};
my $rlookahead_buffer = $self->{_rlookahead_buffer};
if ( scalar( @{$rlookahead_buffer} ) ) {
$line = shift @{$rlookahead_buffer};
}
else {
$line = $line_source_object->get_line();
}
return $line;
}
1;
Perl-Tidy-20210717/lib/Perl/Tidy/LineSource.pm 0000644 0001750 0001750 00000007202 14073571552 017627 0 ustar steve steve #####################################################################
#
# the Perl::Tidy::LineSource class supplies an object with a 'get_line()' method
# which returns the next line to be parsed
#
#####################################################################
package Perl::Tidy::LineSource;
use strict;
use warnings;
our $VERSION = '20210717';
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,
rOpts => undef,
rpending_logfile_message => undef,
);
my %args = ( %defaults, @args );
my $input_file = $args{input_file};
my $rOpts = $args{rOpts};
my $rpending_logfile_message = $args{rpending_logfile_message};
my $input_line_ending;
if ( $rOpts->{'preserve-line-endings'} ) {
$input_line_ending = Perl::Tidy::find_input_line_ending($input_file);
}
( my $fh, $input_file ) = Perl::Tidy::streamhandle( $input_file, 'r' );
return unless $fh;
# in order to check output syntax when standard output is used,
# or when it is an object, we have to make a copy of the file
if ( ( $input_file eq '-' || ref $input_file ) && $rOpts->{'check-syntax'} )
{
# Turning off syntax check when input output is used.
# The reason is that temporary files cause problems on
# on many systems.
$rOpts->{'check-syntax'} = 0;
${$rpending_logfile_message} .= < $fh,
_filename => $input_file,
_input_line_ending => $input_line_ending,
_rinput_buffer => [],
_started => 0,
}, $class;
}
sub close_input_file {
my $self = shift;
# Only close physical files, not STDIN and other objects
my $filename = $self->{_filename};
if ( $filename ne '-' && !ref $filename ) {
eval { $self->{_fh}->close() };
}
return;
}
sub get_line {
my $self = shift;
my $line = undef;
my $fh = $self->{_fh};
my $rinput_buffer = $self->{_rinput_buffer};
if ( scalar( @{$rinput_buffer} ) ) {
$line = shift @{$rinput_buffer};
}
else {
$line = $fh->getline();
# patch to read raw mac files under unix, dos
# see if the first line has embedded \r's
if ( $line && !$self->{_started} ) {
if ( $line =~ /[\015][^\015\012]/ ) {
# found one -- break the line up and store in a buffer
@{$rinput_buffer} = map { $_ . "\n" } split /\015/, $line;
my $count = @{$rinput_buffer};
$line = shift @{$rinput_buffer};
}
$self->{_started}++;
}
}
return $line;
}
1;
Perl-Tidy-20210717/lib/Perl/Tidy/Formatter.pm 0000644 0001750 0001750 00003267274 14074420117 017535 0 ustar steve steve #####################################################################
#
# The Perl::Tidy::Formatter package adds indentation, whitespace, and
# line breaks to the token stream
#
#####################################################################
# 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 statments
# sub set_continuation_breaks
# CODE SECTION 11: Code to break long lists
# sub scan_list
# CODE SECTION 12: Code for setting indentation
# CODE SECTION 13: Preparing batches for vertical alignment
# sub send_lines_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;
# this can be turned on for extra checking during development
use constant DEVEL_MODE => 0;
{ #<<< A non-indenting brace to contain all lexical variables
use Carp;
our $VERSION = '20210717';
# 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 <_decrement_count();
return;
}
sub Die {
my ($msg) = @_;
Perl::Tidy::Die($msg);
croak "unexpected return from Perl::Tidy::Die";
}
sub Warn {
my ($msg) = @_;
Perl::Tidy::Warn($msg);
return;
}
sub Fault {
my ($msg) = @_;
# This routine is called for errors that really should not occur
# except if there has been a bug introduced by a recent program change.
# Please add comments at calls to Fault to explain why the call
# should not occur, and where to look to fix it.
my ( $package0, $filename0, $line0, $subroutine0 ) = caller(0);
my ( $package1, $filename1, $line1, $subroutine1 ) = caller(1);
my ( $package2, $filename2, $line2, $subroutine2 ) = caller(2);
my $input_stream_name = get_input_stream_name();
Die(< $i++,
_CI_LEVEL_ => $i++,
_CUMULATIVE_LENGTH_ => $i++,
_LINE_INDEX_ => $i++,
_KNEXT_SEQ_ITEM_ => $i++,
_LEVEL_ => $i++,
_SLEVEL_ => $i++,
_TOKEN_ => $i++,
_TOKEN_LENGTH_ => $i++,
_TYPE_ => $i++,
_TYPE_SEQUENCE_ => $i++,
# Number of token variables; must be last in list:
_NVARS => $i++,
};
# Array index names for $self (which is an array ref)
$i = 0;
use constant {
_rlines_ => $i++,
_rlines_new_ => $i++,
_rLL_ => $i++,
_Klimit_ => $i++,
_K_opening_container_ => $i++,
_K_closing_container_ => $i++,
_K_opening_ternary_ => $i++,
_K_closing_ternary_ => $i++,
_K_first_seq_item_ => $i++,
_rK_phantom_semicolons_ => $i++,
_rtype_count_by_seqno_ => $i++,
_ris_function_call_paren_ => $i++,
_rlec_count_by_seqno_ => $i++,
_ris_broken_container_ => $i++,
_ris_permanently_broken_ => $i++,
_rhas_list_ => $i++,
_rhas_broken_list_ => $i++,
_rhas_broken_list_with_lec_ => $i++,
_rhas_code_block_ => $i++,
_rhas_broken_code_block_ => $i++,
_rhas_ternary_ => $i++,
_ris_excluded_lp_container_ => $i++,
_rwant_reduced_ci_ => $i++,
_rno_xci_by_seqno_ => $i++,
_ris_bli_container_ => $i++,
_rparent_of_seqno_ => $i++,
_rchildren_of_seqno_ => $i++,
_ris_list_by_seqno_ => $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++,
_this_batch_ => $i++,
_last_output_short_opening_token_ => $i++,
_last_line_leading_type_ => $i++,
_last_line_leading_level_ => $i++,
_last_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_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++,
_rKrange_code_without_comments_ => $i++,
_rbreak_before_Kfirst_ => $i++,
_rbreak_after_Klast_ => $i++,
_rwant_container_open_ => $i++,
_converged_ => $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++,
_rbreak_before_container_by_seqno_ => $i++,
_ris_essential_old_breakpoint_ => $i++,
_roverride_cab3_ => $i++,
_ris_assigned_structure_ => $i++,
};
# Array index names for _this_batch_ (in above list)
# So _this_batch_ is a sub-array of $self for
# holding the batches of tokens being processed.
$i = 0;
use constant {
_starting_in_quote_ => $i++,
_ending_in_quote_ => $i++,
_is_static_block_comment_ => $i++,
_rlines_K_ => $i++,
_do_not_pad_ => $i++,
_ibeg0_ => $i++,
_peak_batch_size_ => $i++,
_max_index_to_go_ => $i++,
_rK_to_go_ => $i++,
_batch_count_ => $i++,
_rix_seqno_controlling_ci_ => $i++,
_batch_CODE_type_ => $i++,
};
# 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 => 10000;
use constant VERY_STRONG => 100;
use constant STRONG => 2.1;
use constant NOMINAL => 1.1;
use constant WEAK => 0.8;
use constant VERY_WEAK => 0.55;
# values for testing indexes in output array
use constant UNDEFINED_INDEX => -1;
# Maximum number of little messages; probably need not be changed.
use constant MAX_NAG_MESSAGES => 6;
# increment between sequence numbers for each type
# For example, ?: pairs might have numbers 7,11,15,...
use constant TYPE_SEQUENCE_INCREMENT => 4;
# Initialize constant hashes ...
my @q;
@q = qw(
= **= += *= &= <<= &&=
-= /= |= >>= ||= //=
.= %= ^=
x=
);
@is_assignment{@q} = (1) x scalar(@q);
@q = qw(
grep
keys
map
reverse
sort
split
);
@is_keyword_returning_list{@q} = (1) x scalar(@q);
@q = qw(is if unless and or err last next redo return);
@is_if_unless_and_or_last_next_redo_return{@q} = (1) x scalar(@q);
# 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);
@q = qw(if unless while until for);
@is_if_unless_while_until_for{@q} =
(1) x scalar(@q);
@q = qw(last next redo return);
@is_last_next_redo_return{@q} = (1) x scalar(@q);
@q = qw(sort map grep);
@is_sort_map_grep{@q} = (1) x scalar(@q);
@q = qw(sort map grep eval);
@is_sort_map_grep_eval{@q} = (1) x scalar(@q);
@q = qw(if unless);
@is_if_unless{@q} = (1) x scalar(@q);
@q = qw(and or err);
@is_and_or{@q} = (1) x scalar(@q);
# Identify certain operators which often occur in chains.
# Note: the minus (-) causes a side effect of padding of the first line in
# something like this (by sub set_logical_padding):
# Checkbutton => 'Transmission checked',
# -variable => \$TRANS
# This usually improves appearance so it seems ok.
@q = qw(&& || and or : ? . + - * /);
@is_chain_operator{@q} = (1) x scalar(@q);
# 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_opening_sequence_token{@q} = (1) x scalar(@q);
@q = qw< } ) ] : >;
@is_closing_sequence_token{@q} = (1) x scalar(@q);
# a hash needed by sub scan_list for labeling containers
@q = qw( k => && || ? : . );
@is_container_label_type{@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);
# 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.
@q = qw( do sub eval sort map grep );
@is_block_with_ci{@q} = (1) x scalar(@q);
}
{ ## begin closure to count instanes
# methods to count instances
my $_count = 0;
sub get_count { return $_count; }
sub _increment_count { return ++$_count }
sub _decrement_count { return --$_count }
} ## end closure to count instanes
sub new {
my ( $class, @args ) = @_;
# we are given an object with a write_line() method to take lines
my %defaults = (
sink_object => undef,
diagnostics_object => undef,
logger_object => undef,
length_function => sub { return length( $_[0] ) },
is_encoded_data => "",
fh_tee => undef,
);
my %args = ( %defaults, @args );
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_gnu_vars();
initialize_csc_vars();
initialize_scan_list();
initialize_saved_opening_indentation();
initialize_undo_ci();
initialize_process_line_of_CODE();
initialize_grind_batch_of_CODE();
initialize_adjusted_indentation();
initialize_postponed_breakpoint();
initialize_batch_variables();
initialize_forced_breakpoint_vars();
initialize_gnu_batch_vars();
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,
length_function => $length_function
);
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 = [];
# Basic data structures...
$self->[_rlines_] = []; # = ref to array of lines of the file
$self->[_rlines_new_] = []; # = ref to array of output lines
# 'rLL' = reference to the liner array of all tokens in the file.
# 'LL' stands for 'Linked List'. Using a linked list was a disaster, but
# 'LL' stuck because it is easy to type.
$self->[_rLL_] = [];
$self->[_Klimit_] = undef; # = maximum K index for rLL.
# Arrays for quickly traversing the structures
$self->[_K_opening_container_] = {};
$self->[_K_closing_container_] = {};
$self->[_K_opening_ternary_] = {};
$self->[_K_closing_ternary_] = {};
$self->[_K_first_seq_item_] = undef; # K of first token with a sequence #
# Array of phantom semicolons, in case we ever need to undo them
$self->[_rK_phantom_semicolons_] = undef;
# 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->[_rhas_list_] = {};
$self->[_rhas_broken_list_] = {};
$self->[_rhas_broken_list_with_lec_] = {};
$self->[_rhas_code_block_] = {};
$self->[_rhas_broken_code_block_] = {};
$self->[_rhas_ternary_] = {};
$self->[_ris_excluded_lp_container_] = {};
$self->[_rwant_reduced_ci_] = {};
$self->[_rno_xci_by_seqno_] = {};
$self->[_ris_bli_container_] = {};
$self->[_rparent_of_seqno_] = {};
$self->[_rchildren_of_seqno_] = {};
$self->[_ris_list_by_seqno_] = {};
$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;
# Reference to the batch being processed
$self->[_this_batch_] = [];
# Memory of processed text...
$self->[_last_last_line_leading_level_] = 0;
$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_END_or_DATA_] = 0;
# 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->[_rKrange_code_without_comments_] = [];
$self->[_rbreak_before_Kfirst_] = {};
$self->[_rbreak_after_Klast_] = {};
$self->[_rwant_container_open_] = {};
$self->[_converged_] = 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->[_rbreak_before_container_by_seqno_] = {};
$self->[_ris_essential_old_breakpoint_] = {};
$self->[_roverride_cab3_] = {};
$self->[_ris_assigned_structure_] = {};
# This flag will be updated later by a call to get_save_logfile()
$self->[_save_logfile_] = defined($logger_object);
bless $self, $class;
# Safety check..this is not a class yet
if ( _increment_count() > 1 ) {
confess
"Attempt to create more than 1 object in $class, which is not a true class yet\n";
}
return $self;
}
######################################
# CODE SECTION 2: Some Basic Utilities
######################################
{ ## 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_logger_object {
return $logger_object;
}
sub get_input_stream_name {
my $input_stream_name = "";
if ($logger_object) {
$input_stream_name = $logger_object->get_input_stream_name();
}
return $input_stream_name;
}
# interface to Perl::Tidy::Logger routines
sub warning {
my ($msg) = @_;
if ($logger_object) { $logger_object->warning($msg); }
return;
}
sub complain {
my ($msg) = @_;
if ($logger_object) {
$logger_object->complain($msg);
}
return;
}
sub write_logfile_entry {
my @msg = @_;
if ($logger_object) {
$logger_object->write_logfile_entry(@msg);
}
return;
}
sub report_definite_bug {
if ($logger_object) {
$logger_object->report_definite_bug();
}
return;
}
sub get_saw_brace_error {
if ($logger_object) {
return $logger_object->get_saw_brace_error();
}
return;
}
sub we_are_at_the_last_line {
if ($logger_object) {
$logger_object->we_are_at_the_last_line();
}
return;
}
} ## 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;
}
sub write_diagnostics {
my ($msg) = @_;
if ($diagnostics_object) {
$diagnostics_object->write_diagnostics($msg);
}
return;
}
} ## end closure for diagnostics routines
sub get_convergence_check {
my ($self) = @_;
return $self->[_converged_];
}
sub get_added_semicolon_count {
my $self = shift;
return $self->[_added_semicolon_count_];
}
sub get_output_line_number {
my ($self) = @_;
my $vao = $self->[_vertical_aligner_object_];
return $vao->get_output_line_number();
}
sub check_token_array {
my $self = shift;
# Check for errors in the array of tokens. This is only called now
# when the DEVEL_MODE flag is set, so this Fault will only occur
# during code development.
my $rLL = $self->[_rLL_];
for ( my $KK = 0 ; $KK < @{$rLL} ; $KK++ ) {
my $nvars = @{ $rLL->[$KK] };
if ( $nvars != _NVARS ) {
my $NVARS = _NVARS;
my $type = $rLL->[$KK]->[_TYPE_];
$type = '*' unless defined($type);
# 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");
}
}
}
return;
}
sub want_blank_line {
my $self = shift;
$self->flush();
my $file_writer_object = $self->[_file_writer_object_];
$file_writer_object->want_blank_line();
return;
}
sub write_unindented_line {
my ( $self, $line ) = @_;
$self->flush();
my $file_writer_object = $self->[_file_writer_object_];
$file_writer_object->write_line($line);
return;
}
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();
}
sub trim {
# trim leading and trailing whitespace from a string
my $str = shift;
$str =~ s/\s+$//;
$str =~ s/^\s+//;
return $str;
}
sub max {
my (@vals) = @_;
my $max = shift @vals;
for (@vals) { $max = $_ > $max ? $_ : $max }
return $max;
}
sub min {
my (@vals) = @_;
my $min = shift @vals;
for (@vals) { $min = $_ < $min ? $_ : $min }
return $min;
}
sub split_words {
# given a string containing words separated by whitespace,
# return the list of words
my ($str) = @_;
return unless $str;
$str =~ s/\s+$//;
$str =~ s/^\s+//;
return split( /\s+/, $str );
}
###########################################
# 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 = shift;
initialize_whitespace_hashes();
initialize_bond_strength_hashes();
# 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();
make_static_block_comment_pattern();
make_static_side_comment_pattern();
make_closing_side_comment_prefix();
make_closing_side_comment_list_pattern();
$format_skipping_pattern_begin =
make_format_skipping_pattern( 'format-skipping-begin', '#<<<' );
$format_skipping_pattern_end =
make_format_skipping_pattern( 'format-skipping-end', '#>>>' );
make_non_indenting_brace_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'} = 100000000;
}
}
make_bli_pattern();
make_block_brace_vertical_tightness_pattern();
make_blank_line_pattern();
make_keyword_group_list_pattern();
# Make initial list of desired one line block types
# They will be modified by 'prepare_cuddled_block_types'
%want_one_line_block = %is_sort_map_grep_eval;
# Default is to exclude one-line block types from -bl formatting
# FIXME: Eventually a flag should be added to modify this.
%is_braces_left_exclude_block = %is_sort_map_grep_eval;
prepare_cuddled_block_types();
if ( $rOpts->{'dump-cuddled-block-list'} ) {
dump_cuddled_block_list(*STDOUT);
Exit(0);
}
if ( $rOpts->{'line-up-parentheses'} ) {
if ( $rOpts->{'indent-only'}
|| !$rOpts->{'add-newlines'}
|| !$rOpts->{'delete-old-newlines'} )
{
Warn(<{'line-up-parentheses'} = 0;
}
if ( $rOpts->{'whitespace-cycle'} ) {
Warn(<{'whitespace-cycle'} = 0;
}
}
# At present, tabs are not compatible with the line-up-parentheses style
# (it would be possible to entab the total leading whitespace
# just prior to writing the line, if desired).
if ( $rOpts->{'line-up-parentheses'} && $rOpts->{'tabs'} ) {
Warn(<{'tabs'} = 0;
}
# Likewise, tabs are not compatible with outdenting..
if ( $rOpts->{'outdent-keywords'} && $rOpts->{'tabs'} ) {
Warn(<{'tabs'} = 0;
}
if ( $rOpts->{'outdent-labels'} && $rOpts->{'tabs'} ) {
Warn(<{'tabs'} = 0;
}
if ( !$rOpts->{'space-for-semicolon'} ) {
$want_left_space{'f'} = -1;
}
if ( $rOpts->{'space-terminal-semicolon'} ) {
$want_left_space{';'} = 1;
}
# 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(<{'outdent-keyword-list'} );
unless (@okw) {
@okw = qw(next last redo goto return); # defaults
}
# FUTURE: if not a keyword, assume that it is an identifier
foreach (@okw) {
if ( $Perl::Tidy::Tokenizer::is_keyword{$_} ) {
$outdent_keyword{$_} = 1;
}
else {
Warn("ignoring '$_' in -okwl list; not a perl keyword");
}
}
# setup hash for -kpit option
%keyword_paren_inner_tightness = ();
my $kpit_value = $rOpts->{'keyword-paren-inner-tightness'};
if ( defined($kpit_value) && $kpit_value != 1 ) {
my @kpit =
split_words( $rOpts->{'keyword-paren-inner-tightness-list'} );
unless (@kpit) {
@kpit = qw(if elsif unless while until for foreach); # defaults
}
# we will allow keywords and user-defined identifiers
foreach (@kpit) {
$keyword_paren_inner_tightness{$_} = $kpit_value;
}
}
# implement user whitespace preferences
if ( my @q = split_words( $rOpts->{'want-left-space'} ) ) {
@want_left_space{@q} = (1) x scalar(@q);
}
if ( my @q = split_words( $rOpts->{'want-right-space'} ) ) {
@want_right_space{@q} = (1) x scalar(@q);
}
if ( my @q = split_words( $rOpts->{'nowant-left-space'} ) ) {
@want_left_space{@q} = (-1) x scalar(@q);
}
if ( my @q = split_words( $rOpts->{'nowant-right-space'} ) ) {
@want_right_space{@q} = (-1) x scalar(@q);
}
if ( $rOpts->{'dump-want-left-space'} ) {
dump_want_left_space(*STDOUT);
Exit(0);
}
if ( $rOpts->{'dump-want-right-space'} ) {
dump_want_right_space(*STDOUT);
Exit(0);
}
# default keywords for which space is introduced before an opening paren
# (at present, including them messes up vertical alignment)
my @sak = qw(my local our and or xor err eq ne if else elsif until
unless while for foreach return switch case given when catch);
%space_after_keyword = map { $_ => 1 } @sak;
# first remove any or all of these if desired
if ( my @q = split_words( $rOpts->{'nospace-after-keyword'} ) ) {
# -nsak='*' selects all the above keywords
if ( @q == 1 && $q[0] eq '*' ) { @q = keys(%space_after_keyword) }
@space_after_keyword{@q} = (0) x scalar(@q);
}
# then allow user to add to these defaults
if ( my @q = split_words( $rOpts->{'space-after-keyword'} ) ) {
@space_after_keyword{@q} = (1) x scalar(@q);
}
# implement user break preferences
my $break_after = sub {
my @toks = @_;
foreach my $tok (@toks) {
if ( $tok eq '?' ) { $tok = ':' } # patch to coordinate ?/:
my $lbs = $left_bond_strength{$tok};
my $rbs = $right_bond_strength{$tok};
if ( defined($lbs) && defined($rbs) && $lbs < $rbs ) {
( $right_bond_strength{$tok}, $left_bond_strength{$tok} ) =
( $lbs, $rbs );
}
}
};
my $break_before = sub {
my @toks = @_;
foreach my $tok (@toks) {
my $lbs = $left_bond_strength{$tok};
my $rbs = $right_bond_strength{$tok};
if ( defined($lbs) && defined($rbs) && $rbs < $lbs ) {
( $right_bond_strength{$tok}, $left_bond_strength{$tok} ) =
( $lbs, $rbs );
}
}
};
$break_after->(@all_operators) if ( $rOpts->{'break-after-all-operators'} );
$break_before->(@all_operators)
if ( $rOpts->{'break-before-all-operators'} );
$break_after->( split_words( $rOpts->{'want-break-after'} ) );
$break_before->( split_words( $rOpts->{'want-break-before'} ) );
# make note if breaks are before certain key types
%want_break_before = ();
foreach my $tok ( @all_operators, ',' ) {
$want_break_before{$tok} =
$left_bond_strength{$tok} < $right_bond_strength{$tok};
}
# Coordinate ?/: breaks, which must be similar
if ( !$want_break_before{':'} ) {
$want_break_before{'?'} = $want_break_before{':'};
$right_bond_strength{'?'} = $right_bond_strength{':'} + 0.01;
$left_bond_strength{'?'} = NO_BREAK;
}
# 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;
}
%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 compatable with opt=2, silently set to opt=0
# (2) opt=0 and 2 give same result if -i=-ci; but opt=0 is faster
if ( $opt == 2 ) {
if ( $rOpts->{'line-up-parentheses'}
|| $rOpts->{'indent-columns'} ==
$rOpts->{'continuation-indentation'} )
{
$opt = 0;
}
}
$container_indentation_options{$tok} = $opt;
}
}
# Define here tokens which may follow the closing brace of a do statement
# on the same line, as in:
# } while ( $something);
my @dof = qw(until while unless if ; : );
push @dof, ',';
@is_do_follower{@dof} = (1) x scalar(@dof);
# What tokens may follow the closing brace of an if or elsif block?
# Not used. Previously used for cuddled else, but no longer needed.
%is_if_brace_follower = ();
# nothing can follow the closing curly of an else { } block:
%is_else_brace_follower = ();
# what can follow a multi-line anonymous sub definition closing curly:
my @asf = qw# ; : => or and && || ~~ !~~ ) #;
push @asf, ',';
@is_anon_sub_brace_follower{@asf} = (1) x scalar(@asf);
# what can follow a one-line anonymous sub closing curly:
# one-line anonymous subs also have ']' here...
# see tk3.t and PP.pm
my @asf1 = qw# ; : => or and && || ) ] ~~ !~~ #;
push @asf1, ',';
@is_anon_sub_1_brace_follower{@asf1} = (1) x scalar(@asf1);
# What can follow a closing curly of a block
# which is not an if/elsif/else/do/sort/map/grep/eval/sub
# Testfiles: 'Toolbar.pm', 'Menubar.pm', bless.t, '3rules.pl'
my @obf = qw# ; : => or and && || ) #;
push @obf, ',';
@is_other_brace_follower{@obf} = (1) x scalar(@obf);
$right_bond_strength{'{'} = WEAK;
$left_bond_strength{'{'} = VERY_STRONG;
# make -l=0 equal to -l=infinite
if ( !$rOpts->{'maximum-line-length'} ) {
$rOpts->{'maximum-line-length'} = 1000000;
}
# make -lbl=0 equal to -lbl=infinite
if ( !$rOpts->{'long-block-line-count'} ) {
$rOpts->{'long-block-line-count'} = 1000000;
}
my $ole = $rOpts->{'output-line-ending'};
if ($ole) {
my %endings = (
dos => "\015\012",
win => "\015\012",
mac => "\015",
unix => "\012",
);
# Patch for RT #99514, a memoization issue.
# Normally, the user enters one of 'dos', 'win', etc, and we change the
# value in the options parameter to be the corresponding line ending
# character. But, if we are using memoization, on later passes through
# here the option parameter will already have the desired ending
# character rather than the keyword 'dos', 'win', etc. So
# we must check to see if conversion has already been done and, if so,
# bypass the conversion step.
my %endings_inverted = (
"\015\012" => 'dos',
"\015\012" => 'win',
"\015" => 'mac',
"\012" => 'unix',
);
if ( defined( $endings_inverted{$ole} ) ) {
# we already have valid line ending, nothing more to do
}
else {
$ole = lc $ole;
unless ( $rOpts->{'output-line-ending'} = $endings{$ole} ) {
my $str = join " ", keys %endings;
Die(<{'preserve-line-endings'} ) {
Warn("Ignoring -ple; conflicts with -ole\n");
$rOpts->{'preserve-line-endings'} = undef;
}
}
}
# hashes used to simplify setting whitespace
%tightness = (
'{' => $rOpts->{'brace-tightness'},
'}' => $rOpts->{'brace-tightness'},
'(' => $rOpts->{'paren-tightness'},
')' => $rOpts->{'paren-tightness'},
'[' => $rOpts->{'square-bracket-tightness'},
']' => $rOpts->{'square-bracket-tightness'},
);
%matching_token = (
'{' => '}',
'(' => ')',
'[' => ']',
'?' => ':',
);
# note any requested old line breaks to keep
%keep_break_before_type = ();
%keep_break_after_type = ();
if ( !$rOpts->{'ignore-old-breakpoints'} ) {
# FIXME: could check for valid types here.
# Invalid types are harmless but probably not intended.
my @types;
@types = ( split_words( $rOpts->{'keep-old-breakpoints-before'} ) );
@keep_break_before_type{@types} = (1) x scalar(@types);
@types = ( split_words( $rOpts->{'keep-old-breakpoints-after'} ) );
@keep_break_after_type{@types} = (1) x scalar(@types);
}
else {
if ( $rOpts->{'break-at-old-method-breakpoints'} ) {
Warn("Conflicting parameters: -iob and -bom; -bom will be ignored\n"
);
$rOpts->{'break-at-old-method-breakpoints'} = 0;
}
if ( $rOpts->{'break-at-old-comma-breakpoints'} ) {
Warn("Conflicting parameters: -iob and -boc; -boc will be ignored\n"
);
$rOpts->{'break-at-old-comma-breakpoints'} = 0;
}
if ( $rOpts->{'break-at-old-semicolon-breakpoints'} ) {
Warn("Conflicting parameters: -iob and -bos; -bos will be ignored\n"
);
$rOpts->{'break-at-old-semicolon-breakpoints'} = 0;
}
if ( $rOpts->{'keep-old-breakpoints-before'} ) {
Warn("Conflicting parameters: -iob and -kbb; -kbb will be ignored\n"
);
$rOpts->{'keep-old-breakpoints-before'} = "";
}
if ( $rOpts->{'keep-old-breakpoints-after'} ) {
Warn("Conflicting parameters: -iob and -kba; -kba will be ignored\n"
);
$rOpts->{'keep-old-breakpoints-after'} = "";
}
# 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;
}
#############################################################
# Make global vars for frequently used options for efficiency
#############################################################
$rOpts_closing_side_comment_maximum_text =
$rOpts->{'closing-side-comment-maximum-text'};
$rOpts_continuation_indentation = $rOpts->{'continuation-indentation'};
$rOpts_indent_columns = $rOpts->{'indent-columns'};
$rOpts_line_up_parentheses = $rOpts->{'line-up-parentheses'};
$rOpts_maximum_line_length = $rOpts->{'maximum-line-length'};
$rOpts_variable_maximum_line_length =
$rOpts->{'variable-maximum-line-length'};
$rOpts_block_brace_tightness = $rOpts->{'block-brace-tightness'};
$rOpts_block_brace_vertical_tightness =
$rOpts->{'block-brace-vertical-tightness'};
$rOpts_stack_closing_block_brace = $rOpts->{'stack-closing-block-brace'};
$rOpts_maximum_consecutive_blank_lines =
$rOpts->{'maximum-consecutive-blank-lines'};
$rOpts_recombine = $rOpts->{'recombine'};
$rOpts_add_newlines = $rOpts->{'add-newlines'};
$rOpts_break_at_old_comma_breakpoints =
$rOpts->{'break-at-old-comma-breakpoints'};
$rOpts_ignore_old_breakpoints = $rOpts->{'ignore-old-breakpoints'};
$rOpts_keep_interior_semicolons = $rOpts->{'keep-interior-semicolons'};
$rOpts_comma_arrow_breakpoints = $rOpts->{'comma-arrow-breakpoints'};
$rOpts_maximum_fields_per_table = $rOpts->{'maximum-fields-per-table'};
$rOpts_one_line_block_semicolons = $rOpts->{'one-line-block-semicolons'};
$rOpts_break_at_old_semicolon_breakpoints =
$rOpts->{'break-at-old-semicolon-breakpoints'};
$rOpts_tee_side_comments = $rOpts->{'tee-side-comments'};
$rOpts_tee_block_comments = $rOpts->{'tee-block-comments'};
$rOpts_tee_pod = $rOpts->{'tee-pod'};
$rOpts_delete_side_comments = $rOpts->{'delete-side-comments'};
$rOpts_delete_closing_side_comments =
$rOpts->{'delete-closing-side-comments'};
$rOpts_format_skipping = $rOpts->{'format-skipping'};
$rOpts_indent_only = $rOpts->{'indent-only'};
$rOpts_static_block_comments = $rOpts->{'static-block-comments'};
$rOpts_add_whitespace = $rOpts->{'add-whitespace'};
$rOpts_delete_old_whitespace = $rOpts->{'delete-old-whitespace'};
$rOpts_freeze_whitespace = $rOpts->{'freeze-whitespace'};
$rOpts_function_paren_vertical_alignment =
$rOpts->{'function-paren-vertical-alignment'};
$rOpts_ignore_side_comment_lengths =
$rOpts->{'ignore-side-comment-lengths'};
$rOpts_break_at_old_attribute_breakpoints =
$rOpts->{'break-at-old-attribute-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_ternary_breakpoints =
$rOpts->{'break-at-old-ternary-breakpoints'};
$rOpts_short_concatenation_item_length =
$rOpts->{'short-concatenation-item-length'};
$rOpts_closing_side_comment_else_flag =
$rOpts->{'closing-side-comment-else-flag'};
$rOpts_fuzzy_line_length = $rOpts->{'fuzzy-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'},
);
# 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.
my $level_max = 1000;
# The basic scheme:
foreach my $level ( 0 .. $level_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_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_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;
}
}
initialize_weld_nested_exclusion_rules($rOpts);
initialize_line_up_parentheses_exclusion_rules($rOpts);
return;
}
sub initialize_weld_nested_exclusion_rules {
my ($rOpts) = @_;
%weld_nested_exclusion_rules = ();
my $opt_name = 'weld-nested-exclusion-list';
my $str = $rOpts->{$opt_name};
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(<{$opt_name};
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)?$/ ) {
$flag1 = $1 if $1;
$key = $2 if $2;
$flag2 = $3 if $3;
}
else {
$msg1 .= " '$item_save'";
next;
}
if ( !defined($key) ) {
$msg1 .= " '$item_save'";
next;
}
# Check for valid flag1
if ( !defined($flag1) ) { $flag1 = '*' }
elsif ( $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 }
elsif ( $flag2 !~ /^[012]$/ ) {
$msg1 .= " '$item_save'";
next;
}
if ( !defined( $line_up_parentheses_exclusion_rules{$key} ) ) {
$line_up_parentheses_exclusion_rules{$key} = [ $flag1, $flag2 ];
next;
}
# check for multiple conflicting specifications
my $rflags = $line_up_parentheses_exclusion_rules{$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(<' is excluded because it never gets space
# parentheses and brackets are excluded since they are handled specially
# curly braces are included but may be overridden by logic, such as
# newline logic.
# NEW_TOKENS: create a whitespace rule here. This can be as
# simple as adding your new letter to @spaces_both_sides, for
# example.
my @opening_type = qw< L { ( [ >;
@is_opening_type{@opening_type} = (1) x scalar(@opening_type);
my @closing_type = qw< R } ) ] >;
@is_closing_type{@closing_type} = (1) x scalar(@closing_type);
my @spaces_both_sides = qw#
+ - * / % ? = . : x < > | & ^ .. << >> ** && .. || // => += -=
.= %= x= &= |= ^= *= <> <= >= == =~ !~ /= != ... <<= >>= ~~ !~~
&&= ||= //= <=> A k f w F n C Y U G v
#;
my @spaces_left_side = qw<
t ! ~ m p { \ h pp mm Z j
>;
push( @spaces_left_side, '#' ); # avoids warning message
my @spaces_right_side = qw<
; } ) ] R J ++ -- **=
>;
push( @spaces_right_side, ',' ); # avoids warning message
%want_left_space = ();
%want_right_space = ();
%binary_ws_rules = ();
# Note that we setting defaults here. Later in processing
# the values of %want_left_space and %want_right_space
# may be overridden by any user settings specified by the
# -wls and -wrs parameters. However the binary_whitespace_rules
# are hardwired and have priority.
@want_left_space{@spaces_both_sides} =
(1) x scalar(@spaces_both_sides);
@want_right_space{@spaces_both_sides} =
(1) x scalar(@spaces_both_sides);
@want_left_space{@spaces_left_side} =
(1) x scalar(@spaces_left_side);
@want_right_space{@spaces_left_side} =
(-1) x scalar(@spaces_left_side);
@want_left_space{@spaces_right_side} =
(-1) x scalar(@spaces_right_side);
@want_right_space{@spaces_right_side} =
(1) x scalar(@spaces_right_side);
$want_left_space{'->'} = WS_NO;
$want_right_space{'->'} = WS_NO;
$want_left_space{'**'} = WS_NO;
$want_right_space{'**'} = WS_NO;
$want_right_space{'CORE::'} = WS_NO;
# These binary_ws_rules are hardwired and have priority over the above
# settings. It would be nice to allow adjustment by the user,
# but it would be complicated to specify.
#
# hash type information must stay tightly bound
# as in : ${xxxx}
$binary_ws_rules{'i'}{'L'} = WS_NO;
$binary_ws_rules{'i'}{'{'} = WS_YES;
$binary_ws_rules{'k'}{'{'} = WS_YES;
$binary_ws_rules{'U'}{'{'} = WS_YES;
$binary_ws_rules{'i'}{'['} = WS_NO;
$binary_ws_rules{'R'}{'L'} = WS_NO;
$binary_ws_rules{'R'}{'{'} = WS_NO;
$binary_ws_rules{'t'}{'L'} = WS_NO;
$binary_ws_rules{'t'}{'{'} = WS_NO;
$binary_ws_rules{'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;
return;
} ## end initialize_whitespace_hashes
sub set_whitespace_flags {
# 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 white space is needed.
#
# $rwhitespace_flags->[$j] is a flag indicating whether a white space
# BEFORE token $j is needed, with the following values:
#
# WS_NO = -1 do not want a space BEFORE token $j
# WS_OPTIONAL= 0 optional space or $j is a whitespace
# WS_YES = 1 want a space BEFORE token $j
#
my $self = shift;
my $rLL = $self->[_rLL_];
use constant DEBUG_WHITE => 0;
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 = {};
my %is_for_foreach = ( 'for' => 1, 'foreach' => 1 );
my ( $token, $type, $block_type, $seqno, $input_line_no );
my (
$last_token, $last_type, $last_block_type,
$last_seqno, $last_input_line_no
);
my $j_tight_closing_paren = -1;
$token = ' ';
$type = 'b';
$block_type = '';
$seqno = '';
$input_line_no = 0;
$last_token = ' ';
$last_type = 'b';
$last_block_type = '';
$last_seqno = '';
$last_input_line_no = 0;
my $jmax = @{$rLL} - 1;
my ($ws);
# This is some logic moved to a sub to avoid deep nesting of if stmts
my $ws_in_container = sub {
my ($j) = @_;
my $ws = WS_YES;
if ( $j + 1 > $jmax ) { return (WS_NO) }
# Patch to count '-foo' as single token so that
# each of $a{-foo} and $a{foo} and $a{'foo'} do
# not get spaces with default formatting.
my $j_here = $j;
++$j_here
if ( $token eq '-'
&& $last_token eq '{'
&& $rLL->[ $j + 1 ]->[_TYPE_] eq 'w' );
# Patch to 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 < $jmax + 1
&& $rLL->[ $j + 1 ]->[_TYPE_] eq 'b'
&& $rLL->[ $j + 2 ]->[_TYPE_] eq 'n'
&& $rLL->[ $j + 2 ]->[_TOKEN_] =~ /^\d/ )
{
$j_here = $j + 2;
}
# $j_next is where a closing token should be if
# the container has a single token
if ( $j_here + 1 > $jmax ) { return (WS_NO) }
my $j_next =
( $rLL->[ $j_here + 1 ]->[_TYPE_] eq 'b' )
? $j_here + 2
: $j_here + 1;
if ( $j_next > $jmax ) { return WS_NO }
my $tok_next = $rLL->[$j_next]->[_TOKEN_];
my $type_next = $rLL->[$j_next]->[_TYPE_];
# for tightness = 1, if there is just one token
# within the matching pair, we will keep it tight
if (
$tok_next eq $matching_token{$last_token}
# but watch out for this: [ [ ] (misc.t)
&& $last_token ne $token
# double diamond is usually spaced
&& $token ne '<<>>'
)
{
# remember where to put the space for the closing paren
$j_tight_closing_paren = $j_next;
return (WS_NO);
}
return (WS_YES);
};
# Local hashes to set spaces around container tokens according to their
# sequence numbers. These are set as keywords are examined.
# They are controlled by the -kpit and -kpitl flags.
my %opening_container_inside_ws;
my %closing_container_inside_ws;
my $set_container_ws_by_keyword = sub {
return unless (%keyword_paren_inner_tightness);
my ( $word, $sequence_number ) = @_;
# We just saw a keyword (or other function name) followed by an opening
# paren. Now check to see if the following paren should have special
# treatment for its inside space. If so we set a hash value using the
# sequence number as key.
if ( $word && $sequence_number ) {
my $tightness = $keyword_paren_inner_tightness{$word};
if ( defined($tightness) && $tightness != 1 ) {
my $ws_flag = $tightness == 0 ? WS_YES : WS_NO;
$opening_container_inside_ws{$sequence_number} = $ws_flag;
$closing_container_inside_ws{$sequence_number} = $ws_flag;
}
}
};
my $ws_opening_container_override = sub {
my ( $ws, $sequence_number ) = @_;
return $ws unless (%opening_container_inside_ws);
if ($sequence_number) {
my $ws_override = $opening_container_inside_ws{$sequence_number};
if ($ws_override) { $ws = $ws_override }
}
return $ws;
};
my $ws_closing_container_override = sub {
my ( $ws, $sequence_number ) = @_;
return $ws unless (%closing_container_inside_ws);
if ($sequence_number) {
my $ws_override = $closing_container_inside_ws{$sequence_number};
if ($ws_override) { $ws = $ws_override }
}
return $ws;
};
# main loop over all tokens to define the whitespace flags
for ( my $j = 0 ; $j <= $jmax ; $j++ ) {
my $rtokh = $rLL->[$j];
# Set a default
$rwhitespace_flags->[$j] = WS_OPTIONAL;
if ( $rtokh->[_TYPE_] eq 'b' ) {
next;
}
# set a default value, to be changed as needed
$ws = undef;
$last_token = $token;
$last_type = $type;
$last_block_type = $block_type;
$last_seqno = $seqno;
$last_input_line_no = $input_line_no;
$token = $rtokh->[_TOKEN_];
$type = $rtokh->[_TYPE_];
$block_type = $rtokh->[_BLOCK_TYPE_];
$seqno = $rtokh->[_TYPE_SEQUENCE_];
$input_line_no = $rtokh->[_LINE_INDEX_];
#---------------------------------------------------------------
# Whitespace Rules Section 1:
# Handle space on the inside of opening braces.
#---------------------------------------------------------------
# /^[L\{\(\[]$/
if ( $is_opening_type{$last_type} ) {
$j_tight_closing_paren = -1;
# let us keep empty matched braces together: () {} []
# except for BLOCKS
if ( $token eq $matching_token{$last_token} ) {
if ($block_type) {
$ws = WS_YES;
}
else {
$ws = WS_NO;
}
}
else {
# we're considering the right of an opening brace
# tightness = 0 means always pad inside with space
# tightness = 1 means pad inside if "complex"
# tightness = 2 means never pad inside with space
my $tightness;
if ( $last_type eq '{'
&& $last_token eq '{'
&& $last_block_type )
{
$tightness = $rOpts_block_brace_tightness;
}
else { $tightness = $tightness{$last_token} }
#=============================================================
# Patch for test problem <>
# We must always avoid spaces around a bare word beginning
# with ^ as in:
# my $before = ${^PREMATCH};
# Because all of the following cause an error in perl:
# my $before = ${ ^PREMATCH };
# my $before = ${ ^PREMATCH};
# my $before = ${^PREMATCH };
# So if brace tightness flag is -bt=0 we must temporarily reset
# to bt=1. Note that here we must set tightness=1 and not 2 so
# that the closing space
# is also avoided (via the $j_tight_closing_paren flag in coding)
if ( $type eq 'w' && $token =~ /^\^/ ) { $tightness = 1 }
#=============================================================
if ( $tightness <= 0 ) {
$ws = WS_YES;
}
elsif ( $tightness > 1 ) {
$ws = WS_NO;
}
else {
$ws = $ws_in_container->($j);
}
}
# check for special cases which override the above rules
$ws = $ws_opening_container_override->( $ws, $last_seqno );
} # end setting space flag inside opening tokens
my $ws_1;
$ws_1 = $ws
if DEBUG_WHITE;
#---------------------------------------------------------------
# Whitespace Rules Section 2:
# Handle space on inside of closing brace pairs.
#---------------------------------------------------------------
# /[\}\)\]R]/
if ( $is_closing_type{$type} ) {
if ( $j == $j_tight_closing_paren ) {
$j_tight_closing_paren = -1;
$ws = WS_NO;
}
else {
if ( !defined($ws) ) {
my $tightness;
if ( $type eq '}' && $token eq '}' && $block_type ) {
$tightness = $rOpts_block_brace_tightness;
}
else { $tightness = $tightness{$token} }
$ws = ( $tightness > 1 ) ? WS_NO : WS_YES;
}
}
# check for special cases which override the above rules
$ws = $ws_closing_container_override->( $ws, $seqno );
} # end setting space flag inside closing tokens
my $ws_2;
$ws_2 = $ws
if DEBUG_WHITE;
#---------------------------------------------------------------
# Whitespace Rules Section 3:
# Use the binary rule table.
#---------------------------------------------------------------
if ( !defined($ws) ) {
$ws = $binary_ws_rules{$last_type}{$type};
}
my $ws_3;
$ws_3 = $ws
if DEBUG_WHITE;
#---------------------------------------------------------------
# Whitespace Rules Section 4:
# Handle some special cases.
#---------------------------------------------------------------
if ( $token eq '(' ) {
# This will have to be tweaked as tokenization changes.
# We usually want a space at '} (', for example:
# <>
# 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' ) {
$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.
elsif (( $last_type =~ /^[wCUG]$/ )
|| ( $last_type =~ /^[wi]$/ && $last_token =~ /^([\&]|->)/ ) )
{
$ws = $rOpts_space_function_paren ? WS_YES : WS_NO;
$set_container_ws_by_keyword->( $last_token, $seqno );
$ris_function_call_paren->{$seqno} = 1;
}
# space between something like $i and ( in <>
# for $i ( 0 .. 20 ) {
# FIXME: eventually, type 'i' could be split into multiple
# token types so this can be a hardwired rule.
elsif ( $last_type eq 'i' && $last_token =~ /^[\$\%\@]/ ) {
$ws = WS_YES;
}
# allow constant function followed by '()' to retain no space
elsif ($last_type eq 'C'
&& $rLL->[ $j + 1 ]->[_TOKEN_] eq ')' )
{
$ws = WS_NO;
}
}
# patch for SWITCH/CASE: make space at ']{' optional
# since the '{' might begin a case or when block
elsif ( ( $token eq '{' && $type ne 'L' ) && $last_token eq ']' ) {
$ws = WS_OPTIONAL;
}
# keep space between 'sub' and '{' for anonymous sub definition
if ( $type eq '{' ) {
if ( $last_token eq 'sub' ) {
$ws = WS_YES;
}
# this is needed to avoid no space in '){'
if ( $last_token eq ')' && $token eq '{' ) { $ws = WS_YES }
# avoid any space before the brace or bracket in something like
# @opts{'a','b',...}
if ( $last_type eq 'i' && $last_token =~ /^\@/ ) {
$ws = WS_NO;
}
}
elsif ( $type eq 'i' ) {
# never a space before ->
if ( substr( $token, 0, 2 ) eq '->' ) {
$ws = WS_NO;
}
}
# retain any space between '-' and bare word
elsif ( $type eq 'w' || $type eq 'C' ) {
$ws = WS_OPTIONAL if $last_type eq '-';
# never a space before ->
if ( substr( $token, 0, 2 ) eq '->' ) {
$ws = WS_NO;
}
}
# 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' );
}
# always space before side comment
elsif ( $type eq '#' ) { $ws = WS_YES if $j > 0 }
# always preserver whatever space was used after a possible
# filehandle (except _) or here doc operator
if (
$type ne '#'
&& ( ( $last_type eq 'Z' && $last_token ne '_' )
|| $last_type eq 'h' )
)
{
$ws = WS_OPTIONAL;
}
# space_backslash_quote; RT #123774 <>
# allow a space between a backslash and single or double quote
# to avoid fooling html formatters
elsif ( $last_type eq '\\' && $type eq 'Q' && $token =~ /^[\"\']/ ) {
if ($rOpts_space_backslash_quote) {
if ( $rOpts_space_backslash_quote == 1 ) {
$ws = WS_OPTIONAL;
}
elsif ( $rOpts_space_backslash_quote == 2 ) { $ws = WS_YES }
else { } # shouldnt happen
}
else {
$ws = WS_NO;
}
}
elsif ( $type eq 'k' ) {
# Keywords 'for', 'foreach' are special cases for -kpit since the
# opening paren does not always immediately follow the keyword. So
# we have to search forward for the paren in this case. I have
# limited the search to 10 tokens ahead, just in case somebody
# has a big file and no opening paren. This should be enough for
# all normal code.
if ( $is_for_foreach{$token}
&& %keyword_paren_inner_tightness
&& defined( $keyword_paren_inner_tightness{$token} )
&& $j < $jmax )
{
my $jp = $j;
for ( my $inc = 1 ; $inc < 10 ; $inc++ ) {
$jp++;
last if ( $jp > $jmax );
next unless ( $rLL->[$jp]->[_TOKEN_] eq '(' );
my $seqno = $rLL->[$jp]->[_TYPE_SEQUENCE_];
$set_container_ws_by_keyword->( $token, $seqno );
last;
}
}
}
my $ws_4;
$ws_4 = $ws
if 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
if ( !defined($ws) ) {
my $wl = $want_left_space{$type};
my $wr = $want_right_space{$last_type};
if ( !defined($wl) ) { $wl = 0 }
if ( !defined($wr) ) { $wr = 0 }
$ws = ( ( $wl == $wr ) || ( $wl == -1 ) || !$wr ) ? $wl : $wr;
}
if ( !defined($ws) ) {
$ws = 0;
write_diagnostics(
"WS flag is undefined for tokens $last_token $token\n");
}
# Treat newline as a whitespace. Otherwise, we might combine
# 'Send' and '-recipients' here according to the above rules:
# <>
# my $msg = new Fax::Send
# -recipients => $to,
# -data => $data;
if ( $ws == 0 && $input_line_no != $last_input_line_no ) { $ws = 1 }
$rwhitespace_flags->[$j] = $ws;
DEBUG_WHITE && do {
my $str = substr( $last_token, 0, 15 );
$str .= ' ' x ( 16 - length($str) );
if ( !defined($ws_1) ) { $ws_1 = "*" }
if ( !defined($ws_2) ) { $ws_2 = "*" }
if ( !defined($ws_3) ) { $ws_3 = "*" }
if ( !defined($ws_4) ) { $ws_4 = "*" }
print STDOUT
"NEW WHITE: i=$j $str $last_type $type $ws_1 : $ws_2 : $ws_3 : $ws_4 : $ws \n";
};
} ## end main loop
if ( $rOpts->{'tight-secret-operators'} ) {
new_secret_operator_whitespace( $rLL, $rwhitespace_flags );
}
$self->[_ris_function_call_paren_] = $ris_function_call_paren;
return $rwhitespace_flags;
} ## end sub set_whitespace_flags
sub dump_want_left_space {
my $fh = shift;
local $" = "\n";
$fh->print(<print("$key\t$want_left_space{$key}\n");
}
return;
}
sub dump_want_right_space {
my $fh = shift;
local $" = "\n";
$fh->print(<print("$key\t$want_right_space{$key}\n");
}
return;
}
{ ## begin closure is_essential_whitespace
my %is_sort_grep_map;
my %is_for_foreach;
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;
BEGIN {
my @q;
@q = qw(sort grep map);
@is_sort_grep_map{@q} = (1) x scalar(@q);
@q = qw(for foreach);
@is_for_foreach{@q} = (1) x scalar(@q);
@q = qw(
.. :: << >> ** && .. || // -> => += -= .= %= &= |= ^= *= <>
<= >= == =~ !~ != ++ -- /= x= ~~ ~. |. &. ^.
);
@is_digraph{@q} = (1) x scalar(@q);
@q = qw( ... **= <<= >>= &&= ||= //= <=> !~~ &.= |.= ^.= <<~);
@is_trigraph{@q} = (1) x scalar(@q);
# 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);
}
sub is_essential_whitespace {
# Essential whitespace means whitespace which cannot be safely deleted
# without risking the introduction of a syntax error.
# We are given three tokens and their types:
# ($tokenl, $typel) is the token to the left of the space in question
# ($tokenr, $typer) is the token to the right of the space in question
# ($tokenll, $typell) is previous nonblank token to the left of $tokenl
#
# 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 run a large number of files with the -mangle option and check for
# differences.
my ( $tokenll, $typell, $tokenl, $typel, $tokenr, $typer ) = @_;
# This is potentially a very slow routine but the following quick
# filters typically catch and handle over 90% of the calls.
# 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 delmiter and spacing was used if guessing was needed.
if ( $typer eq '#' ) {
return 1
if ( $tokenl
&& ( $typel eq '?' || substr( $tokenl, -1 ) eq '$' ) );
return;
}
my $tokenr_is_bareword = $tokenr =~ /^\w/ && $tokenr !~ /^\d/;
my $tokenr_is_open_paren = $tokenr eq '(';
my $token_joined = $tokenl . $tokenr;
my $tokenl_is_dash = $tokenl eq '-';
my $result =
# never combine two bare words or numbers
# examples: and ::ok(1)
# return ::spw(...)
# for bla::bla:: abc
# example is "%overload:: and" in files Dumpvalue.pm or colonbug.pl
# $input eq"quit" to make $inputeq"quit"
# my $size=-s::SINK if $file; <==OK but we won't do it
# don't join something like: for bla::bla:: abc
# example is "%overload:: and" in files Dumpvalue.pm or colonbug.pl
( ( $tokenl =~ /([\'\w]|\:\:)$/ && $typel ne 'CORE::' )
&& ( $tokenr =~ /^([\'\w]|\:\:)/ ) )
# do not combine a number with a concatenation dot
# example: pom.caputo:
# $vt100_compatible ? "\e[0;0H" : ('-' x 78 . "\n");
|| $typel eq 'n' && $tokenr eq '.'
|| $typer eq 'n'
&& $tokenl eq '.'
# cases of a space before a bareword...
|| (
$tokenr_is_bareword && (
# do not join a minus with a bare word, because you might form
# a file test operator. Example from Complex.pm:
# if (CORE::abs($z - i) < $eps);
# "z-i" would be taken as a file test.
$tokenl_is_dash && length($tokenr) == 1
# and something like this could become ambiguous without space
# after the '-':
# use constant III=>1;
# $a = $b - III;
# and even this:
# $a = - III;
|| $tokenl_is_dash && $typer =~ /^[wC]$/
# keep 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' && $tokenl =~ /\$$/
# don't combine $$ or $# with any alphanumeric
# (testfile mangle.t with --mangle)
|| $tokenl =~ /^\$[\$\#]$/
)
) ## end $tokenr_is_bareword
# OLD, not used
# '= -' should not become =- or you will get a warning
# about reversed -=
# || ($tokenr eq '-')
# do not join a bare word with a minus, like between 'Send' and
# '-recipients' here <>
# 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 <<
|| $tokenr =~ /^\<\ [qw#= ( ) =#], #=( )=
'Venus1' => [qw#0 +#], # 0+
'Venus2' => [qw#+ 0#], # +0
'Enterprise' => [qw#) x ! !#], # ()x!!
'Kite1' => [qw#~ ~ <>#], # ~~<>
'Kite2' => [qw#~~ <>#], # ~~<>
'Winking Fat Comma' => [ ( ',', '=>' ) ], # ,=>
'Bang bang ' => [qw#! !#], # !!
);
# The following operators and constants are not included because they
# are normally kept tight by perltidy:
# ~~ <~>
#
# Make a lookup table indexed by the first token of each operator:
# first token => [list, list, ...]
foreach my $value ( values(%secret_operators) ) {
my $tok = $value->[0];
push @{ $is_leading_secret_token{$tok} }, $value;
}
}
sub new_secret_operator_whitespace {
my ( $rlong_array, $rwhitespace_flags ) = @_;
# Loop over all tokens in this line
my ( $token, $type );
my $jmax = @{$rlong_array} - 1;
foreach my $j ( 0 .. $jmax ) {
$token = $rlong_array->[$j]->[_TOKEN_];
$type = $rlong_array->[$j]->[_TYPE_];
# Skip unless this token might start a secret operator
next if ( $type eq 'b' );
next unless ( $is_leading_secret_token{$token} );
# Loop over all secret operators with this leading token
foreach my $rpattern ( @{ $is_leading_secret_token{$token} } ) {
my $jend = $j - 1;
foreach my $tok ( @{$rpattern} ) {
$jend++;
$jend++
if ( $jend <= $jmax
&& $rlong_array->[$jend]->[_TYPE_] eq 'b' );
if ( $jend > $jmax
|| $tok ne $rlong_array->[$jend]->[_TOKEN_] )
{
$jend = undef;
last;
}
}
if ($jend) {
# set flags to prevent spaces within this operator
foreach my $jj ( $j + 1 .. $jend ) {
$rwhitespace_flags->[$jj] = WS_NO;
}
$j = $jend;
last;
}
} ## End Loop over all operators
} ## End loop over all tokens
return;
} # End sub
} ## 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.
my %is_good_keyword_breakpoint;
my %is_lt_gt_le_ge;
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(lt gt le ge);
@is_lt_gt_le_ge{@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 exponentation
@q = qw# ** .. ... <=> #;
@left_bond_strength{@q} = (STRONG) x scalar(@q);
@right_bond_strength{@q} = (STRONG) x scalar(@q);
# The comma-arrow has very low precedence but not a good break point
$left_bond_strength{'=>'} = NO_BREAK;
$right_bond_strength{'=>'} = NOMINAL;
# ok to break after label
$left_bond_strength{'J'} = NO_BREAK;
$right_bond_strength{'J'} = NOMINAL;
$left_bond_strength{'j'} = STRONG;
$right_bond_strength{'j'} = STRONG;
$left_bond_strength{'A'} = STRONG;
$right_bond_strength{'A'} = STRONG;
$left_bond_strength{'->'} = STRONG;
$right_bond_strength{'->'} = VERY_STRONG;
$left_bond_strength{'CORE::'} = NOMINAL;
$right_bond_strength{'CORE::'} = NO_BREAK;
# breaking AFTER modulus operator is ok:
@q = qw< % >;
@left_bond_strength{@q} = (STRONG) x scalar(@q);
@right_bond_strength{@q} =
( 0.1 * NOMINAL + 0.9 * STRONG ) x scalar(@q);
# Break AFTER math operators * and /
@q = qw< * / x >;
@left_bond_strength{@q} = (STRONG) x scalar(@q);
@right_bond_strength{@q} = (NOMINAL) x scalar(@q);
# Break AFTER weakest math operators + and -
# Make them weaker than * but a bit stronger than '.'
@q = qw< + - >;
@left_bond_strength{@q} = (STRONG) x scalar(@q);
@right_bond_strength{@q} =
( 0.91 * NOMINAL + 0.09 * WEAK ) x scalar(@q);
# 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;
$left_bond_strength{';'} = VERY_STRONG;
$right_bond_strength{';'} = VERY_WEAK;
$left_bond_strength{'f'} = VERY_STRONG;
# make right strength of for ';' a little less than '='
# to make for contents break after the ';' to avoid this:
# for ( $j = $number_of_fields - 1 ; $j < $item_count ; $j +=
# $number_of_fields )
# and make it weaker than ',' and 'and' too
$right_bond_strength{'f'} = VERY_WEAK - 0.03;
# The strengths of ?/: should be somewhere between
# an '=' and a quote (NOMINAL),
# make strength of ':' slightly less than '?' to help
# break long chains of ? : after the colons
$left_bond_strength{':'} = 0.4 * WEAK + 0.6 * NOMINAL;
$right_bond_strength{':'} = NO_BREAK;
$left_bond_strength{'?'} = $left_bond_strength{':'} + 0.01;
$right_bond_strength{'?'} = NO_BREAK;
$left_bond_strength{','} = VERY_STRONG;
$right_bond_strength{','} = VERY_WEAK;
# remaining digraphs and trigraphs not defined above
@q = qw( :: <> ++ --);
@left_bond_strength{@q} = (WEAK) x scalar(@q);
@right_bond_strength{@q} = (STRONG) x scalar(@q);
# Set bond strengths of certain keywords
# make 'or', 'err', 'and' slightly weaker than a ','
$left_bond_strength{'and'} = VERY_WEAK - 0.01;
$left_bond_strength{'or'} = VERY_WEAK - 0.02;
$left_bond_strength{'err'} = VERY_WEAK - 0.02;
$left_bond_strength{'xor'} = VERY_WEAK - 0.01;
$right_bond_strength{'and'} = NOMINAL;
$right_bond_strength{'or'} = NOMINAL;
$right_bond_strength{'err'} = NOMINAL;
$right_bond_strength{'xor'} = NOMINAL;
#---------------------------------------------------------------
# Bond Strength BEGIN Section 2.
# Set binary rules for bond strengths between certain token types.
#---------------------------------------------------------------
# We have a little problem making tables which apply to the
# container tokens. Here is a list of container tokens and
# their types:
#
# type tokens // meaning
# { {, [, ( // indent
# } }, ], ) // outdent
# [ [ // left non-structural [ (enclosing an array index)
# ] ] // right non-structural square bracket
# ( ( // left non-structural paren
# ) ) // right non-structural paren
# L { // left non-structural curly brace (enclosing a key)
# R } // right non-structural curly brace
#
# Some rules apply to token types and some to just the token
# itself. We solve the problem by combining type and token into a
# new hash key for the container types.
#
# If a rule applies to a token 'type' then we need to make rules
# for each of these 'type.token' combinations:
# Type Type.Token
# { {{, {[, {(
# [ [[
# ( ((
# L L{
# } }}, }], })
# ] ]]
# ) ))
# R R}
#
# If a rule applies to a token then we need to make rules for
# these 'type.token' combinations:
# Token Type.Token
# { {{, L{
# [ {[, [[
# ( {(, ((
# } }}, R}
# ] }], ]]
# ) }), ))
# allow long lines before final { in an if statement, as in:
# if (..........
# ..........)
# {
#
# Otherwise, the line before the { tends to be too short.
$binary_bond_strength{'))'}{'{{'} = VERY_WEAK + 0.03;
$binary_bond_strength{'(('}{'{{'} = NOMINAL;
# break on something like '} (', but keep this stronger than a ','
# example is in 'howe.pl'
$binary_bond_strength{'R}'}{'(('} = 0.8 * VERY_WEAK + 0.2 * WEAK;
$binary_bond_strength{'}}'}{'(('} = 0.8 * VERY_WEAK + 0.2 * WEAK;
# keep matrix and hash indices together
# but make them a little below STRONG to allow breaking open
# something like {'some-word'}{'some-very-long-word'} at the }{
# (bracebrk.t)
$binary_bond_strength{']]'}{'[['} = 0.9 * STRONG + 0.1 * NOMINAL;
$binary_bond_strength{']]'}{'L{'} = 0.9 * STRONG + 0.1 * NOMINAL;
$binary_bond_strength{'R}'}{'[['} = 0.9 * STRONG + 0.1 * NOMINAL;
$binary_bond_strength{'R}'}{'L{'} = 0.9 * STRONG + 0.1 * NOMINAL;
# increase strength to the point where a break in the following
# will be after the opening paren rather than at the arrow:
# $a->$b($c);
$binary_bond_strength{'i'}{'->'} = 1.45 * STRONG;
# Note that the following alternative strength would make the break at the
# '->' rather than opening the '('. Both have advantages and disadvantages.
# $binary_bond_strength{'i'}{'->'} = 0.5*STRONG + 0.5 * NOMINAL; #
$binary_bond_strength{'))'}{'->'} = 0.1 * STRONG + 0.9 * NOMINAL;
$binary_bond_strength{']]'}{'->'} = 0.1 * STRONG + 0.9 * NOMINAL;
$binary_bond_strength{'})'}{'->'} = 0.1 * STRONG + 0.9 * NOMINAL;
$binary_bond_strength{'}]'}{'->'} = 0.1 * STRONG + 0.9 * NOMINAL;
$binary_bond_strength{'}}'}{'->'} = 0.1 * STRONG + 0.9 * NOMINAL;
$binary_bond_strength{'R}'}{'->'} = 0.1 * STRONG + 0.9 * NOMINAL;
$binary_bond_strength{'))'}{'[['} = 0.2 * STRONG + 0.8 * NOMINAL;
$binary_bond_strength{'})'}{'[['} = 0.2 * STRONG + 0.8 * NOMINAL;
$binary_bond_strength{'))'}{'{['} = 0.2 * STRONG + 0.8 * NOMINAL;
$binary_bond_strength{'})'}{'{['} = 0.2 * STRONG + 0.8 * NOMINAL;
#---------------------------------------------------------------
# Binary NO_BREAK rules
#---------------------------------------------------------------
# use strict requires that bare word and => not be separated
$binary_bond_strength{'C'}{'=>'} = NO_BREAK;
$binary_bond_strength{'U'}{'=>'} = NO_BREAK;
# Never break between a bareword and a following paren because
# perl may give an error. For example, if a break is placed
# between 'to_filehandle' and its '(' the following line will
# give a syntax error [Carp.pm]: my( $no) =fileno(
# to_filehandle( $in)) ;
$binary_bond_strength{'C'}{'(('} = NO_BREAK;
$binary_bond_strength{'C'}{'{('} = NO_BREAK;
$binary_bond_strength{'U'}{'(('} = NO_BREAK;
$binary_bond_strength{'U'}{'{('} = NO_BREAK;
# use strict requires that bare word within braces not start new
# line
$binary_bond_strength{'L{'}{'w'} = NO_BREAK;
$binary_bond_strength{'w'}{'R}'} = NO_BREAK;
# 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;
# 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) = @_;
my $rK_weld_right = $self->[_rK_weld_right_];
my $rK_weld_left = $self->[_rK_weld_left_];
# 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 = ' ';
my $token_length = 1;
my $last_type;
my $last_nonblank_type = $type;
my $last_nonblank_token = $token;
my $list_str = $left_bond_strength{'?'};
my ( $block_type, $i_next, $i_next_nonblank, $next_nonblank_token,
$next_nonblank_type, $next_token, $next_type,
$total_nesting_depth, );
# main loop to compute bond strengths between each pair of tokens
foreach my $i ( 0 .. $max_index_to_go ) {
$last_type = $type;
if ( $type ne 'b' ) {
$last_nonblank_type = $type;
$last_nonblank_token = $token;
}
$type = $types_to_go[$i];
# strength on both sides of a blank is the same
if ( $type eq 'b' && $last_type ne 'b' ) {
$bond_strength_to_go[$i] = $bond_strength_to_go[ $i - 1 ];
next;
}
$token = $tokens_to_go[$i];
$token_length = $token_lengths_to_go[$i];
$block_type = $block_type_to_go[$i];
$i_next = $i + 1;
$next_type = $types_to_go[$i_next];
$next_token = $tokens_to_go[$i_next];
$total_nesting_depth = $nesting_depth_to_go[$i_next];
$i_next_nonblank = ( ( $next_type eq 'b' ) ? $i + 2 : $i + 1 );
$next_nonblank_type = $types_to_go[$i_next_nonblank];
$next_nonblank_token = $tokens_to_go[$i_next_nonblank];
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' && defined( $right_bond_strength{$token} ) ) {
$bsr = $right_bond_strength{$token};
}
elsif ( $token eq 'ne' or $token eq 'eq' ) {
$bsr = NOMINAL;
}
# set terminal bond strength to the nominal value
# this will cause good preceding breaks to be retained
if ( $i_next_nonblank > $max_index_to_go ) {
$bsl = NOMINAL;
}
# define right bond strengths of certain keywords
if ( $next_nonblank_type eq 'k'
&& defined( $left_bond_strength{$next_nonblank_token} ) )
{
$bsl = $left_bond_strength{$next_nonblank_token};
}
elsif ($next_nonblank_token eq 'ne'
or $next_nonblank_token eq 'eq' )
{
$bsl = NOMINAL;
}
elsif ( $is_lt_gt_le_ge{$next_nonblank_token} ) {
$bsl = 0.9 * NOMINAL + 0.1 * STRONG;
}
# Use the minimum of the left and right strengths. Note: it might
# seem that we would want to keep a NO_BREAK if either token has
# this value. This didn't work, for example because in an arrow
# list, it prevents the comma from separating from the following
# bare word (which is probably quoted by its arrow). So necessary
# NO_BREAK's have to be handled as special cases in the final
# section.
if ( !defined($bsr) ) { $bsr = VERY_STRONG }
if ( !defined($bsl) ) { $bsl = VERY_STRONG }
my $bond_str = ( $bsr < $bsl ) ? $bsr : $bsl;
my $bond_str_1 = $bond_str;
#---------------------------------------------------------------
# Bond Strength Section 2:
# Apply hardwired rules..
#---------------------------------------------------------------
# Patch to put terminal or clauses on a new line: Weaken the bond
# at an || followed by die or similar keyword to make the terminal
# or clause fall on a new line, like this:
#
# my $class = shift
# || die "Cannot add broadcast: No class identifier found";
#
# Otherwise the break will be at the previous '=' since the || and
# = have the same starting strength and the or is biased, like
# this:
#
# my $class =
# shift || die "Cannot add broadcast: No class identifier found";
#
# In any case if the user places a break at either the = or the ||
# it should remain there.
if ( $type eq '||' || $type eq 'k' && $token eq 'or' ) {
if ( $next_nonblank_token =~ /^(die|confess|croak|warn)$/ ) {
if ( $want_break_before{$token} && $i > 0 ) {
$bond_strength_to_go[ $i - 1 ] -= $delta_bias;
# keep bond strength of a token and its following blank
# the same
if ( $types_to_go[ $i - 1 ] eq 'b' && $i > 2 ) {
$bond_strength_to_go[ $i - 2 ] -= $delta_bias;
}
}
else {
$bond_str -= $delta_bias;
}
}
}
# good to break after end of code blocks
if ( $type eq '}' && $block_type && $next_nonblank_type ne ';' ) {
$bond_str = 0.5 * WEAK + 0.5 * VERY_WEAK + $code_bias;
$code_bias += $delta_bias;
}
if ( $type eq 'k' ) {
# allow certain control keywords to stand out
if ( $next_nonblank_type eq 'k'
&& $is_last_next_redo_return{$token} )
{
$bond_str = 0.45 * WEAK + 0.55 * VERY_WEAK;
}
# Don't break after keyword my. This is a quick fix for a
# rare problem with perl. An example is this line from file
# Container.pm:
# foreach my $question( Debian::DebConf::ConfigDb::gettree(
# $this->{'question'} ) )
if ( $token eq 'my' ) {
$bond_str = NO_BREAK;
}
}
# good to break before 'if', 'unless', etc
if ( $is_if_brace_follower{$next_nonblank_token} ) {
$bond_str = VERY_WEAK;
}
if ( $next_nonblank_type eq 'k' && $type ne 'CORE::' ) {
if ( $is_keyword_returning_list{$next_nonblank_token} ) {
$bond_str = $list_str if ( $bond_str > $list_str );
}
# keywords like 'unless', 'if', etc, within statements
# make good breaks
if ( $is_good_keyword_breakpoint{$next_nonblank_token} ) {
$bond_str = VERY_WEAK / 1.05;
}
}
# try not to break before a comma-arrow
elsif ( $next_nonblank_type eq '=>' ) {
if ( $bond_str < STRONG ) { $bond_str = STRONG }
}
#---------------------------------------------------------------
# Additional hardwired NOBREAK rules
#---------------------------------------------------------------
# map1.t -- correct for a quirk in perl
if ( $token eq '('
&& $next_nonblank_type eq 'i'
&& $last_nonblank_type eq 'k'
&& $is_sort_map_grep{$last_nonblank_token} )
# /^(sort|map|grep)$/ )
{
$bond_str = NO_BREAK;
}
# extrude.t: do not break before paren at:
# -l pid_filename(
if ( $last_nonblank_type eq 'F' && $next_nonblank_token eq '(' ) {
$bond_str = NO_BREAK;
}
# in older version of perl, use strict can cause problems with
# breaks before bare words following opening parens. For example,
# this will fail under older versions if a break is made between
# '(' and 'MAIL': use strict; open( MAIL, "a long filename or
# command"); close MAIL;
if ( $type eq '{' ) {
if ( $token eq '(' && $next_nonblank_type eq 'w' ) {
# but it's fine to break if the word is followed by a '=>'
# or if it is obviously a sub call
my $i_next_next_nonblank = $i_next_nonblank + 1;
my $next_next_type = $types_to_go[$i_next_next_nonblank];
if ( $next_next_type eq 'b'
&& $i_next_nonblank < $max_index_to_go )
{
$i_next_next_nonblank++;
$next_next_type = $types_to_go[$i_next_next_nonblank];
}
# We'll check for an old breakpoint and keep a leading
# bareword if it was that way in the input file.
# Presumably it was ok that way. For example, the
# following would remain unchanged:
#
# @months = (
# January, February, March, April,
# May, June, July, August,
# September, October, November, December,
# );
#
# This should be sufficient:
if (
!$old_breakpoint_to_go[$i]
&& ( $next_next_type eq ','
|| $next_next_type eq '}' )
)
{
$bond_str = NO_BREAK;
}
}
}
# Do not break between a possible filehandle and a ? or / and do
# not introduce a break after it if there is no blank
# (extrude.t)
elsif ( $type eq 'Z' ) {
# don't break..
if (
# if there is no blank and we do not want one. Examples:
# print $x++ # do not break after $x
# print HTML"HELLO" # break ok after HTML
(
$next_type ne 'b'
&& defined( $want_left_space{$next_type} )
&& $want_left_space{$next_type} == WS_NO
)
# or we might be followed by the start of a quote,
# 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;
}
}
# 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' );
}
# Fix for c039
elsif ( $type eq 'w' ) {
$bond_str = NO_BREAK
if ( !$old_breakpoint_to_go[$i]
&& substr( $next_nonblank_token, 0, 1 ) eq '/' );
}
my $bond_str_2 = $bond_str;
#---------------------------------------------------------------
# End of hardwired rules
#---------------------------------------------------------------
#---------------------------------------------------------------
# Bond Strength Section 3:
# Apply table rules. These have priority over the above
# hardwired rules.
#---------------------------------------------------------------
my $tabulated_bond_str;
my $ltype = $type;
my $rtype = $next_nonblank_type;
if ( $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;
}
# 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;
}
my $bond_str_3 = $bond_str;
# If the hardwired rules conflict with the tabulated bond
# strength then there is an inconsistency that should be fixed
DEBUG_BOND
&& $tabulated_bond_str
&& $bond_str_1
&& $bond_str_1 != $bond_str_2
&& $bond_str_2 != $tabulated_bond_str
&& do {
print STDERR
"BOND_TABLES: ltype=$ltype rtype=$rtype $bond_str_1->$bond_str_2->$bond_str_3\n";
};
#-----------------------------------------------------------------
# Bond Strength Section 4:
# Modify strengths of certain tokens which often occur in sequence
# by adding a small bias to each one in turn so that the breaks
# occur from left to right.
#
# Note that we only changing strengths by small amounts here,
# and usually increasing, so we should not be altering any NO_BREAKs.
# Other routines which check for NO_BREAKs will use a tolerance
# of one to avoid any problem.
#-----------------------------------------------------------------
# The bias tables use special keys:
# $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;
if ( $type eq ',' ) {
# add any bias set by sub scan_list at old comma break points
$bond_str += $bond_strength_to_go[$i];
}
# bias left token
elsif ( defined( $bias{$left_key} ) ) {
if ( !$want_break_before{$left_key} ) {
$bias{$left_key} += $delta_bias;
$bond_str += $bias{$left_key};
}
}
# bias right token
if ( defined( $bias{$right_key} ) ) {
if ( $want_break_before{$right_key} ) {
# for leading '.' align all but 'short' quotes; the idea
# is to not place something like "\n" on a single line.
if ( $right_key eq '.' ) {
unless (
$last_nonblank_type eq '.'
&& ( $token_length <=
$rOpts_short_concatenation_item_length )
&& ( !$is_closing_token{$token} )
)
{
$bias{$right_key} += $delta_bias;
}
}
else {
$bias{$right_key} += $delta_bias;
}
$bond_str += $bias{$right_key};
}
}
my $bond_str_4 = $bond_str;
#---------------------------------------------------------------
# Bond Strength Section 5:
# Fifth Approximation.
# Take nesting depth into account by adding the nesting depth
# to the bond strength.
#---------------------------------------------------------------
my $strength;
if ( defined($bond_str) && !$nobreak_to_go[$i] ) {
if ( $total_nesting_depth > 0 ) {
$strength = $bond_str + $total_nesting_depth;
}
else {
$strength = $bond_str;
}
}
else {
$strength = NO_BREAK;
# 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] > 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;
}
}
# always break after side comment
if ( $type eq '#' ) { $strength = 0 }
$bond_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 .= ' ' x ( 16 - length($str) );
print STDOUT
"BOND: i=$i $str $type $next_nonblank_type depth=$total_nesting_depth strength=$bond_str_1 -> $bond_str_2 -> $bond_str_3 -> $bond_str_4 $bond_str -> $strength \n";
};
} ## end main loop
return;
} ## end sub set_bond_strengths
} ## end closure set_bond_strengths
sub bad_pattern {
# See if a pattern will compile. We have to use a string eval here,
# but it should be safe because the pattern has been constructed
# by this program.
my ($pattern) = @_;
eval "'##'=~/$pattern/";
return $@;
}
{ ## 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 {
# the cuddled-else style, if used, is controlled by a hash that
# we construct here
# Include keywords here which should not be cuddled
my $cuddled_string = "";
if ( $rOpts->{'cuddled-else'} ) {
# set the default
$cuddled_string = 'elsif else continue catch finally'
unless ( $rOpts->{'cuddled-block-list-exclusive'} );
# This is the old equivalent but more complex version
# $cuddled_string = 'if-elsif-else unless-elsif-else -continue ';
# Add users other blocks to be cuddled
my $cuddled_block_list = $rOpts->{'cuddled-block-list'};
if ($cuddled_block_list) {
$cuddled_string .= " " . $cuddled_block_list;
}
}
# If we have a cuddled string of the form
# 'try-catch-finally'
# we want to prepare a hash of the form
# $rcuddled_block_types = {
# 'try' => {
# 'catch' => 1,
# 'finally' => 1
# },
# };
# use -dcbl to dump this hash
# Multiple such strings are input as a space or comma separated list
# If we get two lists with the same leading type, such as
# -cbl = "-try-catch-finally -try-catch-otherwise"
# then they will get merged as follows:
# $rcuddled_block_types = {
# 'try' => {
# 'catch' => 1,
# 'finally' => 2,
# 'otherwise' => 1,
# },
# };
# This will allow either type of chain to be followed.
$cuddled_string =~ s/,/ /g; # allow space or comma separated lists
my @cuddled_strings = split /\s+/, $cuddled_string;
$rcuddled_block_types = {};
# process each dash-separated string...
my $string_count = 0;
foreach my $string (@cuddled_strings) {
next unless $string;
my @words = split /-+/, $string; # allow multiple dashes
# we could look for and report possible errors here...
next unless ( @words > 0 );
# allow either '-continue' or *-continue' for arbitrary starting type
my $start = '*';
# a single word without dashes is a secondary block type
if ( @words > 1 ) {
$start = shift @words;
}
# always make an entry for the leading word. If none follow, this
# will still prevent a wildcard from matching this word.
if ( !defined( $rcuddled_block_types->{$start} ) ) {
$rcuddled_block_types->{$start} = {};
}
# The count gives the original word order in case we ever want it.
$string_count++;
my $word_count = 0;
foreach my $word (@words) {
next unless $word;
if ( $no_cuddle{$word} ) {
Warn(
"## Ignoring keyword '$word' in -cbl; does not seem right\n"
);
next;
}
$word_count++;
$rcuddled_block_types->{$start}->{$word} =
1; #"$string_count.$word_count";
# git#9: Remove this word from the list of desired one-line
# blocks
$want_one_line_block{$word} = 0;
}
}
return;
}
} ## begin 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
# },
# };
# SIMPLFIED METHOD: the simplified method uses a wildcard for
# the starting block type and puts all cuddled blocks together:
# my $rcuddled_block_types = {
# '*' => {
# 'else' => 1,
# 'elsif' => 1
# 'catch' => 1,
# 'finally' => 1
# },
# };
# Both methods work, but the simplified method has proven to be adequate and
# easier to manage.
my $cuddled_string = $rOpts->{'cuddled-block-list'};
$cuddled_string = '' unless $cuddled_string;
my $flags = "";
$flags .= "-ce" if ( $rOpts->{'cuddled-else'} );
$flags .= " -cbl='$cuddled_string'";
unless ( $rOpts->{'cuddled-else'} ) {
$flags .= "\nNote: You must specify -ce to generate a cuddled hash";
}
$fh->print(<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;
}
sub make_format_skipping_pattern {
my ( $opt_name, $default ) = @_;
my $param = $rOpts->{$opt_name};
unless ($param) { $param = $default }
$param =~ s/^\s*//;
if ( $param !~ /^#/ ) {
Die("ERROR: the $opt_name parameter '$param' must begin with '#'\n");
}
my $pattern = '^' . $param . '\s';
if ( bad_pattern($pattern) ) {
Die(
"ERROR: the $opt_name parameter '$param' causes the invalid regex '$pattern'\n"
);
}
return $pattern;
}
sub make_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;
}
sub make_closing_side_comment_list_pattern {
# turn any input list into a regex for recognizing selected block types
$closing_side_comment_list_pattern = '^\w+';
if ( defined( $rOpts->{'closing-side-comment-list'} )
&& $rOpts->{'closing-side-comment-list'} )
{
$closing_side_comment_list_pattern =
make_block_pattern( '-cscl', $rOpts->{'closing-side-comment-list'} );
}
return;
}
sub make_sub_matching_pattern {
# Patterns for standardizing matches to block types for regular subs and
# anonymous subs. Examples
# 'sub process' is a named sub
# 'sub ::m' is a named sub
# 'sub' is an anonymous sub
# 'sub:' is a label, not a sub
# 'substr' is a keyword
$SUB_PATTERN = '^sub\s+(::|\w)'; # match normal sub
$ASUB_PATTERN = '^sub$'; # match anonymous sub
$ANYSUB_PATTERN = '^sub\b'; # match either type of sub
# 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 ( $rOpts->{'sub-alias-list'} ) {
# Note that any 'sub-alias-list' has been preprocessed to
# be a trimmed, space-separated list which includes 'sub'
# for example, it might be 'sub method fun'
my $sub_alias_list = $rOpts->{'sub-alias-list'};
$sub_alias_list =~ s/\s+/\|/g;
$SUB_PATTERN =~ s/sub/\($sub_alias_list\)/;
$ASUB_PATTERN =~ s/sub/\($sub_alias_list\)/;
$ANYSUB_PATTERN =~ s/sub/\($sub_alias_list\)/;
}
return;
}
sub make_bli_pattern {
# default list of block types for which -bli would apply
my $bli_list_string = 'if else elsif unless while for foreach do : sub';
if ( defined( $rOpts->{'brace-left-and-indent-list'} )
&& $rOpts->{'brace-left-and-indent-list'} )
{
$bli_list_string = $rOpts->{'brace-left-and-indent-list'};
}
$bli_pattern = make_block_pattern( '-blil', $bli_list_string );
return;
}
sub make_keyword_group_list_pattern {
# turn any input list into a regex for recognizing selected block types.
# Here are the defaults:
$keyword_group_list_pattern = '^(our|local|my|use|require|)$';
$keyword_group_list_comment_pattern = '';
if ( defined( $rOpts->{'keyword-group-blanks-list'} )
&& $rOpts->{'keyword-group-blanks-list'} )
{
my @words = split /\s+/, $rOpts->{'keyword-group-blanks-list'};
my @keyword_list;
my @comment_list;
foreach my $word (@words) {
if ( $word =~ /^(BC|SBC)$/ ) {
push @comment_list, $word;
if ( $word eq 'SBC' ) { push @comment_list, 'SBCX' }
}
else {
push @keyword_list, $word;
}
}
$keyword_group_list_pattern =
make_block_pattern( '-kgbl', $rOpts->{'keyword-group-blanks-list'} );
$keyword_group_list_comment_pattern =
make_block_pattern( '-kgbl', join( ' ', @comment_list ) );
}
return;
}
sub make_block_brace_vertical_tightness_pattern {
# turn any input list into a regex for recognizing selected block types
$block_brace_vertical_tightness_pattern =
'^((if|else|elsif|unless|while|for|foreach|do|\w+:)$|sub)';
if ( defined( $rOpts->{'block-brace-vertical-tightness-list'} )
&& $rOpts->{'block-brace-vertical-tightness-list'} )
{
$block_brace_vertical_tightness_pattern =
make_block_pattern( '-bbvtl',
$rOpts->{'block-brace-vertical-tightness-list'} );
}
return;
}
sub make_blank_line_pattern {
$blank_lines_before_closing_block_pattern = $SUB_PATTERN;
my $key = 'blank-lines-before-closing-block-list';
if ( defined( $rOpts->{$key} ) && $rOpts->{$key} ) {
$blank_lines_before_closing_block_pattern =
make_block_pattern( '-blbcl', $rOpts->{$key} );
}
$blank_lines_after_opening_block_pattern = $SUB_PATTERN;
$key = 'blank-lines-after-opening-block-list';
if ( defined( $rOpts->{$key} ) && $rOpts->{$key} ) {
$blank_lines_after_opening_block_pattern =
make_block_pattern( '-blaol', $rOpts->{$key} );
}
return;
}
sub make_block_pattern {
# given a string of block-type keywords, return a regex to match them
# The only tricky part is that labels are indicated with a single ':'
# and the 'sub' token text may have additional text after it (name of
# sub).
#
# Example:
#
# input string: "if else elsif unless while for foreach do : sub";
# pattern: '^((if|else|elsif|unless|while|for|foreach|do|\w+:)$|sub)';
# Minor Update:
#
# To distinguish between anonymous subs and named subs, use 'sub' to
# indicate a named sub, and 'asub' to indicate an anonymous sub
my ( $abbrev, $string ) = @_;
my @list = split_words($string);
my @words = ();
my %seen;
for my $i (@list) {
if ( $i eq '*' ) { my $pattern = '^.*'; return $pattern }
next if $seen{$i};
$seen{$i} = 1;
if ( $i eq 'sub' ) {
}
elsif ( $i eq 'asub' ) {
}
elsif ( $i eq ';' ) {
push @words, ';';
}
elsif ( $i eq '{' ) {
push @words, '\{';
}
elsif ( $i eq ':' ) {
push @words, '\w+:';
}
elsif ( $i =~ /^\w/ ) {
push @words, $i;
}
else {
Warn("unrecognized block type $i after $abbrev, ignoring\n");
}
}
my $pattern = '(' . join( '|', @words ) . ')$';
my $sub_patterns = "";
if ( $seen{'sub'} ) {
$sub_patterns .= '|' . $SUB_PATTERN;
}
if ( $seen{'asub'} ) {
$sub_patterns .= '|' . $ASUB_PATTERN;
}
if ($sub_patterns) {
$pattern = '(' . $pattern . $sub_patterns . ')';
}
$pattern = '^' . $pattern;
return $pattern;
}
sub make_static_side_comment_pattern {
# create the pattern used to identify static side comments
$static_side_comment_pattern = '^##';
# allow the user to change it
if ( $rOpts->{'static-side-comment-prefix'} ) {
my $prefix = $rOpts->{'static-side-comment-prefix'};
$prefix =~ s/^\s*//;
my $pattern = '^' . $prefix;
if ( bad_pattern($pattern) ) {
Die(
"ERROR: the -sscp prefix '$prefix' causes the invalid regex '$pattern'\n"
);
}
$static_side_comment_pattern = $pattern;
}
return;
}
sub make_closing_side_comment_prefix {
# Be sure we have a valid closing side comment prefix
my $csc_prefix = $rOpts->{'closing-side-comment-prefix'};
my $csc_prefix_pattern;
if ( !defined($csc_prefix) ) {
$csc_prefix = '## end';
$csc_prefix_pattern = '^##\s+end';
}
else {
my $test_csc_prefix = $csc_prefix;
if ( $test_csc_prefix !~ /^#/ ) {
$test_csc_prefix = '#' . $test_csc_prefix;
}
# make a regex to recognize the prefix
my $test_csc_prefix_pattern = $test_csc_prefix;
# escape any special characters
$test_csc_prefix_pattern =~ s/([^#\s\w])/\\$1/g;
$test_csc_prefix_pattern = '^' . $test_csc_prefix_pattern;
# allow exact number of intermediate spaces to vary
$test_csc_prefix_pattern =~ s/\s+/\\s\+/g;
# make sure we have a good pattern
# if we fail this we probably have an error in escaping
# characters.
if ( bad_pattern($test_csc_prefix_pattern) ) {
# shouldn't happen..must have screwed up escaping, above
report_definite_bug();
Warn(
"Program Error: the -cscp prefix '$csc_prefix' caused the invalid regex '$csc_prefix_pattern'\n"
);
# just warn and keep going with defaults
Warn("Please consider using a simpler -cscp prefix\n");
Warn("Using default -cscp instead; please check output\n");
}
else {
$csc_prefix = $test_csc_prefix;
$csc_prefix_pattern = $test_csc_prefix_pattern;
}
}
$rOpts->{'closing-side-comment-prefix'} = $csc_prefix;
$closing_side_comment_prefix_pattern = $csc_prefix_pattern;
return;
}
##################################################
# CODE SECTION 4: receive lines from the tokenizer
##################################################
{ ## begin closure write_line
my $Last_line_had_side_comment;
my $In_format_skipping_section;
my $Saw_VERSION_in_this_file;
sub initialize_write_line {
$Last_line_had_side_comment = 0;
$In_format_skipping_section = 0;
$Saw_VERSION_in_this_file = 0;
return;
}
sub write_line {
# This routine originally received lines of code and immediately processed
# them. That was efficient when memory was limited, but now it just saves
# the lines it receives. They get processed all together after the last
# line is received.
# As tokenized lines are received they are converted to the format needed
# for the final formatting.
my ( $self, $line_of_tokens_old ) = @_;
my $rLL = $self->[_rLL_];
my $Klimit = $self->[_Klimit_];
my $rlines_new = $self->[_rlines_];
my $maximum_level = $self->[_maximum_level_];
my $Kfirst;
my $line_of_tokens = {};
foreach my $key (
qw(
_curly_brace_depth
_ending_in_quote
_guessed_indentation_level
_line_number
_line_text
_line_type
_paren_depth
_quote_character
_square_bracket_depth
_starting_in_quote
)
)
{
$line_of_tokens->{$key} = $line_of_tokens_old->{$key};
}
# Data needed by Logger
$line_of_tokens->{_level_0} = 0;
$line_of_tokens->{_ci_level_0} = 0;
$line_of_tokens->{_nesting_blocks_0} = "";
$line_of_tokens->{_nesting_tokens_0} = "";
# Needed to avoid trimming quotes
$line_of_tokens->{_ended_in_blank_token} = undef;
my $line_type = $line_of_tokens_old->{_line_type};
my $input_line_no = $line_of_tokens_old->{_line_number};
my $CODE_type = "";
my $tee_output;
# Handle line of non-code
if ( $line_type ne 'CODE' ) {
$tee_output ||= $rOpts_tee_pod
&& substr( $line_type, 0, 3 ) eq 'POD';
}
# Handle line of code
else {
my $rtokens = $line_of_tokens_old->{_rtokens};
my $rtoken_type = $line_of_tokens_old->{_rtoken_type};
my $rblock_type = $line_of_tokens_old->{_rblock_type};
my $rcontainer_type = $line_of_tokens_old->{_rcontainer_type};
my $rcontainer_environment =
$line_of_tokens_old->{_rcontainer_environment};
my $rtype_sequence = $line_of_tokens_old->{_rtype_sequence};
my $rlevels = $line_of_tokens_old->{_rlevels};
my $rslevels = $line_of_tokens_old->{_rslevels};
my $rci_levels = $line_of_tokens_old->{_rci_levels};
my $rnesting_blocks = $line_of_tokens_old->{_rnesting_blocks};
my $rnesting_tokens = $line_of_tokens_old->{_rnesting_tokens};
my $jmax = @{$rtokens} - 1;
if ( $jmax >= 0 ) {
$Kfirst = defined($Klimit) ? $Klimit + 1 : 0;
foreach my $j ( 0 .. $jmax ) {
# Clip negative nesting depths to zero to avoid problems.
# Negative values can occur in files with unbalanced containers
my $slevel = $rslevels->[$j];
if ( $slevel < 0 ) { $slevel = 0 }
if ( $rlevels->[$j] > $maximum_level ) {
$maximum_level = $rlevels->[$j];
}
# But do not clip the 'level' variable yet. We will do this
# later, in sub 'store_token_to_go'. The reason is that in
# files with level errors, the logic in 'weld_cuddled_else'
# uses a stack logic that will give bad welds if we clip
# levels here.
## if ( $rlevels->[$j] < 0 ) { $rlevels->[$j] = 0 }
my @tokary;
@tokary[
_TOKEN_, _TYPE_, _BLOCK_TYPE_,
_TYPE_SEQUENCE_, _LEVEL_, _SLEVEL_,
_CI_LEVEL_, _LINE_INDEX_,
]
= (
$rtokens->[$j], $rtoken_type->[$j],
$rblock_type->[$j], $rtype_sequence->[$j],
$rlevels->[$j], $slevel,
$rci_levels->[$j], $input_line_no - 1,
);
push @{$rLL}, \@tokary;
} ## end foreach my $j ( 0 .. $jmax )
$Klimit = @{$rLL} - 1;
# Need to remember if we can trim the input line
$line_of_tokens->{_ended_in_blank_token} =
$rtoken_type->[$jmax] eq 'b';
$line_of_tokens->{_level_0} = $rlevels->[0];
$line_of_tokens->{_ci_level_0} = $rci_levels->[0];
$line_of_tokens->{_nesting_blocks_0} = $rnesting_blocks->[0];
$line_of_tokens->{_nesting_tokens_0} = $rnesting_tokens->[0];
} ## end if ( $jmax >= 0 )
$CODE_type =
$self->get_CODE_type( $line_of_tokens, $Kfirst, $Klimit,
$input_line_no );
$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 '#';
# 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. An since we are deleting now, we have to also
# handle any tee- requests before the side comments vanish.
my $delete_side_comment =
$rOpts_delete_side_comments
&& defined($Kfirst)
&& $rLL->[$Klimit]->[_TYPE_] eq '#'
&& ( $Klimit > $Kfirst || $CODE_type eq 'HSC' )
&& (!$CODE_type
|| $CODE_type eq 'HSC'
|| $CODE_type eq 'IO'
|| $CODE_type eq 'NIN' );
if (
$rOpts_delete_closing_side_comments
&& !$delete_side_comment
&& defined($Kfirst)
&& $Klimit > $Kfirst
&& $rLL->[$Klimit]->[_TYPE_] eq '#'
&& ( !$CODE_type
|| $CODE_type eq 'HSC'
|| $CODE_type eq 'IO'
|| $CODE_type eq 'NIN' )
)
{
my $token = $rLL->[$Klimit]->[_TOKEN_];
my $K_m = $Klimit - 1;
my $type_m = $rLL->[$K_m]->[_TYPE_];
if ( $type_m eq 'b' && $K_m > $Kfirst ) { $K_m-- }
my $last_nonblank_block_type = $rLL->[$K_m]->[_BLOCK_TYPE_];
if ( $token =~ /$closing_side_comment_prefix_pattern/
&& $last_nonblank_block_type =~
/$closing_side_comment_list_pattern/ )
{
$delete_side_comment = 1;
}
} ## end if ( $rOpts_delete_closing_side_comments...)
if ($delete_side_comment) {
pop @{$rLL};
$Klimit -= 1;
if ( $Klimit > $Kfirst
&& $rLL->[$Klimit]->[_TYPE_] eq 'b' )
{
pop @{$rLL};
$Klimit -= 1;
}
# 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 = "";
foreach my $KK ( $Kfirst .. $Klimit ) {
$line .= $rLL->[$KK]->[_TOKEN_];
}
$line_of_tokens->{_line_text} = $line . "\n";
}
# If we delete a hanging side comment the line becomes blank.
if ( $CODE_type eq 'HSC' ) { $CODE_type = 'BL' }
}
} ## end if ( $line_type eq 'CODE')
# Finish storing line variables
if ($tee_output) {
my $fh_tee = $self->[_fh_tee_];
my $line_text = $line_of_tokens_old->{_line_text};
$fh_tee->print($line_text) if ($fh_tee);
}
$line_of_tokens->{_rK_range} = [ $Kfirst, $Klimit ];
$line_of_tokens->{_code_type} = $CODE_type;
$self->[_Klimit_] = $Klimit;
$self->[_maximum_level_] = $maximum_level;
push @{$rlines_new}, $line_of_tokens;
return;
}
sub get_CODE_type {
my ( $self, $line_of_tokens, $Kfirst, $Klast, $input_line_no ) = @_;
# We are looking at a line of code and setting a flag to
# describe any special processing that it requires
# 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 restructions
my $rLL = $self->[_rLL_];
my $CODE_type = "";
my $input_line = $line_of_tokens->{_line_text};
my $jmax = defined($Kfirst) ? $Klast - $Kfirst : -1;
my $is_block_comment = 0;
my $has_side_comment = 0;
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
&& ( $rLL->[$Kfirst]->[_TOKEN_] . " " ) =~
/$format_skipping_pattern_end/ )
{
$In_format_skipping_section = 0;
write_logfile_entry(
"Line $input_line_no: Exiting format-skipping section\n");
}
$CODE_type = 'FS';
goto RETURN;
}
# 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 ( ( $input_line =~ "\t" ) ) {
my $input_line_number = $line_of_tokens->{_line_number};
$self->note_embedded_tab($input_line_number);
}
$CODE_type = 'VB';
goto RETURN;
}
}
# See if we are entering a formatting skip section
if ( $rOpts_format_skipping
&& $is_block_comment
&& ( $rLL->[$Kfirst]->[_TOKEN_] . " " ) =~
/$format_skipping_pattern_begin/ )
{
$In_format_skipping_section = 1;
write_logfile_entry(
"Line $input_line_no: Entering format-skipping section\n");
$CODE_type = 'FS';
goto RETURN;
}
# 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';
goto RETURN;
}
# see if this is a static block comment (starts with ## by default)
my $is_static_block_comment = 0;
my $is_static_block_comment_without_leading_space = 0;
if ( $is_block_comment
&& $rOpts->{'static-block-comments'}
&& $input_line =~ /$static_block_comment_pattern/ )
{
$is_static_block_comment = 1;
$is_static_block_comment_without_leading_space =
substr( $input_line, 0, 1 ) eq '#';
}
# Check for comments which are line directives
# Treat exactly as static block comments without leading space
# reference: perlsyn, near end, section Plain Old Comments (Not!)
# example: '# line 42 "new_filename.plx"'
if (
$is_block_comment
&& $input_line =~ /^\# \s*
line \s+ (\d+) \s*
(?:\s("?)([^"]+)\2)? \s*
$/x
)
{
$is_static_block_comment = 1;
$is_static_block_comment_without_leading_space = 1;
}
# look for hanging side comment
if (
$is_block_comment
&& $Last_line_had_side_comment # last line had side comment
&& $input_line =~ /^\s/ # there is some leading space
&& !$is_static_block_comment # do not make static comment hanging
&& $rOpts->{'hanging-side-comments'} # user is allowing
# hanging side comments
# like this
)
{
$has_side_comment = 1;
$CODE_type = 'HSC';
goto RETURN;
}
# Handle a block (full-line) comment..
if ($is_block_comment) {
if ($is_static_block_comment_without_leading_space) {
$CODE_type = 'SBCX';
goto RETURN;
}
elsif ($is_static_block_comment) {
$CODE_type = 'SBC';
goto RETURN;
}
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';
goto RETURN;
}
else {
$CODE_type = 'BC';
goto RETURN;
}
}
# End of comments. Handle a line of normal code:
if ($rOpts_indent_only) {
$CODE_type = 'IO';
goto RETURN;
}
if ( !$rOpts_add_newlines ) {
$CODE_type = 'NIN';
goto RETURN;
}
# Patch needed for MakeMaker. Do not break a statement
# in which $VERSION may be calculated. See MakeMaker.pm;
# this is based on the coding in it.
# The first line of a file that matches this will be eval'd:
# /([\$*])(([\w\:\']*)\bVERSION)\b.*\=/
# Examples:
# *VERSION = \'1.01';
# ( $VERSION ) = '$Revision: 1.74 $ ' =~ /\$Revision:\s+([^\s]+)/;
# We will pass such a line straight through without breaking
# it unless -npvl is used.
# Patch for problem reported in RT #81866, where files
# had been flattened into a single line and couldn't be
# tidied without -npvl. There are two parts to this patch:
# First, it is not done for a really long line (80 tokens for now).
# Second, we will only allow up to one semicolon
# before the VERSION. We need to allow at least one semicolon
# for statements like this:
# require Exporter; our $VERSION = $Exporter::VERSION;
# where both statements must be on a single line for MakeMaker
my $is_VERSION_statement = 0;
if ( !$Saw_VERSION_in_this_file
&& $jmax < 80
&& $input_line =~
/^[^;]*;?[^;]*([\$*])(([\w\:\']*)\bVERSION)\b.*\=/ )
{
$Saw_VERSION_in_this_file = 1;
write_logfile_entry("passing VERSION line; -npvl deactivates\n");
# This code type has lower priority than others
$CODE_type = 'VER';
goto RETURN;
}
RETURN:
$Last_line_had_side_comment = $has_side_comment;
return $CODE_type;
}
} ## 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.
# Check the maximum level. If it is extremely large we will
# give up and output the file verbatim.
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();
return;
}
# Update the 'save_logfile' flag based to include any tokenization errors.
# We can save time by skipping logfile calls if it is not going to be saved.
my $logger_object = $self->[_logger_object_];
if ($logger_object) {
$self->[_save_logfile_] = $logger_object->get_save_logfile();
}
# Make a pass through all tokens, adding or deleting any whitespace as
# required. Also make any other changes, such as adding semicolons.
# All token changes must be made here so that the token data structure
# remains fixed for the rest of this iteration.
$self->respace_tokens();
$self->find_multiline_qw();
$self->keep_old_line_breaks();
# Implement any welding needed for the -wn or -cb options
$self->weld_containers();
# Locate small nested blocks which should not be broken
$self->mark_short_nested_blocks();
$self->adjust_indentation_levels();
$self->set_excluded_lp_containers();
# Finishes formatting and write the result to the line sink.
# Eventually this call should just change the 'rlines' data according to the
# new line breaks and then return so that we can do an internal iteration
# before continuing with the next stages of formatting.
$self->process_all_lines();
# A final routine to tie up any loose ends
$self->wrapup();
return;
}
sub dump_verbatim {
my $self = shift;
my $rlines = $self->[_rlines_];
foreach my $line ( @{$rlines} ) {
my $input_line = $line->{_line_text};
$self->write_unindented_line($input_line);
}
return;
}
my %wU;
my %wiq;
my %is_nonlist_keyword;
my %is_nonlist_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);
# 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);
}
sub respace_tokens {
my $self = shift;
return if $rOpts->{'indent-only'};
# This routine is called once per file to do as much formatting as possible
# before new line breaks are set.
# This routine makes all necessary and possible changes to the tokenization
# after the initial tokenization of the file. This is a tedious routine,
# but basically it consists of inserting and deleting whitespace between
# nonblank tokens according to the selected parameters. In a few cases
# non-space characters are added, deleted or modified.
# The goal of this routine is to create a new token array which only needs
# the definition of new line breaks and padding to complete formatting. In
# a few cases we have to cheat a little to achieve this goal. In
# particular, we may not know if a semicolon will be needed, because it
# depends on how the line breaks go. To handle this, we include the
# semicolon as a 'phantom' which can be displayed as normal or as an empty
# string.
# Method: The old tokens are copied one-by-one, with changes, from the old
# linear storage array $rLL to a new array $rLL_new.
my $rLL = $self->[_rLL_];
my $Klimit_old = $self->[_Klimit_];
my $rlines = $self->[_rlines_];
my $length_function = $self->[_length_function_];
my $is_encoded_data = $self->[_is_encoded_data_];
my $rLL_new = []; # This is the new array
my $rtoken_vars;
my $Ktoken_vars; # the old K value of $rtoken_vars
my ( $Kfirst_old, $Klast_old ); # Range of old line
my $Klast_old_code; # K of last token if side comment
my $Kmax = @{$rLL} - 1;
my $CODE_type = "";
my $line_type = "";
# Set the whitespace flags, which indicate the token spacing preference.
my $rwhitespace_flags = $self->set_whitespace_flags();
# we will be setting token lengths as we go
my $cumulative_length = 0;
my %seqno_stack;
my %K_old_opening_by_seqno = (); # Note: old K index
my $depth_next = 0;
my $depth_next_max = 0;
my $K_closing_container = $self->[_K_closing_container_];
my $K_closing_ternary = $self->[_K_closing_ternary_];
my $K_opening_container = $self->[_K_opening_container_];
my $K_opening_ternary = $self->[_K_opening_ternary_];
my $rK_phantom_semicolons = $self->[_rK_phantom_semicolons_];
my $rchildren_of_seqno = $self->[_rchildren_of_seqno_];
my $rhas_broken_code_block = $self->[_rhas_broken_code_block_];
my $rhas_broken_list = $self->[_rhas_broken_list_];
my $rhas_broken_list_with_lec = $self->[_rhas_broken_list_with_lec_];
my $rhas_code_block = $self->[_rhas_code_block_];
my $rhas_list = $self->[_rhas_list_];
my $rhas_ternary = $self->[_rhas_ternary_];
my $ris_assigned_structure = $self->[_ris_assigned_structure_];
my $ris_broken_container = $self->[_ris_broken_container_];
my $ris_excluded_lp_container = $self->[_ris_excluded_lp_container_];
my $ris_list_by_seqno = $self->[_ris_list_by_seqno_];
my $ris_permanently_broken = $self->[_ris_permanently_broken_];
my $rlec_count_by_seqno = $self->[_rlec_count_by_seqno_];
my $roverride_cab3 = $self->[_roverride_cab3_];
my $rparent_of_seqno = $self->[_rparent_of_seqno_];
my $rtype_count_by_seqno = $self->[_rtype_count_by_seqno_];
my $last_nonblank_type = ';';
my $last_nonblank_token = ';';
my $last_nonblank_block_type = '';
my $nonblank_token_count = 0;
my $last_nonblank_token_lx = 0;
my %K_first_here_doc_by_seqno;
my $set_permanently_broken = sub {
my ($seqno) = @_;
while ( defined($seqno) ) {
$ris_permanently_broken->{$seqno} = 1;
$seqno = $rparent_of_seqno->{$seqno};
}
return;
};
my $store_token = sub {
my ($item) = @_;
# This will be the index of this item in the new array
my $KK_new = @{$rLL_new};
my $type = $item->[_TYPE_];
my $is_blank = $type eq 'b';
# Do not output consecutive blanks. This should not happen, but
# is worth checking because later routines make this assumption.
if ( $is_blank && $KK_new && $rLL_new->[-1]->[_TYPE_] eq 'b' ) {
return;
}
# check for a sequenced item (i.e., container or ?/:)
my $type_sequence = $item->[_TYPE_SEQUENCE_];
if ($type_sequence) {
my $token = $item->[_TOKEN_];
if ( $is_opening_token{$token} ) {
$K_opening_container->{$type_sequence} = $KK_new;
# 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_type eq ','
&& $Ktoken_vars == $Klast_old_code
&& $Ktoken_vars > $Kfirst_old )
{
$rlec_count_by_seqno->{$type_sequence}++;
}
if ( $last_nonblank_type eq '='
|| $last_nonblank_type eq '=>' )
{
$ris_assigned_structure->{$type_sequence} =
$last_nonblank_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;
# Do not include terminal commas in counts
if ( $last_nonblank_type eq ','
|| $last_nonblank_type eq '=>' )
{
my $seqno = $seqno_stack{ $depth_next - 1 };
if ($seqno) {
$rtype_count_by_seqno->{$seqno}->{$last_nonblank_type}
--;
if ( $Ktoken_vars == $Kfirst_old
&& $last_nonblank_type eq ','
&& $rlec_count_by_seqno->{$seqno} )
{
$rlec_count_by_seqno->{$seqno}--;
}
}
}
# 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.
my $type = $item->[_TYPE_];
Fault(
"Unexpected token type with sequence number: type='$type', seqno='$type_sequence'"
);
}
}
}
# Find the length of this token. Later it may be adjusted if phantom
# or ignoring side comment lengths.
my $token_length =
$is_encoded_data
? $length_function->( $item->[_TOKEN_] )
: length( $item->[_TOKEN_] );
# handle comments
my $is_comment = $type eq '#';
if ($is_comment) {
# trim comments if necessary
if ( $item->[_TOKEN_] =~ s/\s+$// ) {
$token_length = $length_function->( $item->[_TOKEN_] );
}
# Mark length of side comments as just 1 if sc lengths are ignored
if ( $rOpts_ignore_side_comment_lengths
&& ( !$CODE_type || $CODE_type eq 'HSC' ) )
{
$token_length = 1;
}
my $seqno = $seqno_stack{ $depth_next - 1 };
if ( defined($seqno)
&& !$ris_permanently_broken->{$seqno} )
{
$set_permanently_broken->($seqno);
}
}
$item->[_TOKEN_LENGTH_] = $token_length;
# and update the cumulative length
$cumulative_length += $token_length;
# Save the length sum to just AFTER this token
$item->[_CUMULATIVE_LENGTH_] = $cumulative_length;
if ( !$is_blank && !$is_comment ) {
$last_nonblank_type = $type;
$last_nonblank_token = $item->[_TOKEN_];
$last_nonblank_block_type = $item->[_BLOCK_TYPE_];
$last_nonblank_token_lx = $item->[_LINE_INDEX_];
$nonblank_token_count++;
# 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} ) {
$K_first_here_doc_by_seqno{$seqno} = $KK_new;
}
}
}
}
# 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;
};
my $store_token_and_space = sub {
my ( $item, $want_space ) = @_;
# store a token with preceding space if requested and needed
# First store the space
if ( $want_space
&& @{$rLL_new}
&& $rLL_new->[-1]->[_TYPE_] ne 'b'
&& $rOpts_add_whitespace )
{
my $rcopy = copy_token_as_type( $item, 'b', ' ' );
$rcopy->[_LINE_INDEX_] =
$rLL_new->[-1]->[_LINE_INDEX_];
# Patch 23-Jan-2021 to fix -lp blinkers:
# The level and ci_level of newly created spaces should be the same
# as the previous token. Otherwise the coding for the -lp option,
# in sub set_leading_whitespace, can create a blinking state in
# some rare cases.
$rcopy->[_LEVEL_] =
$rLL_new->[-1]->[_LEVEL_];
$rcopy->[_CI_LEVEL_] =
$rLL_new->[-1]->[_CI_LEVEL_];
$store_token->($rcopy);
}
# then the token
$store_token->($item);
};
my $K_end_q = sub {
my ($KK) = @_;
my $K_end = $KK;
my $Kn = $KK + 1;
if ( $Kn <= $Kmax && $rLL->[$Kn]->[_TYPE_] eq 'b' ) { $Kn += 1 }
while ( $Kn <= $Kmax && $rLL->[$Kn]->[_TYPE_] eq 'q' ) {
$K_end = $Kn;
$Kn += 1;
if ( $Kn <= $Kmax && $rLL->[$Kn]->[_TYPE_] eq 'b' ) { $Kn += 1 }
}
return $K_end;
};
my $add_phantom_semicolon = sub {
my ($KK) = @_;
my $Kp = $self->K_previous_nonblank( undef, $rLL_new );
return unless ( defined($Kp) );
# we are only adding semicolons for certain block types
my $block_type = $rLL->[$KK]->[_BLOCK_TYPE_];
return
unless ( $ok_to_add_semicolon_for_block_type{$block_type}
|| $block_type =~ /^(sub|package)/
|| $block_type =~ /^\w+\:$/ );
my $type_sequence = $rLL->[$KK]->[_TYPE_SEQUENCE_];
my $previous_nonblank_type = $rLL_new->[$Kp]->[_TYPE_];
my $previous_nonblank_token = $rLL_new->[$Kp]->[_TOKEN_];
# Do not add a semicolon if...
return
if (
# it would follow a comment (and be isolated)
$previous_nonblank_type eq '#'
# it follows a code block ( because they are not always wanted
# there and may add clutter)
|| $rLL_new->[$Kp]->[_BLOCK_TYPE_]
# it would follow a label
|| $previous_nonblank_type eq 'J'
# it would be inside a 'format' statement (and cause syntax error)
|| ( $previous_nonblank_type eq 'k'
&& $previous_nonblank_token =~ /format/ )
);
# 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{$previous_nonblank_token}
# 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', ' ' );
# Convert the existing blank to:
# a phantom semicolon for one_line_block option = 0 or 1
# a real semicolon for one_line_block option = 2
my $tok = '';
my $len_tok = 0;
if ( $rOpts_one_line_block_semicolons == 2 ) {
$tok = ';';
$len_tok = 1;
}
$rLL_new->[$Ktop]->[_TOKEN_] = $tok;
$rLL_new->[$Ktop]->[_TOKEN_LENGTH_] = $len_tok;
$rLL_new->[$Ktop]->[_TYPE_] = ';';
$rLL_new->[$Ktop]->[_SLEVEL_] =
$rLL->[$KK]->[_SLEVEL_];
# Save list of new K indexes of phantom semicolons.
# This will be needed if we want to undo them for iterations in
# future coding.
push @{$rK_phantom_semicolons}, @{$rLL_new} - 1;
# Then store a new blank
$store_token->($rcopy);
}
else {
# insert a new token
my $rcopy = copy_token_as_type( $rLL_new->[$Kp], ';', '' );
$rcopy->[_SLEVEL_] = $rLL->[$KK]->[_SLEVEL_];
$store_token->($rcopy);
push @{$rK_phantom_semicolons}, @{$rLL_new} - 1;
}
};
my $check_Q = sub {
# Check that a quote looks okay
# This sub works but needs to by sync'd with the log file output
# before it can be used.
my ( $KK, $Kfirst, $line_number ) = @_;
my $token = $rLL->[$KK]->[_TOKEN_];
$self->note_embedded_tab($line_number) if ( $token =~ "\t" );
my $Kp = $self->K_previous_nonblank( undef, $rLL_new );
return unless ( defined($Kp) );
my $previous_nonblank_type = $rLL_new->[$Kp]->[_TYPE_];
my $previous_nonblank_token = $rLL_new->[$Kp]->[_TOKEN_];
my $previous_nonblank_type_2 = 'b';
my $previous_nonblank_token_2 = "";
my $Kpp = $self->K_previous_nonblank( $Kp, $rLL_new );
if ( defined($Kpp) ) {
$previous_nonblank_type_2 = $rLL_new->[$Kpp]->[_TYPE_];
$previous_nonblank_token_2 = $rLL_new->[$Kpp]->[_TOKEN_];
}
my $next_nonblank_token = "";
my $Kn = $KK + 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_];
# make note of something like '$var = s/xxx/yyy/;'
# in case it should have been '$var =~ s/xxx/yyy/;'
if (
$token =~ /^(s|tr|y|m|\/)/
&& $previous_nonblank_token =~ /^(=|==|!=)$/
# preceded by simple scalar
&& $previous_nonblank_type_2 eq 'i'
&& $previous_nonblank_token_2 =~ /^\$/
# followed by some kind of termination
# (but give complaint if we can not see far enough ahead)
&& $next_nonblank_token =~ /^[; \)\}]$/
# scalar is not declared
&& !( $type_0 eq 'k' && $token_0 =~ /^(my|our|local)$/ )
)
{
my $guess = substr( $last_nonblank_token, 0, 1 ) . '~';
complain(
"Note: be sure you want '$previous_nonblank_token' instead of '$guess' here\n"
);
}
};
############################################
# Main loop to respace all lines of the file
############################################
my $last_K_out;
# Testing option to break qw. Do not use; it can make a mess.
my $ALLOW_BREAK_MULTILINE_QW = 0;
my $in_multiline_qw;
foreach my $line_of_tokens ( @{$rlines} ) {
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' );
my $last_CODE_type = $CODE_type;
$CODE_type = $line_of_tokens->{_code_type};
my $rK_range = $line_of_tokens->{_rK_range};
my ( $Kfirst, $Klast ) = @{$rK_range};
next unless defined($Kfirst);
( $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 mismarked as
# something else.
if ( defined($last_K_out) ) {
if ( $Kfirst != $last_K_out + 1 ) {
Fault(
"Program Bug: last K out was $last_K_out but Kfirst=$Kfirst"
);
}
}
else {
# 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 restructions
# For a hanging side comment we insert an empty quote before
# the comment so that it becomes a normal side comment and
# will be aligned by the vertical aligner
if ( $CODE_type eq 'HSC' ) {
# Safety Check: This must be a line with one token (a comment)
my $rtoken_vars = $rLL->[$Kfirst];
if ( $Kfirst == $Klast && $rtoken_vars->[_TYPE_] eq '#' ) {
# Note that even if the flag 'noadd-whitespace' is set, we
# will make an exception here and allow a blank to be
# inserted to push the comment to the right. We can think
# of this as an adjustment of indentation rather than
# whitespace between tokens. This will also prevent the
# hanging side comment from getting converted to a block
# comment if whitespace gets deleted, as for example with
# the -extrude and -mangle options.
my $rcopy = copy_token_as_type( $rtoken_vars, 'q', '' );
$store_token->($rcopy);
$rcopy = copy_token_as_type( $rtoken_vars, 'b', ' ' );
$store_token->($rcopy);
$store_token->($rtoken_vars);
next;
}
else {
# This line was mis-marked by sub scan_comment
Fault(
"Program bug. A hanging side comment has been mismarked"
);
}
}
if ( $CODE_type eq 'BL' ) {
my $seqno = $seqno_stack{ $depth_next - 1 };
if ( defined($seqno)
&& !$ris_permanently_broken->{$seqno}
&& $rOpts_maximum_consecutive_blank_lines )
{
$set_permanently_broken->($seqno);
}
}
# Copy tokens unchanged
foreach my $KK ( $Kfirst .. $Klast ) {
$Ktoken_vars = $KK;
$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.
my $type_next = $rLL->[$Kfirst]->[_TYPE_];
my $token_next = $rLL->[$Kfirst]->[_TOKEN_];
my $Kp = $self->K_previous_code( undef, $rLL_new );
if ( $last_line_type eq 'CODE'
&& $type_next ne 'b'
&& defined($Kp) )
{
my $token_p = $rLL_new->[$Kp]->[_TOKEN_];
my $type_p = $rLL_new->[$Kp]->[_TYPE_];
my ( $token_pp, $type_pp );
my $Kpp = $self->K_previous_code( $Kp, $rLL_new );
if ( defined($Kpp) ) {
$token_pp = $rLL_new->[$Kpp]->[_TOKEN_];
$type_pp = $rLL_new->[$Kpp]->[_TYPE_];
}
else {
$token_pp = ";";
$type_pp = ';';
}
if (
is_essential_whitespace(
$token_pp, $type_pp, $token_p,
$type_p, $token_next, $type_next,
)
)
{
# Copy this first token as blank, but use previous line number
my $rcopy = copy_token_as_type( $rLL->[$Kfirst], 'b', ' ' );
$rcopy->[_LINE_INDEX_] =
$rLL_new->[-1]->[_LINE_INDEX_];
# The level and ci_level of newly created spaces should be the
# same as the previous token. Otherwise blinking states can
# be created if the -lp mode is used. See similar coding in
# sub 'store_token_and_space'. Fixes cases b1109 b1110.
$rcopy->[_LEVEL_] =
$rLL_new->[-1]->[_LEVEL_];
$rcopy->[_CI_LEVEL_] =
$rLL_new->[-1]->[_CI_LEVEL_];
$store_token->($rcopy);
}
}
########################################################
# Loop to copy all tokens on this line, with any changes
########################################################
my $type_sequence;
for ( my $KK = $Kfirst ; $KK <= $Klast ; $KK++ ) {
$Ktoken_vars = $KK;
$rtoken_vars = $rLL->[$KK];
my $token = $rtoken_vars->[_TOKEN_];
my $type = $rtoken_vars->[_TYPE_];
my $last_type_sequence = $type_sequence;
$type_sequence = $rtoken_vars->[_TYPE_SEQUENCE_];
# Handle a blank space ...
if ( $type eq 'b' ) {
# Delete it if not wanted by whitespace rules
# or we are deleting all whitespace
# Note that whitespace flag is a flag indicating whether a
# white space BEFORE the token is needed
next if ( $KK >= $Klast ); # skip terminal blank
my $Knext = $KK + 1;
if ($rOpts_freeze_whitespace) {
$store_token->($rtoken_vars);
next;
}
my $ws = $rwhitespace_flags->[$Knext];
if ( $ws == -1
|| $rOpts_delete_old_whitespace )
{
my $Kp = $self->K_previous_nonblank($KK);
next unless defined($Kp);
my $token_p = $rLL->[$Kp]->[_TOKEN_];
my $type_p = $rLL->[$Kp]->[_TYPE_];
my ( $token_pp, $type_pp );
my $Kpp = $self->K_previous_nonblank($Kp);
if ( defined($Kpp) ) {
$token_pp = $rLL->[$Kpp]->[_TOKEN_];
$type_pp = $rLL->[$Kpp]->[_TYPE_];
}
else {
$token_pp = ";";
$type_pp = ';';
}
my $token_next = $rLL->[$Knext]->[_TOKEN_];
my $type_next = $rLL->[$Knext]->[_TYPE_];
my $do_not_delete = is_essential_whitespace(
$token_pp, $type_pp, $token_p,
$type_p, $token_next, $type_next,
);
next unless ($do_not_delete);
}
# make it just one character
$rtoken_vars->[_TOKEN_] = ' ';
$store_token->($rtoken_vars);
next;
}
# Handle a nonblank token...
if ($type_sequence) {
if ( $is_closing_token{$token} ) {
# Insert a tentative missing semicolon if the next token is
# a closing block brace
if (
$type eq '}'
&& $token eq '}'
# not preceded by a ';'
&& $last_nonblank_type ne ';'
# and this is not a VERSION stmt (is all one line, we
# are not inserting semicolons on one-line blocks)
&& $CODE_type ne 'VER'
# and we are allowed to add semicolons
&& $rOpts->{'add-semicolons'}
)
{
$add_phantom_semicolon->($KK);
}
}
}
# Modify certain tokens here for whitespace
# The following is not yet done, but could be:
# sub (x x x)
elsif ( $type =~ /^[wit]$/ ) {
# Examples: <>
# change '$ var' to '$var' etc
# change '@ ' to '@'
my ( $sigil, $word ) = split /\s+/, $token, 2;
if ( length($sigil) == 1
&& $sigil =~ /^[\$\&\%\*\@]$/ )
{
$token = $sigil;
$token .= $word if ($word);
$rtoken_vars->[_TOKEN_] = $token;
}
# Split identifiers with leading arrows, inserting blanks if
# necessary. It is easier and safer here than in the
# tokenizer. For example '->new' becomes two tokens, '->' and
# 'new' with a possible blank between.
#
# Note: there is a related patch in sub set_whitespace_flags
if ( substr( $token, 0, 1 ) eq '-'
&& $token =~ /^\-\>(.*)$/
&& $1 )
{
my $token_save = $1;
my $type_save = $type;
# Change '-> new' to '->new'
$token_save =~ s/^\s+//g;
# store a blank to left of arrow if necessary
my $Kprev = $self->K_previous_nonblank($KK);
if ( defined($Kprev)
&& $rLL->[$Kprev]->[_TYPE_] ne 'b'
&& $rOpts_add_whitespace
&& $want_left_space{'->'} == WS_YES )
{
my $rcopy =
copy_token_as_type( $rtoken_vars, 'b', ' ' );
$store_token->($rcopy);
}
# then store the arrow
my $rcopy = copy_token_as_type( $rtoken_vars, '->', '->' );
$store_token->($rcopy);
# store a blank after the arrow if requested
# added for issue git #33
if ( $want_right_space{'->'} == WS_YES ) {
my $rcopy =
copy_token_as_type( $rtoken_vars, 'b', ' ' );
$store_token->($rcopy);
}
# then reset the current token to be the remainder,
# and reset the whitespace flag according to the arrow
$token = $rtoken_vars->[_TOKEN_] = $token_save;
$type = $rtoken_vars->[_TYPE_] = $type_save;
$store_token->($rtoken_vars);
next;
}
if ( $token =~ /$ANYSUB_PATTERN/ ) {
# -spp = 0 : no space before opening prototype paren
# -spp = 1 : stable (follow input spacing)
# -spp = 2 : always space before opening prototype paren
my $spp = $rOpts->{'space-prototype-paren'};
if ( defined($spp) ) {
if ( $spp == 0 ) { $token =~ s/\s+\(/\(/; }
elsif ( $spp == 2 ) { $token =~ s/\(/ (/; }
}
# one space max, and no tabs
$token =~ s/\s+/ /g;
$rtoken_vars->[_TOKEN_] = $token;
}
# clean up spaces in package identifiers, like
# "package Bob::Dog;"
if ( $token =~ /^package\s/ ) {
$token =~ s/\s+/ /g;
$rtoken_vars->[_TOKEN_] = $token;
}
# trim identifiers of trailing blanks which can occur
# under some unusual circumstances, such as if the
# identifier 'witch' has trailing blanks on input here:
#
# sub
# witch
# () # prototype may be on new line ...
# ...
if ( $type eq 'i' ) {
$token =~ s/\s+$//g;
$rtoken_vars->[_TOKEN_] = $token;
}
}
# handle semicolons
elsif ( $type eq ';' ) {
# Remove unnecessary semicolons, but not after bare
# blocks, where it could be unsafe if the brace is
# mistokenized.
if (
$rOpts->{'delete-semicolons'}
&& (
(
$last_nonblank_type eq '}'
&& (
$is_block_without_semicolon{
$last_nonblank_block_type}
|| $last_nonblank_block_type =~ /$SUB_PATTERN/
|| $last_nonblank_block_type =~ /^\w+:$/
)
)
|| $last_nonblank_type eq ';'
)
)
{
# This looks like a deletable semicolon, but even if a
# semicolon can be deleted it is necessarily best to do so.
# We apply these additional rules for deletion:
# - Always ok to delete a ';' at the end of a line
# - Never delete a ';' before a '#' because it would
# promote it to a block comment.
# - If a semicolon is not at the end of line, then only
# delete if it is followed by another semicolon or closing
# token. This includes the comment rule. It may take
# two passes to get to a final state, but it is a little
# safer. For example, keep the first semicolon here:
# eval { sub bubba { ok(0) }; ok(0) } || ok(1);
# It is not required but adds some clarity.
my $ok_to_delete = 1;
if ( $KK < $Klast ) {
my $Kn = $self->K_next_nonblank($KK);
if ( defined($Kn) && $Kn <= $Klast ) {
my $next_nonblank_token_type =
$rLL->[$Kn]->[_TYPE_];
$ok_to_delete = $next_nonblank_token_type eq ';'
|| $next_nonblank_token_type eq '}';
}
}
# do not delete only nonblank token in a file
else {
my $Kn = $self->K_next_nonblank($KK);
$ok_to_delete = defined($Kn) || $nonblank_token_count;
}
if ($ok_to_delete) {
$self->note_deleted_semicolon($input_line_number);
next;
}
else {
write_logfile_entry("Extra ';'\n");
}
}
}
# patch to add space to something like "x10"
# This avoids having to split this token in the pre-tokenizer
elsif ( $type eq 'n' ) {
if ( $token =~ /^x\d+/ ) {
$token =~ s/x/x /;
$rtoken_vars->[_TOKEN_] = $token;
}
}
# check for a qw quote
elsif ( $type eq 'q' ) {
# trim blanks from right of qw quotes
# (To avoid trimming qw quotes use -ntqw; the tokenizer handles
# this)
$token =~ s/\s*$//;
$rtoken_vars->[_TOKEN_] = $token;
$self->note_embedded_tab($input_line_number)
if ( $token =~ "\t" );
if ($in_multiline_qw) {
# If we are at the end of a multiline qw ..
if ( $in_multiline_qw == $KK ) {
# Split off the closing delimiter character
# so that the formatter can put a line break there if necessary
my $part1 = $token;
my $part2 = substr( $part1, -1, 1, "" );
if ($part1) {
my $rcopy =
copy_token_as_type( $rtoken_vars, 'q', $part1 );
$store_token->($rcopy);
$token = $part2;
$rtoken_vars->[_TOKEN_] = $token;
}
$in_multiline_qw = undef;
# store without preceding blank
$store_token->($rtoken_vars);
next;
}
else {
# continuing a multiline qw
$store_token->($rtoken_vars);
next;
}
}
else {
# we are encountered new qw token...see if multiline
if ($ALLOW_BREAK_MULTILINE_QW) {
my $K_end = $K_end_q->($KK);
if ( $K_end != $KK ) {
# Starting multiline qw...
# set flag equal to the ending K
$in_multiline_qw = $K_end;
# Split off the leading part so that the formatter can
# put a line break there if necessary
if ( $token =~ /^(qw\s*.)(.*)$/ ) {
my $part1 = $1;
my $part2 = $2;
if ($part2) {
my $rcopy =
copy_token_as_type( $rtoken_vars, 'q',
$part1 );
$store_token_and_space->(
$rcopy,
$rwhitespace_flags->[$KK] == WS_YES
);
$token = $part2;
$rtoken_vars->[_TOKEN_] = $token;
# Second part goes without intermediate blank
$store_token->($rtoken_vars);
next;
}
}
}
}
else {
# this is a new single token qw -
# store with possible preceding blank
$store_token_and_space->(
$rtoken_vars, $rwhitespace_flags->[$KK] == WS_YES
);
next;
}
}
} ## end if ( $type eq 'q' )
# change 'LABEL :' to 'LABEL:'
elsif ( $type eq 'J' ) {
$token =~ s/\s+//g;
$rtoken_vars->[_TOKEN_] = $token;
}
# check a quote for problems
elsif ( $type eq 'Q' ) {
$check_Q->( $KK, $Kfirst, $input_line_number );
}
# Store this token with possible previous blank
$store_token_and_space->(
$rtoken_vars, $rwhitespace_flags->[$KK] == WS_YES
);
} # End token loop
} # End line loop
# Walk backwards through the tokens, making forward links to sequence items.
if ( @{$rLL_new} ) {
my $KNEXT;
for ( my $KK = @{$rLL_new} - 1 ; $KK >= 0 ; $KK-- ) {
$rLL_new->[$KK]->[_KNEXT_SEQ_ITEM_] = $KNEXT;
if ( $rLL_new->[$KK]->[_TYPE_SEQUENCE_] ) { $KNEXT = $KK }
}
$self->[_K_first_seq_item_] = $KNEXT;
}
# Find and remember lists by sequence number
foreach my $seqno ( keys %{$K_opening_container} ) {
my $K_opening = $K_opening_container->{$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->{';'} || $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 simicolon 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 perenthesized 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_];
if ( $type_p eq 'k' ) {
my $token_p = $rLL_new->[$Kp]->[_TOKEN_];
$is_list = 0 if ( $is_nonlist_keyword{$token_p} );
}
else {
$is_list = 0 if ( $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 = $rLL_new->[$K_opening]->[_BLOCK_TYPE_];
if ( $block_type && substr( $block_type, -1, 1 ) eq ' ' ) {
# Always remove the trailing space
$block_type =~ s/\s+$//;
# Try to filter out parenless sub calls
my ( $Knn1, $Knn2 );
my ( $type_nn1, $type_nn2 ) = ( 'b', 'b' );
$Knn1 = $self->K_next_nonblank( $K_opening, $rLL_new );
$Knn2 = $self->K_next_nonblank( $Knn1, $rLL_new ) if defined($Knn1);
$type_nn1 = $rLL_new->[$Knn1]->[_TYPE_] if ( defined($Knn1) );
$type_nn2 = $rLL_new->[$Knn2]->[_TYPE_] if ( defined($Knn2) );
# 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 = "";
$rLL_new->[$K_opening]->[_CI_LEVEL_] = 1;
$rLL_new->[$K_closing]->[_CI_LEVEL_] = 1;
}
$rLL_new->[$K_opening]->[_BLOCK_TYPE_] = $block_type;
$rLL_new->[$K_closing]->[_BLOCK_TYPE_] = $block_type;
}
# Handle a list container
if ( $is_list && !$block_type ) {
$ris_list_by_seqno->{$seqno} = $seqno;
my $seqno_parent = $rparent_of_seqno->{$seqno};
my $depth = 0;
while ( defined($seqno_parent) && $seqno_parent ne SEQ_ROOT ) {
$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;
}
}
$seqno_parent = $rparent_of_seqno->{$seqno_parent};
}
}
# Handle code blocks ...
# The -lp option needs to know if a container holds a code block
elsif ( $block_type && $rOpts_line_up_parentheses ) {
my $seqno_parent = $rparent_of_seqno->{$seqno};
while ( defined($seqno_parent) && $seqno_parent ne SEQ_ROOT ) {
$rhas_code_block->{$seqno_parent} = 1;
$rhas_broken_code_block->{$seqno_parent} = $line_diff;
$seqno_parent = $rparent_of_seqno->{$seqno_parent};
}
}
}
# Find containers with ternaries, needed for -lp formatting.
foreach my $seqno ( keys %{$K_opening_ternary} ) {
my $seqno_parent = $rparent_of_seqno->{$seqno};
while ( defined($seqno_parent) && $seqno_parent ne SEQ_ROOT ) {
$rhas_ternary->{$seqno_parent} = 1;
$seqno_parent = $rparent_of_seqno->{$seqno_parent};
}
}
# 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 ( $rhas_list->{$seqno} ) {
$roverride_cab3->{$seqno} = 1;
}
# 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} = 1;
}
}
}
}
# Reset memory to be the new array
$self->[_rLL_] = $rLL_new;
my $Klimit;
if ( @{$rLL_new} ) { $Klimit = @{$rLL_new} - 1 }
$self->[_Klimit_] = $Klimit;
# DEBUG OPTION: make sure the new array looks okay.
# This is no longer needed but should be retained for future development.
DEVEL_MODE && $self->check_token_array();
# reset the token limits of each line
$self->resync_lines_and_tokens();
return;
}
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 ) = @_;
if ( $type eq 'b' ) {
$token = " " unless defined($token);
}
elsif ( $type eq 'q' ) {
$token = '' unless defined($token);
}
elsif ( $type eq '->' ) {
$token = '->' unless defined($token);
}
elsif ( $type eq ';' ) {
$token = ';' unless defined($token);
}
else {
# This sub assumes it will be called with just two types, 'b' or 'q'
Fault(
"Programming error: copy_token_as has type $type but should be 'b' or 'q'"
);
}
my @rnew_token = @{$rold_token};
$rnew_token[_TYPE_] = $type;
$rnew_token[_TOKEN_] = $token;
$rnew_token[_BLOCK_TYPE_] = '';
$rnew_token[_TYPE_SEQUENCE_] = '';
return \@rnew_token;
}
sub Debug_dump_tokens {
# a debug routine, not normally used
my ( $self, $msg ) = @_;
my $rLL = $self->[_rLL_];
my $nvars = @{$rLL};
print STDERR "$msg\n";
print STDERR "ntokens=$nvars\n";
print STDERR "K\t_TOKEN_\t_TYPE_\n";
my $K = 0;
foreach my $item ( @{$rLL} ) {
print STDERR "$K\t$item->[_TOKEN_]\t$item->[_TYPE_]\n";
$K++;
}
return;
}
sub K_next_code {
my ( $self, $KK, $rLL ) = @_;
# return the index K of the next nonblank, non-comment token
return unless ( defined($KK) && $KK >= 0 );
# use the standard array unless given otherwise
$rLL = $self->[_rLL_] unless ( defined($rLL) );
my $Num = @{$rLL};
my $Knnb = $KK + 1;
while ( $Knnb < $Num ) {
if ( !defined( $rLL->[$Knnb] ) ) {
# We seem to have encountered a gap in our array.
# This shouldn't happen because sub write_line() pushed
# items into the $rLL array.
Fault("Undefined entry for k=$Knnb");
}
if ( $rLL->[$Knnb]->[_TYPE_] ne 'b'
&& $rLL->[$Knnb]->[_TYPE_] ne '#' )
{
return $Knnb;
}
$Knnb++;
}
return;
}
sub K_next_nonblank {
my ( $self, $KK, $rLL ) = @_;
# return the index K of the next nonblank token, or
# return undef if none
return unless ( defined($KK) && $KK >= 0 );
# The third arg allows this routine to be used on any array. This is
# useful in sub respace_tokens when we are copying tokens from an old $rLL
# to a new $rLL array. But usually the third arg will not be given and we
# will just use the $rLL array in $self.
$rLL = $self->[_rLL_] unless ( defined($rLL) );
my $Num = @{$rLL};
my $Knnb = $KK + 1;
return unless ( $Knnb < $Num );
return $Knnb if ( $rLL->[$Knnb]->[_TYPE_] ne 'b' );
return unless ( ++$Knnb < $Num );
return $Knnb if ( $rLL->[$Knnb]->[_TYPE_] ne 'b' );
# Backup loop. Very unlikely to get here; it means we have neighboring
# blanks in the token stream.
$Knnb++;
while ( $Knnb < $Num ) {
# Safety check, this fault shouldn't happen: The $rLL array is the
# main array of tokens, so all entries should be used. It is
# initialized in sub write_line, and then re-initialized by sub
# $store_token() within sub respace_tokens. Tokens are pushed on
# so there shouldn't be any gaps.
if ( !defined( $rLL->[$Knnb] ) ) {
Fault("Undefined entry for k=$Knnb");
}
if ( $rLL->[$Knnb]->[_TYPE_] ne 'b' ) { return $Knnb }
$Knnb++;
}
return;
}
sub K_previous_code {
# return the index K of the previous nonblank, non-comment token
# Call with $KK=undef to start search at the top of the array
my ( $self, $KK, $rLL ) = @_;
# use the standard array unless given otherwise
$rLL = $self->[_rLL_] unless ( defined($rLL) );
my $Num = @{$rLL};
if ( !defined($KK) ) { $KK = $Num }
elsif ( $KK > $Num ) {
# 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.
Fault(
"Program Bug: K_previous_nonblank_new called with K=$KK which exceeds $Num"
);
}
my $Kpnb = $KK - 1;
while ( $Kpnb >= 0 ) {
if ( $rLL->[$Kpnb]->[_TYPE_] ne 'b'
&& $rLL->[$Kpnb]->[_TYPE_] ne '#' )
{
return $Kpnb;
}
$Kpnb--;
}
return;
}
sub K_previous_nonblank {
# return index of previous nonblank token before item K;
# Call with $KK=undef to start search at the top of the array
my ( $self, $KK, $rLL ) = @_;
# use the standard array unless given otherwise
$rLL = $self->[_rLL_] unless ( defined($rLL) );
my $Num = @{$rLL};
if ( !defined($KK) ) { $KK = $Num }
elsif ( $KK > $Num ) {
# 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.
Fault(
"Program Bug: K_previous_nonblank_new called with K=$KK which exceeds $Num"
);
}
my $Kpnb = $KK - 1;
return unless ( $Kpnb >= 0 );
return $Kpnb if ( $rLL->[$Kpnb]->[_TYPE_] ne 'b' );
return unless ( --$Kpnb >= 0 );
return $Kpnb if ( $rLL->[$Kpnb]->[_TYPE_] ne 'b' );
# Backup loop. We should not get here unless some routine
# slipped repeated blanks into the token stream.
return unless ( --$Kpnb >= 0 );
while ( $Kpnb >= 0 ) {
if ( $rLL->[$Kpnb]->[_TYPE_] ne 'b' ) { return $Kpnb }
$Kpnb--;
}
return;
}
sub get_old_line_index {
# return index of the original line that token K was on
my ( $self, $K ) = @_;
my $rLL = $self->[_rLL_];
return 0 unless defined($K);
return $rLL->[$K]->[_LINE_INDEX_];
}
sub get_old_line_count {
# return number of input lines separating two tokens
my ( $self, $Kbeg, $Kend ) = @_;
my $rLL = $self->[_rLL_];
return 0 unless defined($Kbeg);
return 0 unless defined($Kend);
return $rLL->[$Kend]->[_LINE_INDEX_] - $rLL->[$Kbeg]->[_LINE_INDEX_] + 1;
}
sub parent_seqno_by_K {
# Return the sequence number of the parent container of token K, if any.
my ( $self, $KK ) = @_;
return unless defined($KK);
# Note: This routine is relatively slow. I tried replacing it with a hash
# which is easily created in sub respace_tokens. But the total time with a
# hash was greater because this routine is called once per line whereas a
# hash must be created token-by-token.
my $rLL = $self->[_rLL_];
my $KNEXT = $KK;
# 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;
while ( defined($KNEXT) ) {
my $Kt = $KNEXT;
$KNEXT = $rLL->[$KNEXT]->[_KNEXT_SEQ_ITEM_];
my $rtoken_vars = $rLL->[$Kt];
my $type = $rtoken_vars->[_TYPE_];
my $type_sequence = $rtoken_vars->[_TYPE_SEQUENCE_];
# if next container token is closing, it is the parent seqno
if ( $is_closing_type{$type} ) {
if ( $Kt > $KK ) {
$parent_seqno = $type_sequence;
}
else {
$parent_seqno = $self->[_rparent_of_seqno_]->{$type_sequence};
}
last;
}
# if next container token is opening, we want its parent container
elsif ( $is_opening_type{$type} ) {
$parent_seqno = $self->[_rparent_of_seqno_]->{$type_sequence};
last;
}
# not a container - must be ternary - keep going
}
$parent_seqno = SEQ_ROOT unless ( defined($parent_seqno) );
return $parent_seqno;
}
sub is_in_block_by_i {
my ( $self, $i ) = @_;
# returns 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)
# returns false otherwise
my $seqno = $parent_seqno_to_go[$i];
return 1 if ( !$seqno || $seqno eq SEQ_ROOT );
my $Kopening = $self->[_K_opening_container_]->{$seqno};
return 1 unless defined($Kopening);
my $rLL = $self->[_rLL_];
return 1 if $rLL->[$Kopening]->[_BLOCK_TYPE_];
return;
}
sub is_in_list_by_i {
my ( $self, $i ) = @_;
# returns true if token at i is contained in a LIST
# returns false otherwise
my $seqno = $parent_seqno_to_go[$i];
return unless ( $seqno && $seqno ne SEQ_ROOT );
if ( $self->[_ris_list_by_seqno_]->{$seqno} ) {
return 1;
}
return;
}
sub is_list_by_K {
# Return true if token K is in a list
my ( $self, $KK ) = @_;
my $parent_seqno = $self->parent_seqno_by_K($KK);
return unless defined($parent_seqno);
return $self->[_ris_list_by_seqno_]->{$parent_seqno};
}
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};
}
sub resync_lines_and_tokens {
my $self = shift;
my $rLL = $self->[_rLL_];
my $Klimit = $self->[_Klimit_];
my $rlines = $self->[_rlines_];
my @Krange_code_without_comments;
my @Klast_valign_code;
# Re-construct the arrays of tokens associated with the original input lines
# since they have probably changed due to inserting and deleting blanks
# and a few other tokens.
my $Kmax = -1;
# This is the next token and its line index:
my $Knext = 0;
my $inext;
if ( defined($rLL) && @{$rLL} ) {
$Kmax = @{$rLL} - 1;
$inext = $rLL->[$Knext]->[_LINE_INDEX_];
}
# Remember the most recently output token index
my $Klast_out;
my $iline = -1;
foreach my $line_of_tokens ( @{$rlines} ) {
$iline++;
my $line_type = $line_of_tokens->{_line_type};
my $CODE_type = $line_of_tokens->{_code_type};
if ( $line_type eq 'CODE' ) {
my @K_array;
my $rK_range;
if ( $Knext <= $Kmax ) {
$inext = $rLL->[$Knext]->[_LINE_INDEX_];
while ( $inext <= $iline ) {
push @K_array, $Knext;
$Knext += 1;
if ( $Knext > $Kmax ) {
$inext = undef;
last;
}
$inext = $rLL->[$Knext]->[_LINE_INDEX_];
}
}
# Delete any terminal blank token
if (@K_array) {
if ( $rLL->[ $K_array[-1] ]->[_TYPE_] eq 'b' ) {
pop @K_array;
}
}
# Define the range of K indexes for the line:
# $Kfirst = index of first token on line
# $Klast_out = index of last token on line
my ( $Kfirst, $Klast );
if (@K_array) {
$Kfirst = $K_array[0];
$Klast = $K_array[-1];
$Klast_out = $Klast;
if ( defined($Kfirst) ) {
# 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 'send_lines_to_vertical_aligner'.
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';
}
}
}
}
# 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.
if ( defined($inext) ) {
Fault("unexpected tokens at end of file when reconstructing 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 );
# 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.
# Fixes cases b1021 b1023 b1034 b1048 b1049 b1050 b1056 b1058
if ( $rOpts_ignore_old_breakpoints && $rOpts_line_up_parentheses ) {
my %is_assignment_or_fat_comma = %is_assignment;
$is_assignment_or_fat_comma{'=>'} = 1;
my $ris_essential_old_breakpoint =
$self->[_ris_essential_old_breakpoint_];
my $iline = -1;
my ( $Kfirst, $Klast );
foreach my $line_of_tokens ( @{$rlines} ) {
$iline++;
my $line_type = $line_of_tokens->{_line_type};
if ( $line_type ne 'CODE' ) {
( $Kfirst, $Klast ) = ( undef, undef );
next;
}
my ( $Kfirst_prev, $Klast_prev ) = ( $Kfirst, $Klast );
( $Kfirst, $Klast ) = @{ $line_of_tokens->{_rK_range} };
next unless defined($Klast_prev);
next unless defined($Kfirst);
my $type_last = $rLL->[$Klast_prev]->[_TOKEN_];
my $type_first = $rLL->[$Kfirst]->[_TOKEN_];
next
unless ( $is_assignment_or_fat_comma{$type_last}
|| $is_assignment_or_fat_comma{$type_first} );
$ris_essential_old_breakpoint->{$Klast_prev} = 1;
}
}
return;
}
sub keep_old_line_breaks {
# 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 ($self) = @_;
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 $rwant_container_open = $self->[_rwant_container_open_];
my $K_opening_container = $self->[_K_opening_container_];
my $ris_broken_container = $self->[_ris_broken_container_];
my $ris_list_by_seqno = $self->[_ris_list_by_seqno_];
# This code moved here from sub scan_list 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 '->' ) {
$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
unless ( defined($Kn)
&& $Kn <= $Klast
&& $rLL->[$Kn]->[_TYPE_] eq '->' );
my $seqno = $rLL->[$Kfirst]->[_TYPE_SEQUENCE_];
next unless ($seqno);
# Patch to avoid blinkers: but do not do this unless the
# container holds a list, or the opening and closing parens are
# separated by more than one line.
# Fixes case b977.
next
if (
!$ris_list_by_seqno->{$seqno}
&& ( !$ris_broken_container->{$seqno}
|| $ris_broken_container->{$seqno} <= 1 )
);
$rwant_container_open->{$seqno} = 1;
}
}
}
return unless ( %keep_break_before_type || %keep_break_after_type );
foreach my $item ( @{$rKrange_code_without_comments} ) {
my ( $Kfirst, $Klast ) = @{$item};
my $type_first = $rLL->[$Kfirst]->[_TYPE_];
if ( $keep_break_before_type{$type_first} ) {
$rbreak_before_Kfirst->{$Kfirst} = 1;
}
my $type_last = $rLL->[$Klast]->[_TYPE_];
if ( $keep_break_after_type{$type_last} ) {
$rbreak_after_Klast->{$Klast} = 1;
}
}
return;
}
sub weld_containers {
# Called once per file to do any welding operations requested by --weld*
# flags.
my ($self) = @_;
# This count is used to eliminate needless calls for weld checks elsewere
$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;
# Note that 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");
}
$rweld_len_right_at_K->{$Kstart} =
$rLL->[$Kend]->[_CUMULATIVE_LENGTH_] -
$rLL->[$Kstart]->[_CUMULATIVE_LENGTH_];
$rK_weld_left->{$Kend} = $Kstart; # fix in case of missing left link
# 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;
}
}
# Update the end index and lengths of any long welds to extend to the far
# end. This has to be processed in sorted order.
# Left links added for b1173.
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 );
my @Klist;
push @Klist, $Kstart;
$Kend = $rK_weld_right->{$Kstart};
$rK_weld_left->{$Kend} = $Kstart;
my $Knext = $rK_weld_right->{$Kend};
while ( defined($Knext) ) {
push @Klist, $Kend;
$Kend = $Knext;
$rK_weld_left->{$Kend} = $Kstart;
$Knext = $rK_weld_right->{$Kend};
}
pop @Klist; # values for last entry are already correct
foreach my $KK (@Klist) {
# Ending indexes must only be shifted to the right for long welds.
# An error here would be due to a programming error introduced in
# the code immediately above.
my $Kend_old = $rK_weld_right->{$KK};
if ( !defined($Kend_old) || $Kend < $Kend_old ) {
Fault(
"Bad weld link at K=$KK, old end is K=$Kend_old, new end is $Kend\n"
);
}
$rK_weld_right->{$KK} = $Kend;
$rweld_len_right_at_K->{$KK} =
$rLL->[$Kend]->[_CUMULATIVE_LENGTH_] -
$rLL->[$KK]->[_CUMULATIVE_LENGTH_];
}
}
return;
}
sub cumulative_length_before_K {
my ( $self, $KK ) = @_;
my $rLL = $self->[_rLL_];
return ( $KK <= 0 ) ? 0 : $rLL->[ $KK - 1 ]->[_CUMULATIVE_LENGTH_];
}
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_];
# This routine implements the -cb flag by finding the appropriate
# closing and opening block braces and welding them together.
return unless ( %{$rcuddled_block_types} );
my $rLL = $self->[_rLL_];
return unless ( defined($rLL) && @{$rLL} );
my $rbreak_container = $self->[_rbreak_container_];
my $K_opening_container = $self->[_K_opening_container_];
my $K_closing_container = $self->[_K_closing_container_];
my $length_to_opening_seqno = sub {
my ($seqno) = @_;
my $KK = $K_opening_container->{$seqno};
my $lentot = $KK <= 0 ? 0 : $rLL->[ $KK - 1 ]->[_CUMULATIVE_LENGTH_];
return $lentot;
};
my $length_to_closing_seqno = sub {
my ($seqno) = @_;
my $KK = $K_closing_container->{$seqno};
my $lentot = $KK <= 0 ? 0 : $rLL->[ $KK - 1 ]->[_CUMULATIVE_LENGTH_];
return $lentot;
};
my $is_broken_block = sub {
# a block is broken if the input line numbers of the braces differ
# we can only cuddle between broken blocks
my ($seqno) = @_;
my $K_opening = $K_opening_container->{$seqno};
return unless ( defined($K_opening) );
my $K_closing = $K_closing_container->{$seqno};
return unless ( defined($K_closing) );
return $rbreak_container->{$seqno}
|| $rLL->[$K_closing]->[_LINE_INDEX_] !=
$rLL->[$K_opening]->[_LINE_INDEX_];
};
# A stack to remember open chains at all levels: 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;
my $KNEXT = $self->[_K_first_seq_item_];
while ( defined($KNEXT) ) {
my $KK = $KNEXT;
$KNEXT = $rLL->[$KNEXT]->[_KNEXT_SEQ_ITEM_];
my $rtoken_vars = $rLL->[$KK];
my $type_sequence = $rtoken_vars->[_TYPE_SEQUENCE_];
if ( !$type_sequence ) {
next if ( $KK == 0 ); # first token in file may not be container
# 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
# _KNEXT_SEQ_ITEM_. Or an error has been introduced in the
# loop control lines above.
Fault("sequence = $type_sequence not defined at K=$KK");
}
# 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 }
# We are only looking at code blocks
my $token = $rtoken_vars->[_TOKEN_];
my $type = $rtoken_vars->[_TYPE_];
next unless ( $type eq $token );
if ( $token eq '{' ) {
my $block_type = $rtoken_vars->[_BLOCK_TYPE_];
if ( !$block_type ) {
# patch for unrecognized block types which may not be labeled
my $Kp = $self->K_previous_nonblank($KK);
while ( $Kp && $rLL->[$Kp]->[_TYPE_] eq '#' ) {
$Kp = $self->K_previous_nonblank($Kp);
}
next unless $Kp;
$block_type = $rLL->[$Kp]->[_TOKEN_];
}
if ( $in_chain{$level} ) {
# we are in a chain and are at an opening block brace.
# See if we are welding this opening brace with the previous
# block brace. Get their identification numbers:
my $closing_seqno = $in_chain{$level}->[1];
my $opening_seqno = $type_sequence;
# The preceding block must be on multiple lines so that its
# closing brace will start a new line.
if ( !$is_broken_block->($closing_seqno) ) {
next unless ( $CBO == 2 );
$rbreak_container->{$closing_seqno} = 1;
}
# we will let the trailing block be either broken or intact
## && $is_broken_block->($opening_seqno);
# We can weld the closing brace to its following word ..
my $Ko = $K_closing_container->{$closing_seqno};
my $Kon;
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);
}
}
else {
# We are not in a chain. Start a new chain if we see the
# starting block type.
if ( $rcuddled_block_types->{$block_type} ) {
$in_chain{$level} = [ $block_type, $type_sequence ];
}
else {
$block_type = '*';
$in_chain{$level} = [ $block_type, $type_sequence ];
}
}
}
elsif ( $token eq '}' ) {
if ( $in_chain{$level} ) {
# We are in a chain at a closing brace. See if this chain
# continues..
my $Knn = $self->K_next_code($KK);
next unless $Knn;
my $chain_type = $in_chain{$level}->[0];
my $next_nonblank_token = $rLL->[$Knn]->[_TOKEN_];
if (
$rcuddled_block_types->{$chain_type}->{$next_nonblank_token}
)
{
# Note that we do not weld yet because we must wait until
# we we are sure that an opening brace for this follows.
$in_chain{$level}->[1] = $type_sequence;
}
else { $in_chain{$level} = undef }
}
}
}
return;
}
sub find_nested_pairs {
my $self = shift;
# 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.
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_];
# 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 unless ( $K_outer_closing < $Num );
my $outer_seqno = $rLL->[$K_outer_closing]->[_TYPE_SEQUENCE_];
next unless ($outer_seqno);
my $token_outer_closing = $rLL->[$K_outer_closing]->[_TOKEN_];
next unless ( $is_closing_token{$token_outer_closing} );
# 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 unless defined($K_outer_opening) && defined($K_inner_opening);
# Verify that the inner opening token is the next container after the
# outer opening token.
my $K_io_check = $rLL->[$K_outer_opening]->[_KNEXT_SEQ_ITEM_];
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 $rLL->[$K_inner_opening]->[_BLOCK_TYPE_] 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 = $rLL->[$K_signature_closing]->[_KNEXT_SEQ_ITEM_];
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 );
my $saw_comma;
foreach my $KK ( $K_io_check + 1 .. $K_signature_closing - 1 ) {
if ( $rLL->[$KK]->[_TYPE_] eq ',' ) { $saw_comma = 1; last }
}
next if ($saw_comma);
}
# 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 nonblank characters separating them.
if ( $K_diff < 0 ) { next } # Shouldn't happen
my $Kn = $K_outer_opening;
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;
for (
my $Kn = $K_outer_opening + 1 ;
$Kn <= $K_inner_opening ;
$Kn += 1
)
{
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_];
$is_name = $is_name_type->{$type};
next if ( $is_name && $last_is_name );
$nonblank_count++;
last if ( $nonblank_count > 2 );
}
# 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 }
}
if (
# adjacent opening containers, like: do {{
$nonblank_count == 1
# short item following opening paren, like: fun( yyy (
|| ( $nonblank_count == 2
&& $rLL->[$K_outer_opening]->[_TOKEN_] eq '(' )
# 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.
|| ( $rLL->[$K_inner_opening]->[_BLOCK_TYPE_] eq 'sub'
&& $rLL->[$Kn_first]->[_TOKEN_] eq 'sub'
&& !$rLL->[$K_outer_opening]->[_BLOCK_TYPE_] )
)
{
push @nested_pairs,
[ $inner_seqno, $outer_seqno, $K_inner_closing ];
}
next;
}
# 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;
}
sub is_excluded_weld {
# decide if this weld is excluded by user request
my ( $self, $KK, $is_leading ) = @_;
my $rLL = $self->[_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 ( $is_f, $is_k, $is_w );
my $Kp = $self->K_previous_nonblank($KK);
if ( defined($Kp) ) {
my $seqno = $rtoken_vars->[_TYPE_SEQUENCE_];
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 }
return $match;
}
# types needed for welding RULE 6
my %type_ok_after_bareword;
BEGIN {
my @q = qw# => -> { ( [ #;
@type_ok_after_bareword{@q} = (1) x scalar(@q);
}
use constant DEBUG_WELD => 0;
sub setup_new_weld_measurements {
# Define quantities to check for excess line lengths when welded.
# Called by sub 'weld_nested_containers' and sub 'weld_nested_quotes'
my ( $self, $Kouter_opening, $Kinner_opening ) = @_;
# Given indexes of outer and inner opening containers to be welded:
# $Kouter_opening, $Kinner_opening
# 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 $starting_level;
my $starting_ci;
my $starting_lentot;
my $maximum_text_length;
my $msg = "";
my $iline_oo = $rLL->[$Kouter_opening]->[_LINE_INDEX_];
my $rK_range = $rlines->[$iline_oo]->{_rK_range};
my ( $Kfirst, $Klast ) = @{$rK_range};
# Define a reference index from which to start measuring
my $Kref = $Kfirst;
my $Kprev = $self->K_previous_nonblank($Kfirst);
if ( defined($Kprev) ) {
# The -iob and -wn flags do not work well together. To avoid
# blinking states we have to override -iob at certain key line
# breaks.
$self->[_ris_essential_old_breakpoint_]->{$Kprev} = 1;
# 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
my $type_prev = $rLL->[$Kprev]->[_TYPE_];
if ( $rOpts_line_up_parentheses
|| $want_break_before{$type_prev} )
{
if ( 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 = $rlines->[$iline_prev]->{_rK_range};
my ( $Kfirst, $Klast ) = @{$rK_range};
for ( my $KK = $Kref - 1 ; $KK >= $Kfirst ; $KK-- ) {
next if ( $rLL->[$KK]->[_TYPE_] eq 'b' );
$Kref = $KK;
last;
}
}
}
}
}
# 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;
# Now fix these if necessary to avoid known problems...
# FIX1: 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;
# FIX2 for 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.
if ( $starting_ci
&& $rOpts_line_up_parentheses
&& $rOpts_delete_old_whitespace
&& !$rOpts_add_whitespace
&& 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_] }
unless (
$type_prev =~ /^[\,\.\;]/
|| $type_prev =~ /^[=\{\[\(\L]/ && $type_pp eq 'b'
|| $type_first =~ /^[=\,\.\;\{\[\(\L]/
|| $type_first eq '||'
|| ( $type_first eq 'k' && $token_first eq 'if'
|| $token_first eq 'or' )
)
{
$msg =
"Skipping weld: poor break with -lp and ci at type_first='$type_first' type_prev='$type_prev'\n";
$new_weld_ok = 0;
}
}
return ( $new_weld_ok, $maximum_text_length, $starting_lentot, $msg );
}
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);
}
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_];
# 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};
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 $multiline_tol =
1 + max( $rOpts_indent_columns, $rOpts_continuation_indentation );
my $length_to_opening_seqno = sub {
my ($seqno) = @_;
my $KK = $K_opening_container->{$seqno};
my $lentot = defined($KK)
&& $KK > 0 ? $rLL->[ $KK - 1 ]->[_CUMULATIVE_LENGTH_] : 0;
return $lentot;
};
my $length_to_closing_seqno = sub {
my ($seqno) = @_;
my $KK = $K_closing_container->{$seqno};
my $lentot = defined($KK)
&& $KK > 0 ? $rLL->[ $KK - 1 ]->[_CUMULATIVE_LENGTH_] : 0;
return $lentot;
};
# Abbreviations:
# _oo=outer opening, i.e. first of { {
# _io=inner opening, i.e. second of { {
# _oc=outer closing, i.e. second of } {
# _ic=inner closing, i.e. first of } }
my $previous_pair;
# 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 ( 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);
my $comma_count = $rtype_count->{','};
next unless ($comma_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' );
}
# 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 = "";
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 $is_multiline_weld =
$iline_oo == $iline_io
&& $iline_ic == $iline_oc
&& $iline_io != $iline_ic;
if (DEBUG_WELD) {
my $token_io = $rLL->[$Kinner_opening]->[_TOKEN_];
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;
( 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 $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, and
# This flag is used to avoid creating blinkers.
# FIX1: Changed 'excess_length_to_K' to 'excess_length_of_line'
# to get exact lengths and fix b604 b605.
if ( $iline_oo == $iline_oc ) {
# All the tokens are on one line, now check their length
my $excess =
$self->excess_line_length_for_Krange( $Kfirst, $Klast );
if ( $excess <= 0 ) {
# All tokens are on one line and fit. This is a valid
# existing one-line weld except for some edge cases
# involving -lp:
# FIX2: Patch for b1114: add a tolerance of one level if
# this line has an unbalanced start. This helps prevent
# blinkers in unusual cases for lines near the length limit
# by making it more likely that RULE 2 will prevent a weld.
# FIX3: for b1131: only use level difference in -lp mode.
# FIX4: for b1141, b1142: reduce the tolerance for longer
# leading tokens
if ( $rOpts_line_up_parentheses
&& $outer_opening->[_LEVEL_] -
$rLL->[$Kfirst]->[_LEVEL_] )
{
# We only need a tolerance if the leading text before
# the first opening token is shorter than the
# indentation length. For simplicity we just use the
# length of the first token here. If necessary, we
# could be more exact in the future and find the
# total length up to the first opening token.
# See cases b1114, b1141, b1142.
my $tolx = max( 0,
$rOpts_indent_columns -
$rLL->[$Kfirst]->[_TOKEN_LENGTH_] );
if ( $excess + $tolx <= 0 ) {
$is_one_line_weld = 1;
}
}
else {
$is_one_line_weld = 1;
}
}
}
# 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 = $inner_opening->[_KNEXT_SEQ_ITEM_];
if ( $Knext_seq_item == $Kinner_closing ) {
$do_not_weld_rule = 1;
}
}
}
} ## end starting new weld sequence
# 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 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
? 0
: $multiline_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 = $rLL->[$Kouter_opening]->[_BLOCK_TYPE_];
if ( $block_type && $rcuddled_block_types->{'*'}->{$block_type} ) {
my $io_line = $inner_opening->[_LINE_INDEX_];
my $ic_line = $inner_closing->[_LINE_INDEX_];
my $oo_line = $outer_opening->[_LINE_INDEX_];
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.
# DO-NOT-WELD RULE 7: Do not weld if this conflicts with -bom
# (case b973)
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 ) = @{$rK_range};
next unless defined($Kfirst);
if ( $rLL->[$Kfirst]->[_TYPE_] eq '->' ) {
$do_not_weld_rule = 7;
last;
}
}
}
if ($do_not_weld_rule) {
# After neglecting a pair, we start measuring from start of point io
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 $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 $Msg;
}
push @welds, $item;
$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 $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;
}
# After welding, reduce the indentation level if all intermediate tokens
my $dlevel = $outer_opening->[_LEVEL_] - $inner_opening->[_LEVEL_];
if ( $dlevel != 0 ) {
my $Kstart = $Kinner_opening;
my $Kstop = $Kinner_closing;
for ( my $KK = $Kstart ; $KK <= $Kstop ; $KK++ ) {
$rLL->[$KK]->[_LEVEL_] += $dlevel;
}
# Copy opening ci level to help break at = for -lp mode (case b1124)
$rLL->[$Kinner_opening]->[_CI_LEVEL_] =
$rLL->[$Kouter_opening]->[_CI_LEVEL_];
# But do not copy the closing ci level ... it can give poor results
## $rLL->[$Kinner_closing]->[_CI_LEVEL_] =
## $rLL->[$Kouter_closing]->[_CI_LEVEL_];
}
}
return;
}
sub weld_nested_quotes {
# Called once per file for option '--weld-nested-containers'. This
# does welding on qw quotes.
my $self = shift;
# See if quotes are excluded from welding
my $rflags = $weld_nested_exclusion_rules{'q'};
return if ( defined($rflags) && defined( $rflags->[1] ) );
my $rK_weld_left = $self->[_rK_weld_left_];
my $rK_weld_right = $self->[_rK_weld_right_];
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 $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;
};
# 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
my $KNEXT = $self->[_K_first_seq_item_];
while ( defined($KNEXT) ) {
my $KK = $KNEXT;
$KNEXT = $rLL->[$KNEXT]->[_KNEXT_SEQ_ITEM_];
my $rtoken_vars = $rLL->[$KK];
my $outer_seqno = $rtoken_vars->[_TYPE_SEQUENCE_];
if ( !$outer_seqno ) {
next if ( $KK == 0 ); # first token in file may not be container
# 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
# _KNEXT_SEQ_ITEM_. Or an error has been introduced in the
# loop control lines above.
Fault("sequence = $outer_seqno not defined at K=$KK");
}
my $token = $rtoken_vars->[_TOKEN_];
if ( $is_opening_token{$token} ) {
# see if the next token is a quote of some type
my $Kn = $KK + 1;
$Kn += 1
if ( $Kn < $Num && $rLL->[$Kn]->[_TYPE_] eq 'b' );
next unless ( $Kn < $Num );
my $next_token = $rLL->[$Kn]->[_TOKEN_];
my $next_type = $rLL->[$Kn]->[_TYPE_];
next
unless ( ( $next_type eq 'q' || $next_type eq 'Q' )
&& $next_token =~ /^q/ );
# The token before the closing container must also be a quote
my $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 );
# 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 = "";
my $do_not_weld;
my $Kouter_opening = $K_opening_container->{$outer_seqno};
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 );
# 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 $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 = "" }
$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( $KK, $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 ) = @{$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 $Msg;
}
next;
}
# OK to weld
if (DEBUG_WELD) {
$Msg .= "Welding QW\n";
print $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;
}
sub is_welded_right_at_i {
my ( $self, $i ) = @_;
return unless ( $total_weld_count && $i >= 0 );
# Back up at a blank. This routine is sometimes called at blanks.
# TODO: this routine can eventually be eliminated by setting the weld flags
# for all K indexes between the start and end of a weld, not just at
# sequenced items.
if ( $i > 0 && $types_to_go[$i] eq 'b' ) { $i-- }
return defined( $self->[_rK_weld_right_]->{ $K_to_go[$i] } );
}
sub is_welded_at_seqno {
my ( $self, $seqno ) = @_;
# given a sequence number:
# return true if it is welded either left or right
# return 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} );
}
sub mark_short_nested_blocks {
# This routine looks at the entire file and marks any short nested blocks
# which should not be broken. The results are stored in the hash
# $rshort_nested->{$type_sequence}
# which will be true if the container should remain intact.
#
# For example, consider the following line:
# sub cxt_two { sort { $a <=> $b } test_if_list() }
# The 'sort' block is short and nested within an outer sub block.
# Normally, the 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'
my $self = shift;
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 $rshort_nested = $self->[_rshort_nested_];
my $rlines = $self->[_rlines_];
# 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);
};
my $is_broken_block = sub {
# a block is broken if the input line numbers of the braces differ
my ($seqno) = @_;
my $K_opening = $K_opening_container->{$seqno};
return unless ( defined($K_opening) );
my $K_closing = $K_closing_container->{$seqno};
return unless ( defined($K_closing) );
return $rbreak_container->{$seqno}
|| $rLL->[$K_closing]->[_LINE_INDEX_] !=
$rLL->[$K_opening]->[_LINE_INDEX_];
};
# loop over all containers
my @open_block_stack;
my $iline = -1;
my $KNEXT = $self->[_K_first_seq_item_];
while ( defined($KNEXT) ) {
my $KK = $KNEXT;
$KNEXT = $rLL->[$KNEXT]->[_KNEXT_SEQ_ITEM_];
my $rtoken_vars = $rLL->[$KK];
my $type_sequence = $rtoken_vars->[_TYPE_SEQUENCE_];
if ( !$type_sequence ) {
next if ( $KK == 0 ); # first token in file may not be container
# 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
# _KNEXT_SEQ_ITEM_. Or an error has been introduced in the
# loop control lines above.
Fault("sequence = $type_sequence not defined at K=$KK");
}
# 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 );
my $block_type = $rtoken_vars->[_BLOCK_TYPE_];
next unless ($block_type);
# Keep a stack of all acceptable block braces seen.
# Only consider blocks entirely on one line so dump the stack when line
# changes.
my $iline_last = $iline;
$iline = $rLL->[$KK]->[_LINE_INDEX_];
if ( $iline != $iline_last ) { @open_block_stack = () }
if ( $token eq '}' ) {
if (@open_block_stack) { pop @open_block_stack }
}
next unless ( $token eq '{' );
# block must be balanced (bad scripts may be unbalanced)
my $K_opening = $K_opening_container->{$type_sequence};
my $K_closing = $K_closing_container->{$type_sequence};
next unless ( defined($K_opening) && defined($K_closing) );
# require that this block be entirely on one line
next if ( $is_broken_block->($type_sequence) );
# See if this block fits on one line of allowed length (which may
# be different from the input script)
$starting_lentot =
$KK <= 0 ? 0 : $rLL->[ $KK - 1 ]->[_CUMULATIVE_LENGTH_];
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 unless ( @open_block_stack > 1 );
# Looks OK, mark this as a short nested block
$rshort_nested->{$type_sequence} = 1;
}
return;
}
sub adjust_indentation_levels {
my ($self) = @_;
# Called once per file to do special indentation adjustments.
# These routines adjust levels either by changing _CI_LEVEL_ directly or
# by setting modified levels in the array $self->[_radjusted_levels_].
# Initialize the adjusted levels. These will be the levels actually used
# for computing indentation.
# NOTE: This routine is called after the weld routines, which may have
# already adjusted _LEVEL_, so we are making adjustments on top of those
# levels. It would be much nicer to have the weld routines also use this
# adjustment, but that gets complicated when we combine -gnu -wn and have
# some welded quotes.
my $radjusted_levels = $self->[_radjusted_levels_];
my $rLL = $self->[_rLL_];
foreach my $KK ( 0 .. @{$rLL} - 1 ) {
$radjusted_levels->[$KK] = $rLL->[$KK]->[_LEVEL_];
}
# First set adjusted levels for any non-indenting braces.
$self->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();
# Adjust continuation indentation if -bli is set
$self->bli_adjustment();
$self->extended_ci()
if ( $rOpts->{'extended-continuation-indentation'} );
# Now clip any adjusted levels to be non-negative
$self->clip_adjusted_levels();
return;
}
sub clip_adjusted_levels {
# Replace any negative adjusted levels with zero.
# Negative levels can occur in files with brace errors.
my ($self) = @_;
my $radjusted_levels = $self->[_radjusted_levels_];
return unless defined($radjusted_levels) && @{$radjusted_levels};
foreach ( @{$radjusted_levels} ) { $_ = 0 if ( $_ < 0 ) }
return;
}
sub non_indenting_braces {
# Called once per file to handle the --non-indenting-braces parameter.
# Remove indentation within marked braces if requested
my ($self) = @_;
return unless ( $rOpts->{'non-indenting-braces'} );
my $rLL = $self->[_rLL_];
return unless ( defined($rLL) && @{$rLL} );
my $rspecial_side_comment_type = $self->[_rspecial_side_comment_type_];
my $radjusted_levels = $self->[_radjusted_levels_];
my $Kmax = @{$rLL} - 1;
my @seqno_stack;
my $is_non_indenting_brace = sub {
my ($KK) = @_;
# looking for an opening block brace
my $token = $rLL->[$KK]->[_TOKEN_];
my $block_type = $rLL->[$KK]->[_BLOCK_TYPE_];
return unless ( $token eq '{' && $block_type );
# followed by a comment
my $K_sc = $KK + 1;
$K_sc += 1
if ( $K_sc <= $Kmax && $rLL->[$K_sc]->[_TYPE_] eq 'b' );
return unless ( $K_sc <= $Kmax );
my $type_sc = $rLL->[$K_sc]->[_TYPE_];
return unless ( $type_sc eq '#' );
# on the same line
my $line_index = $rLL->[$KK]->[_LINE_INDEX_];
my $line_index_sc = $rLL->[$K_sc]->[_LINE_INDEX_];
return unless ( $line_index_sc == $line_index );
# get the side comment text
my $token_sc = $rLL->[$K_sc]->[_TOKEN_];
# 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";
my $is_nib = ( $token_sc =~ /$non_indenting_brace_pattern/ );
if ($is_nib) { $rspecial_side_comment_type->{$K_sc} = 'NIB' }
return $is_nib;
};
foreach my $KK ( 0 .. $Kmax ) {
my $num = @seqno_stack;
my $seqno = $rLL->[$KK]->[_TYPE_SEQUENCE_];
if ($seqno) {
my $token = $rLL->[$KK]->[_TOKEN_];
if ( $token eq '{' && $is_non_indenting_brace->($KK) ) {
push @seqno_stack, $seqno;
}
if ( $token eq '}' && @seqno_stack && $seqno_stack[-1] == $seqno ) {
pop @seqno_stack;
$num -= 1;
}
}
next unless $num;
$radjusted_levels->[$KK] -= $num;
}
return;
}
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 $rOpts_whitespace_cycle = $rOpts->{'whitespace-cycle'};
if ( $rOpts_whitespace_cycle && $rOpts_whitespace_cycle > 0 ) {
my $Kmax = @{$rLL} - 1;
my $whitespace_last_level = -1;
my @whitespace_level_stack = ();
my $last_nonblank_type = 'b';
my $last_nonblank_token = '';
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;
}
elsif ( $level_abs > $whitespace_last_level ) {
$level = $whitespace_level_stack[-1] +
( $level_abs - $whitespace_last_level );
if (
# 1 Try to break at a block brace
(
$level > $rOpts_whitespace_cycle
&& $last_nonblank_type eq '{'
&& $last_nonblank_token eq '{'
)
# 2 Then either a brace or bracket
|| ( $level > $rOpts_whitespace_cycle + 1
&& $last_nonblank_token =~ /^[\{\[]$/ )
# 3 Then a paren too
|| $level > $rOpts_whitespace_cycle + 2
)
{
$level = 1;
}
push @whitespace_level_stack, $level;
}
$level = $whitespace_level_stack[-1];
$radjusted_levels->[$KK] = $level;
$whitespace_last_level = $level_abs;
my $type = $rLL->[$KK]->[_TYPE_];
my $token = $rLL->[$KK]->[_TOKEN_];
if ( $type ne 'b' ) {
$last_nonblank_type = $type;
$last_nonblank_token = $token;
}
}
}
return;
}
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 = $self->[_rhas_broken_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 $length_tol =
max( 1, $rOpts_continuation_indentation, $rOpts_indent_columns );
if ($rOpts_ignore_old_breakpoints) {
$length_tol += $rOpts_maximum_line_length;
}
my $rbreak_before_container_by_seqno = {};
my $rwant_reduced_ci = {};
foreach my $seqno ( keys %{$K_opening_container} ) {
#################################################################
# Part 1: Examine any -bbx=n flags
#################################################################
my $KK = $K_opening_container->{$seqno};
next if ( $rLL->[$KK]->[_BLOCK_TYPE_] );
# 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_broken_list = $rhas_broken_list->{$seqno};
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);
# 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_];
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 ) = @{$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 = "";
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;
}
}
# Patch to fix b1099 for -lp
# ok in -lp mode if this is a list which contains a list
if ( !$ok_to_break && $rOpts_line_up_parentheses ) {
if ( $is_list && $has_list ) {
$ok_to_break = 1;
DEBUG_BBX && do { $Msg = "is list or has list" };
}
}
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
}
# Shouldn't happen! Bad flag, but make behavior same as 3
else {
# ok to break
}
# Set a flag for actual implementation later in
# sub insert_breaks_before_list_opening_containers
$rbreak_before_container_by_seqno->{$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 set_adjusted_indentation
if ( $ci_flag == 1 ) {
$rwant_reduced_ci->{$seqno} = 1;
next;
}
# -bbxi=2 ...
#################################################################
# 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} );
# Always ok to change ci for permanently broken containers
if ( $ris_permanently_broken->{$seqno} ) {
goto OK;
}
# Always OK if this list contains a broken sub-container with
# a non-terminal line-ending comma
if ($has_list_with_lec) { goto OK }
# From here on we are considering a single container...
# A single container must have at least 1 line-ending comma:
next unless ( $rlec_count_by_seqno->{$seqno} );
# Since it has a line-ending comma, it will stay broken if the -boc
# flag is set
if ($rOpts_break_at_old_comma_breakpoints) { goto OK }
# OK if the container contains multiple fat commas
# Better: multiple lines with fat commas
if ( !$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 ) { goto OK }
}
# The last check we can make is to see if this container could fit on a
# single line. Use the least possble indentation in the estmate (ci=0),
# so we are not subtracting $ci * $rOpts_continuation_indentation from
# tablulated $maximum_text_length value.
my $level = $rLL->[$KK]->[_LEVEL_];
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 ) {
DEBUG_BBX
&& print STDOUT "BBX: excess_length=$excess_length\n";
goto OK;
}
# Otherwise skip it
next;
#################################################################
# Part 3: Looks OK: apply -bbx=n and any related -bbxi=n flag
#################################################################
OK:
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)
# n=3 indent one extra ci [This may be dropped]
# 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
}
$rLL->[$KK]->[_CI_LEVEL_] = $ci if ( $ci >= 0 );
}
$self->[_rbreak_before_container_by_seqno_] =
$rbreak_before_container_by_seqno;
$self->[_rwant_reduced_ci_] = $rwant_reduced_ci;
return;
}
use constant DEBUG_XCI => 0;
sub extended_ci {
# 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 ($self) = @_;
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 $rlines = $self->[_rlines_];
my $rno_xci_by_seqno = $self->[_rno_xci_by_seqno_];
my $ris_bli_container = $self->[_ris_bli_container_];
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 $ris_broken_container = $self->[_ris_broken_container_];
my @seqno_stack;
my $seqno_top;
my $KLAST;
my $KNEXT = $self->[_K_first_seq_item_];
# 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 misparsing 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;
while ( defined($KNEXT) ) {
# 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 $length = $rLL->[$KLAST]->[_CUMULATIVE_LENGTH_];
my $count = 0;
for ( my $Kt = $KLAST + 1 ; $Kt < $KNEXT ; $Kt++ ) {
# But do not include tokens which might exceed the line length
# and are not in a list.
# ... This fixes case b1031
my $length_before = $length;
$length = $rLL->[$Kt]->[_CUMULATIVE_LENGTH_];
if (
!$rLL->[$Kt]->[_CI_LEVEL_]
&& ( $is_list
|| $length - $length_before < $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;
}
$KLAST = $KNEXT;
my $KK = $KNEXT;
$KNEXT = $rLL->[$KNEXT]->[_KNEXT_SEQ_ITEM_];
my $seqno = $rLL->[$KK]->[_TYPE_SEQUENCE_];
my $K_opening = $K_opening_container->{$seqno};
# 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 = $rLL->[$KK]->[_BLOCK_TYPE_];
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
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;
}
# Skip if requested by -bbx to avoid blinkers
if ( $rno_xci_by_seqno->{$seqno} ) {
next;
}
# 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.
if ( $ris_bli_container->{$seqno} ) {
next;
}
# We are looking for opening container tokens with ci
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);
# 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;
# 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;
}
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 $ris_bli_container = $self->[_ris_bli_container_];
my $K_opening_container = $self->[_K_opening_container_];
my $KNEXT = $self->[_K_first_seq_item_];
while ( defined($KNEXT) ) {
my $KK = $KNEXT;
$KNEXT = $rLL->[$KNEXT]->[_KNEXT_SEQ_ITEM_];
my $block_type = $rLL->[$KK]->[_BLOCK_TYPE_];
if ( $block_type && $block_type =~ /$bli_pattern/ ) {
my $seqno = $rLL->[$KK]->[_TYPE_SEQUENCE_];
my $K_opening = $K_opening_container->{$seqno};
if ( defined($K_opening) ) {
if ( $KK eq $K_opening ) {
$rLL->[$KK]->[_CI_LEVEL_]++;
$ris_bli_container->{$seqno} = 1;
}
else {
$rLL->[$KK]->[_CI_LEVEL_] =
$rLL->[$K_opening]->[_CI_LEVEL_];
}
}
}
}
return;
}
sub find_multiline_qw {
my $self = shift;
# 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 and 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.
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 $rlines = $self->[_rlines_];
my $rLL = $self->[_rLL_];
my $qw_seqno;
my $num_qw_seqno = 0;
my $K_start_multiline_qw;
foreach my $line_of_tokens ( @{$rlines} ) {
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
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;
}
}
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'} ) {
while ( my ( $qw_seqno, $rKrange ) =
each %{$rKrange_multiline_qw_by_seqno} )
{
my ( $Kbeg, $Kend ) = @{$rKrange};
# require isolated closing token
my $token_end = $rLL->[$Kend]->[_TOKEN_];
next
unless ( length($token_end) == 1
&& ( $is_closing_token{$token_end} || $token_end eq '>' ) );
# 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 ) eq ' ' ) {
$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} = 1;
}
}
# For the -lp option we need to mark all parent containers of
# multiline quotes
if ($rOpts_line_up_parentheses) {
while ( my ( $qw_seqno, $rKrange ) =
each %{$rKrange_multiline_qw_by_seqno} )
{
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
while (1) {
$parent_seqno = $self->[_rparent_of_seqno_]->{$parent_seqno};
last
unless ( defined($parent_seqno)
&& $parent_seqno ne SEQ_ROOT );
$ris_excluded_lp_container->{$parent_seqno} = 1;
}
}
}
$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;
}
sub is_excluded_lp {
# decide if this container is excluded by user request
# returns true if this token is excluded (i.e., may not use -lp)
# returns false otherwise
# note similarity with sub 'is_excluded_weld'
my ( $self, $KK ) = @_;
my $rLL = $self->[_rLL_];
my $rtoken_vars = $rLL->[$KK];
my $token = $rtoken_vars->[_TOKEN_];
my $rflags = $line_up_parentheses_exclusion_rules{$token};
return 0 unless ( defined($rflags) );
my ( $flag1, $flag2 ) = @{$rflags};
# There are two flags:
# flag1 excludes based on the preceding nonblank word
# flag2 excludes based on the contents of the container
return 0 unless ( defined($flag1) );
return 1 if $flag1 eq '*';
# 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 exclusion based on flag1 and the previous token:
my $match;
if ( $flag1 eq 'k' ) { $match = $is_k }
elsif ( $flag1 eq 'K' ) { $match = !$is_k }
elsif ( $flag1 eq 'f' ) { $match = $is_f }
elsif ( $flag1 eq 'F' ) { $match = !$is_f }
elsif ( $flag1 eq 'w' ) { $match = $is_w }
elsif ( $flag1 eq 'W' ) { $match = !$is_w }
return $match if ($match);
# Check for exclusion based on flag2 and the container contents
# Current options to filter on contents:
# 0 or blank: ignore container contents
# 1 exclude non-lists or lists with sublists
# 2 same as 1 but also exclude lists with code blocks
# Note:
# Containers with multiline-qw containers are automatically
# excluded so do not need to be checked.
if ($flag2) {
my $seqno = $rtoken_vars->[_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 = 1;
}
}
return $match;
}
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_];
foreach my $seqno ( keys %{$K_opening_container} ) {
my $KK = $K_opening_container->{$seqno};
next unless defined($KK);
# code blocks are always excluded by the -lp coding so we can skip them
next if ( $rLL->[$KK]->[_BLOCK_TYPE_] );
# 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;
}
######################################
# CODE SECTION 6: Process line-by-line
######################################
sub process_all_lines {
# Main loop over all lines of a file.
# Lines are processed according to type.
my $self = shift;
my $rlines = $self->[_rlines_];
my $sink_object = $self->[_sink_object_];
my $fh_tee = $self->[_fh_tee_];
my $rOpts_keep_old_blank_lines = $rOpts->{'keep-old-blank-lines'};
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_];
# Note for RT#118553, leave only one newline at the end of a file.
# Example code to do this is in comments below:
# my $Opt_trim_ending_blank_lines = 0;
# if ($Opt_trim_ending_blank_lines) {
# while ( my $line_of_tokens = pop @{$rlines} ) {
# my $line_type = $line_of_tokens->{_line_type};
# if ( $line_type eq 'CODE' ) {
# my $CODE_type = $line_of_tokens->{_code_type};
# next if ( $CODE_type eq 'BL' );
# }
# push @{$rlines}, $line_of_tokens;
# last;
# }
# }
# But while this would be a trivial update, it would have very undesirable
# side effects when perltidy is run from within an editor on a small snippet.
# So this is best done with a separate filter, such
# as 'delete_ending_blank_lines.pl' in the examples folder.
# Flag to prevent blank lines when POD occurs in a format skipping sect.
my $in_format_skipping_section;
# set locations for blanks around long runs of keywords
my $rwant_blank_line_after = $self->keyword_group_scan();
my $line_type = "";
my $i_last_POD_END = -10;
my $i = -1;
foreach my $line_of_tokens ( @{$rlines} ) {
$i++;
# insert blank lines requested for keyword sequences
if ( $i > 0
&& defined( $rwant_blank_line_after->{ $i - 1 } )
&& $rwant_blank_line_after->{ $i - 1 } == 1 )
{
$self->want_blank_line();
}
my $last_line_type = $line_type;
$line_type = $line_of_tokens->{_line_type};
my $input_line = $line_of_tokens->{_line_text};
# _line_type codes are:
# SYSTEM - system-specific code before hash-bang line
# CODE - line of perl code (including comments)
# POD_START - line starting pod, such as '=head'
# POD - pod documentation text
# POD_END - last line of pod section, '=cut'
# HERE - text of here-document
# HERE_END - last line of here-doc (target word)
# FORMAT - format section
# FORMAT_END - last line of format section, '.'
# DATA_START - __DATA__ line
# DATA - unidentified text following __DATA__
# END_START - __END__ line
# END - unidentified text following __END__
# ERROR - we are in big trouble, probably not a perl script
# put a blank line after an =cut which comes before __END__ and __DATA__
# (required by podchecker)
if ( $last_line_type eq 'POD_END' && !$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 ) {
$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'} ) { $input_line =~ s/\s+$// }
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;
}
# write unindented non-code line
if ( !$skip_line ) {
$self->write_unindented_line($input_line);
}
}
}
return;
} ## end sub process_all_lines
sub keyword_group_scan {
my $self = shift;
# Called once per file to process the --keyword-group-blanks-* parameters.
# Manipulate blank lines around keyword groups (kgb* flags)
# Scan all lines looking for runs of consecutive lines beginning with
# selected keywords. Example keywords are 'my', 'our', 'local', ... but
# they may be anything. We will set flags requesting that blanks be
# inserted around and within them according to input parameters. Note
# that we are scanning the lines as they came in in the input stream, so
# they are not necessarily well formatted.
# The output of this sub is a return hash ref whose keys are the indexes of
# lines after which we desire a blank line. For line index i:
# $rhash_of_desires->{$i} = 1 means we want a blank line AFTER line $i
# $rhash_of_desires->{$i} = 2 means we want blank line $i removed
my $rhash_of_desires = {};
# 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;
}
my $Opt_blanks_before = $rOpts->{'keyword-group-blanks-before'}; # '-kgbb'
my $Opt_blanks_after = $rOpts->{'keyword-group-blanks-after'}; # '-kgba'
my $Opt_blanks_inside = $rOpts->{'keyword-group-blanks-inside'}; # '-kgbi'
my $Opt_blanks_delete = $rOpts->{'keyword-group-blanks-delete'}; # '-kgbd'
my $Opt_size = $rOpts->{'keyword-group-blanks-size'}; # '-kgbs'
# A range of sizes can be input with decimal notation like 'min.max' with
# any number of dots between the two numbers. Examples:
# string => min max matches
# 1.1 1 1 exactly 1
# 1.3 1 3 1,2, or 3
# 1..3 1 3 1,2, or 3
# 5 5 - 5 or more
# 6. 6 - 6 or more
# .2 - 2 up to 2
# 1.0 1 0 nothing
my ( $Opt_size_min, $Opt_size_max ) = split /\.+/, $Opt_size;
if ( $Opt_size_min && $Opt_size_min !~ /^\d+$/
|| $Opt_size_max && $Opt_size_max !~ /^\d+$/ )
{
Warn(<{'keyword-group-blanks-size'} = "";
return $rhash_of_desires;
}
$Opt_size_min = 1 unless ($Opt_size_min);
if ( $Opt_size_max && $Opt_size_max < $Opt_size_min ) {
return $rhash_of_desires;
}
# codes for $Opt_blanks_before and $Opt_blanks_after:
# 0 = never (delete if exist)
# 1 = stable (keep unchanged)
# 2 = always (insert if missing)
return $rhash_of_desires
unless $Opt_size_min > 0
&& ( $Opt_blanks_before != 1
|| $Opt_blanks_after != 1
|| $Opt_blanks_inside
|| $Opt_blanks_delete );
my $Opt_pattern = $keyword_group_list_pattern;
my $Opt_comment_pattern = $keyword_group_list_comment_pattern;
my $Opt_repeat_count =
$rOpts->{'keyword-group-blanks-repeat-count'}; # '-kgbr'
my $rlines = $self->[_rlines_];
my $rLL = $self->[_rLL_];
my $K_closing_container = $self->[_K_closing_container_];
# variables for the current group and subgroups:
my ( $ibeg, $iend, $count, $level_beg, $K_closing, @iblanks, @group,
@subgroup );
# Definitions:
# ($ibeg, $iend) = starting and ending line indexes of this entire group
# $count = total number of keywords seen in this entire group
# $level_beg = indententation level of this group
# @group = [ $i, $token, $count ] =list of all keywords & blanks
# @subgroup = $j, index of group where token changes
# @iblanks = line indexes of blank lines in input stream in this group
# where i=starting line index
# token (the keyword)
# count = number of this token in this subgroup
# j = index in group where token changes
#
# These vars will contain values for the most recently seen line:
my ( $line_type, $CODE_type, $K_first, $K_last );
my $number_of_groups_seen = 0;
####################
# helper subroutines
####################
my $insert_blank_after = sub {
my ($i) = @_;
$rhash_of_desires->{$i} = 1;
my $ip = $i + 1;
if ( defined( $rhash_of_desires->{$ip} )
&& $rhash_of_desires->{$ip} == 2 )
{
$rhash_of_desires->{$ip} = 0;
}
return;
};
my $split_into_sub_groups = sub {
# place blanks around long sub-groups of keywords
# ...if requested
return unless ($Opt_blanks_inside);
# loop over sub-groups, index k
push @subgroup, scalar @group;
my $kbeg = 1;
my $kend = @subgroup - 1;
for ( my $k = $kbeg ; $k <= $kend ; $k++ ) {
# index j runs through all keywords found
my $j_b = $subgroup[ $k - 1 ];
my $j_e = $subgroup[$k] - 1;
# index i is the actual line number of a keyword
my ( $i_b, $tok_b, $count_b ) = @{ $group[$j_b] };
my ( $i_e, $tok_e, $count_e ) = @{ $group[$j_e] };
my $num = $count_e - $count_b + 1;
# This subgroup runs from line $ib to line $ie-1, but may contain
# blank lines
if ( $num >= $Opt_size_min ) {
# if there are blank lines, we require that at least $num lines
# be non-blank up to the boundary with the next subgroup.
my $nog_b = my $nog_e = 1;
if ( @iblanks && !$Opt_blanks_delete ) {
my $j_bb = $j_b + $num - 1;
my ( $i_bb, $tok_bb, $count_bb ) = @{ $group[$j_bb] };
$nog_b = $count_bb - $count_b + 1 == $num;
my $j_ee = $j_e - ( $num - 1 );
my ( $i_ee, $tok_ee, $count_ee ) = @{ $group[$j_ee] };
$nog_e = $count_e - $count_ee + 1 == $num;
}
if ( $nog_b && $k > $kbeg ) {
$insert_blank_after->( $i_b - 1 );
}
if ( $nog_e && $k < $kend ) {
my ( $i_ep, $tok_ep, $count_ep ) = @{ $group[ $j_e + 1 ] };
$insert_blank_after->( $i_ep - 1 );
}
}
}
};
my $delete_if_blank = sub {
my ($i) = @_;
# delete line $i if it is blank
return unless ( $i >= 0 && $i < @{$rlines} );
my $line_type = $rlines->[$i]->{_line_type};
return if ( $line_type ne 'CODE' );
my $code_type = $rlines->[$i]->{_code_type};
if ( $code_type eq 'BL' ) { $rhash_of_desires->{$i} = 2; }
return;
};
my $delete_inner_blank_lines = sub {
# always remove unwanted trailing blank lines from our list
return unless (@iblanks);
while ( my $ibl = pop(@iblanks) ) {
if ( $ibl < $iend ) { push @iblanks, $ibl; last }
$iend = $ibl;
}
# now mark mark interior blank lines for deletion if requested
return unless ($Opt_blanks_delete);
while ( my $ibl = pop(@iblanks) ) { $rhash_of_desires->{$ibl} = 2 }
};
my $end_group = sub {
# end a group of keywords
my ($bad_ending) = @_;
if ( defined($ibeg) && $ibeg >= 0 ) {
# then handle sufficiently large groups
if ( $count >= $Opt_size_min ) {
$number_of_groups_seen++;
# do any blank deletions regardless of the count
$delete_inner_blank_lines->();
if ( $ibeg > 0 ) {
my $code_type = $rlines->[ $ibeg - 1 ]->{_code_type};
# patch for hash bang line which is not currently marked as
# a comment; mark it as a comment
if ( $ibeg == 1 && !$code_type ) {
my $line_text = $rlines->[ $ibeg - 1 ]->{_line_text};
$code_type = 'BC'
if ( $line_text && $line_text =~ /^#/ );
}
# Do not insert a blank after a comment
# (this could be subject to a flag in the future)
if ( $code_type !~ /(BC|SBC|SBCX)/ ) {
if ( $Opt_blanks_before == INSERT ) {
$insert_blank_after->( $ibeg - 1 );
}
elsif ( $Opt_blanks_before == DELETE ) {
$delete_if_blank->( $ibeg - 1 );
}
}
}
# We will only put blanks before code lines. We could loosen
# this rule a little, but we have to be very careful because
# for example we certainly don't want to drop a blank line
# after a line like this:
# my $var = <[$K_first]->[_LEVEL_];
my $ci_level = $rLL->[$K_first]->[_CI_LEVEL_];
if ( $level == $level_beg
&& $ci_level == 0
&& !$bad_ending
&& $iend < @{$rlines}
&& $CODE_type ne 'HSC' )
{
if ( $Opt_blanks_after == INSERT ) {
$insert_blank_after->($iend);
}
elsif ( $Opt_blanks_after == DELETE ) {
$delete_if_blank->( $iend + 1 );
}
}
}
}
$split_into_sub_groups->();
}
# reset for another group
$ibeg = -1;
$iend = undef;
$level_beg = -1;
$K_closing = undef;
@group = ();
@subgroup = ();
@iblanks = ();
};
my $find_container_end = sub {
# If the keyword lines ends with an open token, find the closing token
# '$K_closing' so that we can easily skip past the contents of the
# container.
return if ( $K_last <= $K_first );
my $KK = $K_last;
my $type_last = $rLL->[$KK]->[_TYPE_];
my $tok_last = $rLL->[$KK]->[_TOKEN_];
if ( $type_last eq '#' ) {
$KK = $self->K_previous_nonblank($KK);
$tok_last = $rLL->[$KK]->[_TOKEN_];
}
if ( $KK > $K_first && $tok_last =~ /^[\(\{\[]$/ ) {
my $type_sequence = $rLL->[$KK]->[_TYPE_SEQUENCE_];
my $lev = $rLL->[$KK]->[_LEVEL_];
if ( $lev == $level_beg ) {
$K_closing = $K_closing_container->{$type_sequence};
}
}
};
my $add_to_group = sub {
my ( $i, $token, $level ) = @_;
# End the previous group if we have reached the maximum
# group size
if ( $Opt_size_max && @group >= $Opt_size_max ) {
$end_group->();
}
if ( @group == 0 ) {
$ibeg = $i;
$level_beg = $level;
$count = 0;
}
$count++;
$iend = $i;
# New sub-group?
if ( !@group || $token ne $group[-1]->[1] ) {
push @subgroup, scalar(@group);
}
push @group, [ $i, $token, $count ];
# remember if this line ends in an open container
$find_container_end->();
return;
};
###################################
# loop over all lines of the source
###################################
$end_group->();
my $i = -1;
foreach my $line_of_tokens ( @{$rlines} ) {
$i++;
last
if ( $Opt_repeat_count > 0
&& $number_of_groups_seen >= $Opt_repeat_count );
$CODE_type = "";
$K_first = undef;
$K_last = undef;
$line_type = $line_of_tokens->{_line_type};
# always end a group at non-CODE
if ( $line_type ne 'CODE' ) { $end_group->(); next }
$CODE_type = $line_of_tokens->{_code_type};
# end any group at a format skipping line
if ( $CODE_type && $CODE_type eq 'FS' ) {
$end_group->();
next;
}
# continue in a verbatim (VB) type; it may be quoted text
if ( $CODE_type eq 'VB' ) {
if ( $ibeg >= 0 ) { $iend = $i; }
next;
}
# and continue in blank (BL) types
if ( $CODE_type eq 'BL' ) {
if ( $ibeg >= 0 ) {
$iend = $i;
push @{iblanks}, $i;
# propagate current subgroup token
my $tok = $group[-1]->[1];
push @group, [ $i, $tok, $count ];
}
next;
}
# examine the first token of this line
my $rK_range = $line_of_tokens->{_rK_range};
( $K_first, $K_last ) = @{$rK_range};
if ( !defined($K_first) ) {
# 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;
}
# This is not for keywords in lists ( keyword 'my' can occur in lists,
# see case b760)
next if ( $self->is_list_by_K($K_first) );
my $level = $rLL->[$K_first]->[_LEVEL_];
my $type = $rLL->[$K_first]->[_TYPE_];
my $token = $rLL->[$K_first]->[_TOKEN_];
my $ci_level = $rLL->[$K_first]->[_CI_LEVEL_];
# see if this is a code type we seek (i.e. comment)
if ( $CODE_type
&& $Opt_comment_pattern
&& $CODE_type =~ /$Opt_comment_pattern/ )
{
my $tok = $CODE_type;
# Continuing a group
if ( $ibeg >= 0 && $level == $level_beg ) {
$add_to_group->( $i, $tok, $level );
}
# Start new group
else {
# first end old group if any; we might be starting new
# keywords at different level
if ( $ibeg > 0 ) { $end_group->(); }
$add_to_group->( $i, $tok, $level );
}
next;
}
# See if it is a keyword we seek, but never start a group in a
# continuation line; the code may be badly formatted.
if ( $ci_level == 0
&& $type eq 'k'
&& $token =~ /$Opt_pattern/ )
{
# Continuing a keyword group
if ( $ibeg >= 0 && $level == $level_beg ) {
$add_to_group->( $i, $token, $level );
}
# Start new keyword group
else {
# first end old group if any; we might be starting new
# keywords at different level
if ( $ibeg > 0 ) { $end_group->(); }
$add_to_group->( $i, $token, $level );
}
next;
}
# This is not one of our keywords, but we are in a keyword group
# so see if we should continue or quit
elsif ( $ibeg >= 0 ) {
# - bail out on a large level change; we may have walked into a
# data structure or anoymous sub code.
if ( $level > $level_beg + 1 || $level < $level_beg ) {
$end_group->();
next;
}
# - keep going on a continuation line of the same level, since
# it is probably a continuation of our previous keyword,
# - and keep going past hanging side comments because we never
# want to interrupt them.
if ( ( ( $level == $level_beg ) && $ci_level > 0 )
|| $CODE_type eq 'HSC' )
{
$iend = $i;
next;
}
# - continue if if we are within in a container which started with
# the line of the previous keyword.
if ( defined($K_closing) && $K_first <= $K_closing ) {
# continue if entire line is within container
if ( $K_last <= $K_closing ) { $iend = $i; next }
# continue at ); or }; or ];
my $KK = $K_closing + 1;
if ( $rLL->[$KK]->[_TYPE_] eq ';' ) {
if ( $KK < $K_last ) {
if ( $rLL->[ ++$KK ]->[_TYPE_] eq 'b' ) { ++$KK }
if ( $KK > $K_last || $rLL->[$KK]->[_TYPE_] ne '#' ) {
$end_group->(1);
next;
}
}
$iend = $i;
next;
}
$end_group->(1);
next;
}
# - end the group if none of the above
$end_group->();
next;
}
# not in a keyword group; continue
else { next }
}
# end of loop over all lines
$end_group->();
return $rhash_of_desires;
} ## end sub 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 $side_comment_follows;
my $CODE_type;
# range of K of tokens for the current line
my ( $K_first, $K_last );
my ( $rLL, $radjusted_levels );
# past stored nonblank tokens
my (
$last_last_nonblank_token, $last_last_nonblank_type,
$last_nonblank_token, $last_nonblank_type,
$last_nonblank_block_type, $K_last_nonblank_code,
$K_last_last_nonblank_code, $looking_for_else,
$is_static_block_comment, $batch_CODE_type,
$last_line_had_side_comment,
);
# Called once at the start of a new file
sub initialize_process_line_of_CODE {
$last_nonblank_token = ';';
$last_nonblank_type = ';';
$last_last_nonblank_token = ';';
$last_last_nonblank_type = ';';
$last_nonblank_block_type = "";
$K_last_nonblank_code = undef;
$K_last_last_nonblank_code = undef;
$looking_for_else = 0;
$is_static_block_comment = 0;
$batch_CODE_type = "";
$last_line_had_side_comment = 0;
return;
}
# 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,
$semicolons_before_block_self_destruct,
$starting_in_quote, $ending_in_quote, );
# Called before the start of each new batch
sub initialize_batch_variables {
$max_index_to_go = UNDEFINED_INDEX;
@summed_lengths_to_go = @nesting_depth_to_go = (0);
# 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.
# So 'long story short': this is a waste of time
0 && do { #<<<
@block_type_to_go = ();
@type_sequence_to_go = ();
@bond_strength_to_go = ();
@forced_breakpoint_to_go = ();
@token_lengths_to_go = ();
@levels_to_go = ();
@mate_index_to_go = ();
@ci_levels_to_go = ();
@nobreak_to_go = ();
@old_breakpoint_to_go = ();
@tokens_to_go = ();
@K_to_go = ();
@types_to_go = ();
@leading_spaces_to_go = ();
@reduced_spaces_to_go = ();
@inext_to_go = ();
@iprev_to_go = ();
@parent_seqno_to_go = ();
};
$rbrace_follower = undef;
$ending_in_quote = 0;
destroy_one_line_block();
return;
}
sub leading_spaces_to_go {
# return the number of indentation spaces for a token in the output
# stream; these were previously stored by 'set_leading_whitespace'.
my ($ii) = @_;
return 0 if ( $ii < 0 );
my $indentation = $leading_spaces_to_go[$ii];
return ref($indentation) ? $indentation->get_spaces() : $indentation;
}
sub create_one_line_block {
( $index_start_one_line_block, $semicolons_before_block_self_destruct )
= @_;
return;
}
sub destroy_one_line_block {
$index_start_one_line_block = UNDEFINED_INDEX;
$semicolons_before_block_self_destruct = 0;
return;
}
# Routine to place the current token into the output stream.
# Called once per output token.
use constant DEBUG_STORE => 0;
sub store_token_to_go {
my ( $self, $Ktoken_vars, $rtoken_vars ) = @_;
# Add one token to the next batch.
# $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: This routine needs to be coded efficiently because it is called
# once per token. I have gotten it down from the second slowest to the
# eighth slowest, but that still seems rather slow for what it does.
# This closure variable has already been defined, for efficiency:
# my $radjusted_levels = $self->[_radjusted_levels_];
my $type = $rtoken_vars->[_TYPE_];
# 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 ) {
my $Klast = $K_to_go[$max_index_to_go];
if ( $Ktoken_vars != $Klast + 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' ) {
return;
}
}
# Do not start a batch with a blank token.
# Fixes cases b149 b888 b984 b985 b986 b987
else {
if ( $type eq 'b' ) { return }
}
++$max_index_to_go;
$batch_CODE_type = $CODE_type;
$K_to_go[$max_index_to_go] = $Ktoken_vars;
$types_to_go[$max_index_to_go] = $type;
$old_breakpoint_to_go[$max_index_to_go] = 0;
$forced_breakpoint_to_go[$max_index_to_go] = 0;
$mate_index_to_go[$max_index_to_go] = -1;
my $token = $tokens_to_go[$max_index_to_go] = $rtoken_vars->[_TOKEN_];
my $ci_level = $ci_levels_to_go[$max_index_to_go] =
$rtoken_vars->[_CI_LEVEL_];
# Clip levels to zero if there are level errors in the file.
# We had to wait until now for reasons explained in sub 'write_line'.
my $level = $rtoken_vars->[_LEVEL_];
if ( $level < 0 ) { $level = 0 }
$levels_to_go[$max_index_to_go] = $level;
$nesting_depth_to_go[$max_index_to_go] = $rtoken_vars->[_SLEVEL_];
$block_type_to_go[$max_index_to_go] = $rtoken_vars->[_BLOCK_TYPE_];
$type_sequence_to_go[$max_index_to_go] =
$rtoken_vars->[_TYPE_SEQUENCE_];
$nobreak_to_go[$max_index_to_go] =
$side_comment_follows ? 2 : $no_internal_newlines;
my $length = $rtoken_vars->[_TOKEN_LENGTH_];
# Safety check that length is defined. Should not be needed now.
# Former patch for indent-only, in which the entire set of tokens is
# turned into type 'q'. Lengths may have not been defined because sub
# 'respace_tokens' is bypassed. We do not need lengths in this case,
# but we will use the character count to have a defined value. In the
# future, it would be nicer to have 'respace_tokens' convert the lines
# to quotes and get correct lengths.
if ( !defined($length) ) { $length = length($token) }
$token_lengths_to_go[$max_index_to_go] = $length;
# We keep a running sum of token lengths from the start of this batch:
# summed_lengths_to_go[$i] = total length to just before token $i
# summed_lengths_to_go[$i+1] = total length to just after token $i
$summed_lengths_to_go[ $max_index_to_go + 1 ] =
$summed_lengths_to_go[$max_index_to_go] + $length;
my $in_continued_quote =
( $Ktoken_vars == $K_first ) && $line_of_tokens->{_starting_in_quote};
if ( $max_index_to_go == 0 ) {
$starting_in_quote = $in_continued_quote;
}
# Define the indentation that this token will have in two cases:
# Without CI = reduced_spaces_to_go
# With CI = leading_spaces_to_go
if ($in_continued_quote) {
$leading_spaces_to_go[$max_index_to_go] = 0;
$reduced_spaces_to_go[$max_index_to_go] = 0;
}
else {
$reduced_spaces_to_go[$max_index_to_go] = my $reduced_spaces =
$rOpts_indent_columns * $radjusted_levels->[$Ktoken_vars];
$leading_spaces_to_go[$max_index_to_go] =
$reduced_spaces + $rOpts_continuation_indentation * $ci_level;
}
# Correct these values if -lp is used
if ($rOpts_line_up_parentheses) {
$self->set_leading_whitespace( $Ktoken_vars, $K_last_nonblank_code,
$K_last_last_nonblank_code, $level, $ci_level,
$in_continued_quote );
}
DEBUG_STORE && do {
my ( $a, $b, $c ) = caller();
print STDOUT
"STORE: from $a $c: storing token $token type $type lev=$level at $max_index_to_go\n";
};
return;
}
sub flush_batch_of_CODE {
# Finish any batch packaging and call the process routine.
# This must be the only call to grind_batch_of_CODE()
my ($self) = @_;
return unless ( $max_index_to_go >= 0 );
# Create an array to hold variables for this batch
my $this_batch = [];
$this_batch->[_starting_in_quote_] = $starting_in_quote;
$this_batch->[_ending_in_quote_] = $ending_in_quote;
$this_batch->[_max_index_to_go_] = $max_index_to_go;
$this_batch->[_rK_to_go_] = \@K_to_go;
$this_batch->[_batch_CODE_type_] = $batch_CODE_type;
# The flag $is_static_block_comment applies to the line which just
# arrived. So it only applies if we are outputting that line.
$this_batch->[_is_static_block_comment_] =
defined($K_first)
&& $max_index_to_go == 0
&& $K_to_go[0] == $K_first ? $is_static_block_comment : 0;
$self->[_this_batch_] = $this_batch;
$last_line_had_side_comment =
$max_index_to_go > 0 && $types_to_go[$max_index_to_go] eq '#';
$self->grind_batch_of_CODE();
# Done .. this batch is history
$self->[_this_batch_] = [];
initialize_batch_variables();
initialize_forced_breakpoint_vars();
initialize_gnu_batch_vars()
if $rOpts_line_up_parentheses;
return;
}
sub end_batch {
# end the current batch, EXCEPT for a few special cases
my ($self) = @_;
# Exception 1: Do not end line in a weld
return
if ( $total_weld_count
&& $self->is_welded_right_at_i($max_index_to_go) );
# Exception 2: just set a tentative breakpoint if we might be in a
# one-line block
if ( $index_start_one_line_block != UNDEFINED_INDEX ) {
$self->set_forced_breakpoint($max_index_to_go);
return;
}
$self->flush_batch_of_CODE();
return;
}
sub flush_vertical_aligner {
my ($self) = @_;
my $vao = $self->[_vertical_aligner_object_];
$vao->flush();
return;
}
# flush is called to output any tokens in the pipeline, so that
# an alternate source of lines can be written in the correct order
sub flush {
my ( $self, $CODE_type ) = @_;
# end the current batch with 1 exception
destroy_one_line_block();
# Exception: if we are flushing within the code stream only to insert
# blank line(s), then we can keep the batch intact at a weld. This
# improves formatting of -ce. See test 'ce1.ce'
if ( $CODE_type && $CODE_type eq 'BL' ) { $self->end_batch() }
# otherwise, we have to shut things down completely.
else { $self->flush_batch_of_CODE() }
$self->flush_vertical_aligner();
return;
}
sub process_line_of_CODE {
my ( $self, $my_line_of_tokens ) = @_;
# This routine is called once per INPUT line to process all of the
# tokens on that line.
# It outputs full-line comments and blank lines immediately.
# The tokens are copied one-by-one from the global token array $rLL to
# a set of '_to_go' arrays which collect batches of tokens for a
# further processing via calls to 'sub store_token_to_go', until a well
# defined 'structural' break point* or 'forced' breakpoint* is reached.
# Then, the batch of collected '_to_go' tokens is passed along to 'sub
# grind_batch_of_CODE' for further processing.
# * 'structural' break points are basically line breaks corresponding
# to code blocks. An example is a chain of if-elsif-else statements,
# which should typically be broken at the opening and closing braces.
# * 'forced' break points are breaks required by side comments or by
# special user controls.
# So this routine is just making an initial set of required line
# breaks, basically regardless of the maximum requested line length.
# The subsequent stage of formating make additional line breaks
# appropriate for lists and logical structures, and to keep line
# lengths below the requested maximum line length.
$line_of_tokens = $my_line_of_tokens;
$CODE_type = $line_of_tokens->{_code_type};
my $input_line_number = $line_of_tokens->{_line_number};
my $input_line = $line_of_tokens->{_line_text};
# initialize closure variables
my $rK_range = $line_of_tokens->{_rK_range};
( $K_first, $K_last ) = @{$rK_range};
# remember original starting index in case it changes
my $K_first_true = $K_first;
$rLL = $self->[_rLL_];
$radjusted_levels = $self->[_radjusted_levels_];
my $file_writer_object = $self->[_file_writer_object_];
my $rbreak_container = $self->[_rbreak_container_];
my $rshort_nested = $self->[_rshort_nested_];
my $sink_object = $self->[_sink_object_];
my $fh_tee = $self->[_fh_tee_];
my $ris_bli_container = $self->[_ris_bli_container_];
my $rK_weld_left = $self->[_rK_weld_left_];
if ( !defined($K_first) ) {
# Empty line: This can happen if tokens are deleted, for example
# with the -mangle parameter
return;
}
$no_internal_newlines = 0;
if ( !$rOpts_add_newlines || $CODE_type eq 'NIN' ) {
$no_internal_newlines = 2;
}
$side_comment_follows = 0;
my $is_comment =
( $K_first == $K_last && $rLL->[$K_first]->[_TYPE_] eq '#' );
my $is_static_block_comment_without_leading_space =
$CODE_type eq 'SBCX';
$is_static_block_comment =
$CODE_type eq 'SBC' || $is_static_block_comment_without_leading_space;
my $is_hanging_side_comment = $CODE_type eq 'HSC';
my $is_VERSION_statement = $CODE_type eq 'VER';
if ($is_VERSION_statement) {
$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 = "";
if ( $max_index_to_go >= 0 ) {
$last_old_nonblank_type = $types_to_go[$max_index_to_go];
$first_new_nonblank_token = $rLL->[$K_first]->[_TOKEN_];
if ( !$is_comment
&& $types_to_go[$max_index_to_go] ne 'b'
&& $K_first > 0
&& $rLL->[ $K_first - 1 ]->[_TYPE_] eq 'b' )
{
$K_first -= 1;
}
}
my $rtok_first = $rLL->[$K_first];
my $in_quote = $line_of_tokens->{_ending_in_quote};
$ending_in_quote = $in_quote;
my $guessed_indentation_level =
$line_of_tokens->{_guessed_indentation_level};
######################################
# Handle a block (full-line) comment..
######################################
if ($is_comment) {
if ( $rOpts->{'delete-block-comments'} ) {
$self->flush();
return;
}
destroy_one_line_block();
$self->end_batch();
# output a blank line before block comments
if (
# unless we follow a blank or comment line
$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
$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
$file_writer_object->write_code_line(
$rtok_first->[_TOKEN_] . "\n", undef );
$self->[_last_line_leading_type_] = '#';
}
return;
}
# compare input/output indentation except for continuation lines
# (because they have an unknown amount of initial blank space)
# and lines which are quotes (because they may have been outdented)
$self->compare_indentation_levels( $K_first, $guessed_indentation_level,
$input_line_number )
unless ( $is_hanging_side_comment
|| $rtok_first->[_CI_LEVEL_] > 0
|| $guessed_indentation_level == 0
&& $rtok_first->[_TYPE_] eq 'Q' );
##########################
# Handle indentation-only
##########################
# NOTE: In previous versions we sent all qw lines out immediately here.
# No longer doing this: also write a line which is entirely a 'qw' list
# to allow stacking of opening and closing tokens. Note that interior
# qw lines will still go out at the end of this routine.
if ( $CODE_type eq 'IO' ) {
$self->flush();
my $line = $input_line;
# Fix for rt #125506 Unexpected string formating
# in which leading space of a terminal quote was removed
$line =~ s/\s+$//;
$line =~ s/^\s+// unless ( $line_of_tokens->{_starting_in_quote} );
my $Ktoken_vars = $K_first;
# We work with a copy of the token variables and change the
# first token to be the entire line as a quote variable
my $rtoken_vars = $rLL->[$Ktoken_vars];
$rtoken_vars = copy_token_as_type( $rtoken_vars, 'q', $line );
# Patch: length is not really important here
$rtoken_vars->[_TOKEN_LENGTH_] = length($line);
$self->store_token_to_go( $Ktoken_vars, $rtoken_vars );
$self->end_batch();
return;
}
############################
# Handle all other lines ...
############################
# If we just saw the end of an elsif block, write nag message
# if we do not see another elseif or an else.
if ($looking_for_else) {
unless ( $rLL->[$K_first]->[_TOKEN_] =~ /^(elsif|else)$/ ) {
write_logfile_entry("(No else block)\n");
}
$looking_for_else = 0;
}
# This is a good place to kill incomplete one-line blocks
if (
(
( $semicolons_before_block_self_destruct == 0 )
&& ( $max_index_to_go >= 0 )
&& ( $last_old_nonblank_type eq ';' )
&& ( $first_new_nonblank_token ne '}' )
)
# Patch for RT #98902. Honor request to break at old commas.
|| ( $rOpts_break_at_old_comma_breakpoints
&& $max_index_to_go >= 0
&& $last_old_nonblank_type eq ',' )
)
{
$forced_breakpoint_to_go[$max_index_to_go] = 1
if ($rOpts_break_at_old_comma_breakpoints);
destroy_one_line_block();
$self->end_batch();
}
# 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
if ( $self->[_rbreak_before_Kfirst_]->{$K_first_true} ) {
destroy_one_line_block();
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
# We do not want a leading blank if the previous batch just got output
if ( $max_index_to_go < 0 && $rLL->[$K_first]->[_TYPE_] eq 'b' ) {
$K_first++;
}
foreach my $Ktoken_vars ( $K_first .. $K_last ) {
my $rtoken_vars = $rLL->[$Ktoken_vars];
my $token = $rtoken_vars->[_TOKEN_];
my $type = $rtoken_vars->[_TYPE_];
my $block_type = $rtoken_vars->[_BLOCK_TYPE_];
my $type_sequence = $rtoken_vars->[_TYPE_SEQUENCE_];
# If we are continuing after seeing a right curly brace, flush
# buffer unless we see what we are looking for, as in
# } else ...
if ( $rbrace_follower && $type ne 'b' ) {
unless ( $rbrace_follower->{$token} ) {
$self->end_batch();
}
$rbrace_follower = undef;
}
# Get next nonblank on this line
my $next_nonblank_token = '';
my $next_nonblank_token_type = 'b';
if ( $Ktoken_vars < $K_last ) {
my $Knnb = $Ktoken_vars + 1;
if ( $rLL->[$Knnb]->[_TYPE_] eq 'b'
&& $Knnb < $K_last )
{
$Knnb++;
}
$next_nonblank_token = $rLL->[$Knnb]->[_TOKEN_];
$next_nonblank_token_type = $rLL->[$Knnb]->[_TYPE_];
}
# Do not allow breaks which would promote a side comment to a
# block comment. In order to allow a break before an opening
# or closing BLOCK, followed by a side comment, those sections
# of code will handle this flag separately.
$side_comment_follows = ( $next_nonblank_token_type eq '#' );
my $is_opening_BLOCK =
( $type eq '{'
&& $token eq '{'
&& $block_type
&& !$rshort_nested->{$type_sequence}
&& $block_type ne 't' );
my $is_closing_BLOCK =
( $type eq '}'
&& $token eq '}'
&& $block_type
&& !$rshort_nested->{$type_sequence}
&& $block_type ne 't' );
if ( $side_comment_follows
&& !$is_opening_BLOCK
&& !$is_closing_BLOCK )
{
$no_internal_newlines = 1;
}
# We're only going to handle breaking for code BLOCKS at this
# (top) level. Other indentation breaks will be handled by
# sub scan_list, which is better suited to dealing with them.
if ($is_opening_BLOCK) {
# Tentatively output this token. This is required before
# calling starting_one_line_block. We may have to unstore
# it, though, if we have to break before it.
$self->store_token_to_go( $Ktoken_vars, $rtoken_vars );
# Look ahead to see if we might form a one-line block..
my $too_long =
$self->starting_one_line_block( $Ktoken_vars,
$K_last_nonblank_code, $K_last );
$self->clear_breakpoint_undo_stack();
# to simplify the logic below, set a flag to indicate if
# this opening brace is far from the keyword which introduces it
my $keyword_on_same_line = 1;
if (
$max_index_to_go >= 0
&& $last_nonblank_type eq ')'
&& ( ( $rtoken_vars->[_SLEVEL_] < $nesting_depth_to_go[0] )
|| $too_long )
)
{
$keyword_on_same_line = 0;
}
# decide if user requested break before '{'
my $want_break =
# This test was added to minimize changes in -bl formatting
# caused by other changes to fix cases b562 .. b983
# Previously, the -bl flag was being applied almost randomly
# to sort/map/grep/eval blocks, depending on if they were
# flagged as possible one-line blocks. usually time they
# were not given -bl formatting. The following flag was
# added to minimize changes to existing formatting.
$is_braces_left_exclude_block{$block_type}
? 0
# use -bl flag if not a sub block of any type
: $block_type !~ /$ANYSUB_PATTERN/
? $rOpts->{'opening-brace-on-new-line'}
# use -sbl flag for a named sub block
: $block_type !~ /$ASUB_PATTERN/
? $rOpts->{'opening-sub-brace-on-new-line'}
# use -asbl flag for an anonymous sub block
: $rOpts->{'opening-anonymous-sub-brace-on-new-line'};
# Break if requested with -bli flag
$want_break ||= $ris_bli_container->{$type_sequence};
# Do not break if this token is welded to the left
if ( $total_weld_count
&& defined( $rK_weld_left->{$Ktoken_vars} ) )
{
$want_break = 0;
}
# Break before an opening '{' ...
if (
# if requested
$want_break
# and we were unable to start looking for a block,
&& $index_start_one_line_block == UNDEFINED_INDEX
# or if it will not be on same line as its keyword, so that
# it will be outdented (eval.t, overload.t), and the user
# has not insisted on keeping it on the right
|| ( !$keyword_on_same_line
&& !$rOpts->{'opening-brace-always-on-right'} )
)
{
# but only if allowed
unless ($no_internal_newlines) {
# since we already stored this token, we must unstore it
$self->unstore_token_to_go();
# then output the line
$self->end_batch();
# and now store this token at the start of a new line
$self->store_token_to_go( $Ktoken_vars, $rtoken_vars );
}
}
# Now update for side comment
if ($side_comment_follows) { $no_internal_newlines = 1 }
# now output this line
unless ($no_internal_newlines) {
$self->end_batch();
}
}
elsif ($is_closing_BLOCK) {
# If there is a pending one-line block ..
if ( $index_start_one_line_block != UNDEFINED_INDEX ) {
# we have to terminate it if..
if (
# it is too long (final length may be different from
# initial estimate). note: must allow 1 space for this
# token
$self->excess_line_length( $index_start_one_line_block,
$max_index_to_go ) >= 0
# or if it has too many semicolons
|| ( $semicolons_before_block_self_destruct == 0
&& $last_nonblank_type ne ';' )
)
{
destroy_one_line_block();
}
}
# put a break before this closing curly brace if appropriate
unless ( $no_internal_newlines
|| $index_start_one_line_block != UNDEFINED_INDEX )
{
# write out everything before this closing curly brace
$self->end_batch();
}
# Now update for side comment
if ($side_comment_follows) { $no_internal_newlines = 1 }
# store the closing curly brace
$self->store_token_to_go( $Ktoken_vars, $rtoken_vars );
# ok, we just stored a closing curly brace. Often, but
# not always, we want to end the line immediately.
# So now we have to check for special cases.
# if this '}' successfully ends a one-line block..
my $is_one_line_block = 0;
my $keep_going = 0;
if ( $index_start_one_line_block != UNDEFINED_INDEX ) {
# Remember the type of token just before the
# opening brace. It would be more general to use
# a stack, but this will work for one-line blocks.
$is_one_line_block =
$types_to_go[$index_start_one_line_block];
# we have to actually make it by removing tentative
# breaks that were set within it
$self->undo_forced_breakpoint_stack(0);
$self->set_nobreaks( $index_start_one_line_block,
$max_index_to_go - 1 );
# then re-initialize for the next one-line block
destroy_one_line_block();
# then decide if we want to break after the '}' ..
# We will keep going to allow certain brace followers as in:
# do { $ifclosed = 1; last } unless $losing;
#
# But make a line break if the curly ends a
# significant block:
if (
(
$is_block_without_semicolon{$block_type}
# Follow users break point for
# one line block types U & G, such as a 'try' block
|| $is_one_line_block =~ /^[UG]$/
&& $Ktoken_vars == $K_last
)
# if needless semicolon follows we handle it later
&& $next_nonblank_token ne ';'
)
{
$self->end_batch()
unless ($no_internal_newlines);
}
}
# set string indicating what we need to look for brace follower
# tokens
if ( $block_type eq 'do' ) {
$rbrace_follower = \%is_do_follower;
if ( $self->tight_paren_follows( $K_to_go[0], $Ktoken_vars )
)
{
$rbrace_follower = { ')' => 1 };
}
}
elsif ( $block_type =~ /^(if|elsif|unless)$/ ) {
$rbrace_follower = \%is_if_brace_follower;
}
elsif ( $block_type eq 'else' ) {
$rbrace_follower = \%is_else_brace_follower;
}
# added eval for borris.t
elsif ($is_sort_map_grep_eval{$block_type}
|| $is_one_line_block eq 'G' )
{
$rbrace_follower = undef;
$keep_going = 1;
}
# anonymous sub
elsif ( $block_type =~ /$ASUB_PATTERN/ ) {
if ($is_one_line_block) {
$rbrace_follower = \%is_anon_sub_1_brace_follower;
}
else {
$rbrace_follower = \%is_anon_sub_brace_follower;
}
}
# None of the above: specify what can follow a closing
# brace of a block which is not an
# if/elsif/else/do/sort/map/grep/eval
# Testfiles:
# 'Toolbar.pm', 'Menubar.pm', bless.t, '3rules.pl', 'break1.t
else {
$rbrace_follower = \%is_other_brace_follower;
}
# See if an elsif block is followed by another elsif or else;
# complain if not.
if ( $block_type eq 'elsif' ) {
if ( $next_nonblank_token_type eq 'b' ) { # end of line?
$looking_for_else = 1; # ok, check on next line
}
else {
unless ( $next_nonblank_token =~ /^(elsif|else)$/ ) {
write_logfile_entry("No else block :(\n");
}
}
}
# keep going after certain block types (map,sort,grep,eval)
# added eval for borris.t
if ($keep_going) {
# keep going
}
# if no more tokens, postpone decision until re-entring
elsif ( ( $next_nonblank_token_type eq 'b' )
&& $rOpts_add_newlines )
{
unless ($rbrace_follower) {
$self->end_batch()
unless ($no_internal_newlines);
}
}
elsif ($rbrace_follower) {
unless ( $rbrace_follower->{$next_nonblank_token} ) {
$self->end_batch()
unless ($no_internal_newlines);
}
$rbrace_follower = undef;
}
else {
$self->end_batch()
unless ($no_internal_newlines);
}
} # end treatment of closing block token
# handle semicolon
elsif ( $type eq ';' ) {
my $break_before_semicolon = ( $Ktoken_vars == $K_first )
&& $rOpts_break_at_old_semicolon_breakpoints;
# kill one-line blocks with too many semicolons
$semicolons_before_block_self_destruct--;
if (
$break_before_semicolon
|| ( $semicolons_before_block_self_destruct < 0 )
|| ( $semicolons_before_block_self_destruct == 0
&& $next_nonblank_token_type !~ /^[b\}]$/ )
)
{
destroy_one_line_block();
$self->end_batch() if ($break_before_semicolon);
}
$self->store_token_to_go( $Ktoken_vars, $rtoken_vars );
$self->end_batch()
unless (
$no_internal_newlines
|| ( $rOpts_keep_interior_semicolons
&& $Ktoken_vars < $K_last )
|| ( $next_nonblank_token eq '}' )
);
}
# handle here_doc target string
elsif ( $type eq 'h' ) {
# no newlines after seeing here-target
$no_internal_newlines = 2;
## destroy_one_line_block(); # deleted to fix case b529
$self->store_token_to_go( $Ktoken_vars, $rtoken_vars );
}
# handle all other token types
else {
$self->store_token_to_go( $Ktoken_vars, $rtoken_vars );
}
# remember two previous nonblank OUTPUT tokens
if ( $type ne '#' && $type ne 'b' ) {
$last_last_nonblank_token = $last_nonblank_token;
$last_last_nonblank_type = $last_nonblank_type;
$last_nonblank_token = $token;
$last_nonblank_type = $type;
$last_nonblank_block_type = $block_type;
$K_last_last_nonblank_code = $K_last_nonblank_code;
$K_last_nonblank_code = $Ktoken_vars;
}
} # end of loop over all tokens in this 'line_of_tokens'
my $type = $rLL->[$K_last]->[_TYPE_];
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
|| $is_VERSION_statement
# to keep a label at the end of a line
|| $type eq 'J'
# 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' )
)
{
destroy_one_line_block();
$self->end_batch();
}
# Check for a soft break request
if ( $max_index_to_go >= 0 && $break_flag && $break_flag == 2 ) {
$self->set_forced_breakpoint($max_index_to_go);
}
# mark old line breakpoints in current output stream
if (
$max_index_to_go >= 0
&& ( !$rOpts_ignore_old_breakpoints
|| $self->[_ris_essential_old_breakpoint_]->{$K_last} )
)
{
my $jobp = $max_index_to_go;
if ( $types_to_go[$max_index_to_go] eq 'b' && $max_index_to_go > 0 )
{
$jobp--;
}
$old_breakpoint_to_go[$jobp] = 1;
}
return;
} ## end sub process_line_of_CODE
} ## end closure process_line_of_CODE
sub tight_paren_follows {
my ( $self, $K_to_go_0, $K_ic ) = @_;
# Input parameters:
# $K_to_go_0 = first token index K of this output batch (=K_to_go[0])
# $K_ic = index of the closing do brace (=K_to_go[$max_index_to_go])
# Return parameter:
# false if we want a break after the closing do brace
# true if we do not want a break after the closing do brace
# We are at the closing brace of a 'do' block. See if this brace is
# followed by a closing paren, and if so, set a flag which indicates
# that we do not want a line break between the '}' and ')'.
# xxxxx ( ...... do { ... } ) {
# ^-------looking at this brace, K_ic
# Subscript notation:
# _i = inner container (braces in this case)
# _o = outer container (parens in this case)
# _io = inner opening = '{'
# _ic = inner closing = '}'
# _oo = outer opening = '('
# _oc = outer closing = ')'
# |--K_oo |--K_oc = outer container
# xxxxx ( ...... do { ...... } ) {
# |--K_io |--K_ic = inner container
# In general, the safe thing to do is return a 'false' value
# if the statement appears to be complex. This will have
# the downstream side-effect of opening up outer containers
# to help make complex code readable. But for simpler
# do blocks it can be preferable to keep the code compact
# by returning a 'true' value.
return unless defined($K_ic);
my $rLL = $self->[_rLL_];
# we should only be called at a closing block
my $seqno_i = $rLL->[$K_ic]->[_TYPE_SEQUENCE_];
return unless ($seqno_i); # shouldn't happen;
# This only applies if the next nonblank is a ')'
my $K_oc = $self->K_next_nonblank($K_ic);
return unless defined($K_oc);
my $token_next = $rLL->[$K_oc]->[_TOKEN_];
return unless ( $token_next eq ')' );
my $seqno_o = $rLL->[$K_oc]->[_TYPE_SEQUENCE_];
my $K_io = $self->[_K_opening_container_]->{$seqno_i};
my $K_oo = $self->[_K_opening_container_]->{$seqno_o};
return unless ( defined($K_io) && defined($K_oo) );
# RULE 1: Do not break before a closing signature paren
# (regardless of complexity). This is a fix for issue git#22.
# Looking for something like:
# sub xxx ( ... do { ... } ) {
# ^----- next block_type
my $K_test = $self->K_next_nonblank($K_oc);
if ( defined($K_test) ) {
my $block_type = $rLL->[$K_test]->[_BLOCK_TYPE_];
if ( $block_type
&& $rLL->[$K_test]->[_TYPE_] eq '{'
&& $block_type =~ /$ANYSUB_PATTERN/ )
{
return 1;
}
}
# RULE 2: Break if the contents within braces appears to be 'complex'. We
# base this decision on the number of tokens between braces.
# xxxxx ( ... do { ... } ) {
# ^^^^^^
# Although very simple, it has the advantages of (1) being insensitive to
# changes in lengths of identifier names, (2) easy to understand, implement
# and test. A test case for this is 't/snippets/long_line.in'.
# Example: $K_ic - $K_oo = 9 [Pass Rule 2]
# if ( do { $2 !~ /&/ } ) { ... }
# Example: $K_ic - $K_oo = 10 [Pass Rule 2]
# for ( split /\s*={70,}\s*/, do { local $/; }) { ... }
# Example: $K_ic - $K_oo = 20 [Fail Rule 2]
# test_zero_args( "do-returned list slice", do { ( 10, 11 )[ 2, 3 ]; });
return if ( $K_ic - $K_io > 16 );
# RULE 3: break if the code between the opening '(' and the '{' is 'complex'
# As with the previous rule, we decide based on the token count
# xxxxx ( ... do { ... } ) {
# ^^^^^^^^
# Example: $K_ic - $K_oo = 9 [Pass Rule 2]
# $K_io - $K_oo = 4 [Pass Rule 3]
# if ( do { $2 !~ /&/ } ) { ... }
# Example: $K_ic - $K_oo = 10 [Pass rule 2]
# $K_io - $K_oo = 9 [Pass rule 3]
# for ( split /\s*={70,}\s*/, do { local $/; }) { ... }
return if ( $K_io - $K_oo > 9 );
# RULE 4: Break if we have already broken this batch of output tokens
return if ( $K_oo < $K_to_go_0 );
# RULE 5: Break if input is not on one line
# For example, we will set the flag for the following expression
# written in one line:
# This has: $K_ic - $K_oo = 10 [Pass rule 2]
# $K_io - $K_oo = 8 [Pass rule 3]
# $self->debug( 'Error: ' . do { local $/; <$err> } );
# but we break after the brace if it is on multiple lines on input, since
# the user may prefer it on multiple lines:
# [Fail rule 5]
# $self->debug(
# 'Error: ' . do { local $/; <$err> }
# );
if ( !$rOpts_ignore_old_breakpoints ) {
my $iline_oo = $rLL->[$K_oo]->[_LINE_INDEX_];
my $iline_oc = $rLL->[$K_oc]->[_LINE_INDEX_];
return if ( $iline_oo != $iline_oc );
}
# OK to keep the paren tight
return 1;
}
sub starting_one_line_block {
# after seeing an opening curly brace, look for the closing brace and see
# if the entire block will fit on a line. This routine is not always right
# so a check is made later (at the closing brace) to make sure we really
# have a one-line block. We have to do this preliminary check, though,
# because otherwise we would always break at a semicolon within a one-line
# block if the block contains multiple statements.
my ( $self, $Kj, $K_last_nonblank, $K_last ) = @_;
my $rbreak_container = $self->[_rbreak_container_];
my $rshort_nested = $self->[_rshort_nested_];
my $rLL = $self->[_rLL_];
my $K_opening_container = $self->[_K_opening_container_];
# kill any current block - we can only go 1 deep
destroy_one_line_block();
# return value:
# 1=distance from start of block to opening brace exceeds line length
# 0=otherwise
my $i_start = 0;
# This routine should not have been called if there are no tokens in the
# 'to_go' arrays of previously stored tokens. A previous call to
# 'store_token_to_go' should have stored an opening brace. An error here
# indicates that a programming change may have caused a flush operation to
# clean out the previously stored tokens.
if ( !defined($max_index_to_go) || $max_index_to_go < 0 ) {
Fault("program bug: store_token_to_go called incorrectly\n");
}
# Return if block should be broken
my $type_sequence = $rLL->[$Kj]->[_TYPE_SEQUENCE_];
if ( $rbreak_container->{$type_sequence} ) {
return 0;
}
my $ris_bli_container = $self->[_ris_bli_container_];
my $is_bli = $ris_bli_container->{$type_sequence};
my $block_type = $rLL->[$Kj]->[_BLOCK_TYPE_];
my $index_max_forced_break = get_index_max_forced_break();
my $previous_nonblank_token = '';
my $i_last_nonblank = -1;
if ( defined($K_last_nonblank) ) {
$i_last_nonblank = $K_last_nonblank - $K_to_go[0];
if ( $i_last_nonblank >= 0 ) {
$previous_nonblank_token = $rLL->[$K_last_nonblank]->[_TOKEN_];
}
}
# find the starting keyword for this block (such as 'if', 'else', ...)
if ( $max_index_to_go == 0
|| $block_type =~ /^[\{\}\;\:]$/
|| $block_type =~ /^package/ )
{
$i_start = $max_index_to_go;
}
# the previous nonblank token should start these block types
elsif (
$i_last_nonblank >= 0
&& ( $previous_nonblank_token eq $block_type
|| $block_type =~ /$ANYSUB_PATTERN/
|| $block_type =~ /\(\)/ )
)
{
$i_start = $i_last_nonblank;
# For signatures and extended syntax ...
# If this brace follows a parenthesized list, we should look back to
# find the keyword before the opening paren because otherwise we might
# form a one line block which stays intack, and cause the parenthesized
# expression to break open. That looks bad.
if ( $tokens_to_go[$i_start] eq ')' ) {
# Find the opening paren
my $K_start = $K_to_go[$i_start];
return 0 unless defined($K_start);
my $seqno = $type_sequence_to_go[$i_start];
return 0 unless ($seqno);
my $K_opening = $K_opening_container->{$seqno};
return 0 unless defined($K_opening);
my $i_opening = $i_start + ( $K_opening - $K_start );
# give up if not on this line
return 0 unless ( $i_opening >= 0 );
$i_start = $i_opening; ##$index_max_forced_break + 1;
# go back one token before the opening paren
if ( $i_start > 0 ) { $i_start-- }
if ( $types_to_go[$i_start] eq 'b' && $i_start > 0 ) { $i_start--; }
my $lev = $levels_to_go[$i_start];
if ( $lev > $rLL->[$Kj]->[_LEVEL_] ) { return 0 }
}
}
elsif ( $previous_nonblank_token eq ')' ) {
# For something like "if (xxx) {", the keyword "if" will be
# just after the most recent break. This will be 0 unless
# we have just killed a one-line block and are starting another.
# (doif.t)
# Note: cannot use inext_index_to_go[] here because that array
# is still being constructed.
$i_start = $index_max_forced_break + 1;
if ( $types_to_go[$i_start] eq 'b' ) {
$i_start++;
}
# Patch to avoid breaking short blocks defined with extended_syntax:
# Strip off any trailing () which was added in the parser to mark
# the opening keyword. For example, in the following
# create( TypeFoo $e) {$bubba}
# the blocktype would be marked as create()
my $stripped_block_type = $block_type;
$stripped_block_type =~ s/\(\)$//;
unless ( $tokens_to_go[$i_start] eq $stripped_block_type ) {
return 0;
}
}
# patch for SWITCH/CASE to retain one-line case/when blocks
elsif ( $block_type eq 'case' || $block_type eq 'when' ) {
# Note: cannot use inext_index_to_go[] here because that array
# is still being constructed.
$i_start = $index_max_forced_break + 1;
if ( $types_to_go[$i_start] eq 'b' ) {
$i_start++;
}
unless ( $tokens_to_go[$i_start] eq $block_type ) {
return 0;
}
}
else {
return 1;
}
my $pos = total_line_length( $i_start, $max_index_to_go ) - 1;
my $maximum_line_length =
$maximum_line_length_at_level[ $levels_to_go[$i_start] ];
# see if block starting location is too great to even start
if ( $pos > $maximum_line_length ) {
return 1;
}
# See if everything to the closing token will fit on one line
# This is part of an update to fix cases b562 .. b983
my $K_closing = $self->[_K_closing_container_]->{$type_sequence};
return 0 unless ( defined($K_closing) );
my $container_length = $rLL->[$K_closing]->[_CUMULATIVE_LENGTH_] -
$rLL->[$Kj]->[_CUMULATIVE_LENGTH_];
my $excess = $pos + 1 + $container_length - $maximum_line_length;
# Add a small tolerance for welded tokens (case b901)
if ( $total_weld_count && $self->is_welded_at_seqno($type_sequence) ) {
$excess += 2;
}
if ( $excess > 0 ) {
# line is too long... there is no chance of forming a one line block
# if the excess is more than 1 char
return 0 if ( $excess > 1 );
# ... and give up if it is not a one-line block on input.
# note: for a one-line block on input, it may be possible to keep
# it as a one-line block (by removing a needless semicolon ).
my $K_start = $K_to_go[$i_start];
my $ldiff =
$rLL->[$K_closing]->[_LINE_INDEX_] - $rLL->[$K_start]->[_LINE_INDEX_];
return 0 if ($ldiff);
}
foreach my $Ki ( $Kj + 1 .. $K_last ) {
# old whitespace could be arbitrarily large, so don't use it
if ( $rLL->[$Ki]->[_TYPE_] eq 'b' ) { $pos += 1 }
else { $pos += $rLL->[$Ki]->[_TOKEN_LENGTH_] }
# ignore some small blocks
my $type_sequence = $rLL->[$Ki]->[_TYPE_SEQUENCE_];
my $nobreak = $rshort_nested->{$type_sequence};
# Return false result if we exceed the maximum line length,
if ( $pos > $maximum_line_length ) {
return 0;
}
# keep going for non-containers
elsif ( !$type_sequence ) {
}
# return if we encounter another opening brace before finding the
# closing brace.
elsif ($rLL->[$Ki]->[_TOKEN_] eq '{'
&& $rLL->[$Ki]->[_TYPE_] eq '{'
&& $rLL->[$Ki]->[_BLOCK_TYPE_]
&& !$nobreak )
{
return 0;
}
# if we find our closing brace..
elsif ($rLL->[$Ki]->[_TOKEN_] eq '}'
&& $rLL->[$Ki]->[_TYPE_] eq '}'
&& $rLL->[$Ki]->[_BLOCK_TYPE_]
&& !$nobreak )
{
# be sure any trailing comment also fits on the line
my $Ki_nonblank = $Ki;
if ( $Ki_nonblank < $K_last ) {
$Ki_nonblank++;
if ( $rLL->[$Ki_nonblank]->[_TYPE_] eq 'b'
&& $Ki_nonblank < $K_last )
{
$Ki_nonblank++;
}
}
# Patch for one-line sort/map/grep/eval blocks with side comments:
# We will ignore the side comment length for sort/map/grep/eval
# because this can lead to statements which change every time
# perltidy is run. Here is an example from Denis Moskowitz which
# oscillates between these two states without this patch:
## --------
## grep { $_->foo ne 'bar' } # asdfa asdf asdf asdf asdf asdf asdf asdf asdf asdf asdf
## @baz;
##
## grep {
## $_->foo ne 'bar'
## } # asdfa asdf asdf asdf asdf asdf asdf asdf asdf asdf asdf
## @baz;
## --------
# When the first line is input it gets broken apart by the main
# line break logic in sub process_line_of_CODE.
# When the second line is input it gets recombined by
# process_line_of_CODE and passed to the output routines. The
# output routines (set_continuation_breaks) do not break it apart
# because the bond strengths are set to the highest possible value
# for grep/map/eval/sort blocks, so the first version gets output.
# It would be possible to fix this by changing bond strengths,
# but they are high to prevent errors in older versions of perl.
if ( $Ki < $K_last
&& $rLL->[$Ki_nonblank]->[_TYPE_] eq '#'
&& !$is_sort_map_grep{$block_type} )
{
$pos += $rLL->[$Ki_nonblank]->[_TOKEN_LENGTH_];
if ( $Ki_nonblank > $Ki + 1 ) {
# source whitespace could be anything, assume
# at least one space before the hash on output
if ( $rLL->[ $Ki + 1 ]->[_TYPE_] eq 'b' ) {
$pos += 1;
}
else { $pos += $rLL->[ $Ki + 1 ]->[_TOKEN_LENGTH_] }
}
if ( $pos >= $maximum_line_length ) {
return 0;
}
}
# ok, it's a one-line block
create_one_line_block( $i_start, 20 );
return 0;
}
# just keep going for other characters
else {
}
}
# We haven't hit the closing brace, but there is still space. So the
# question here is, should we keep going to look at more lines in hopes of
# forming a new one-line block, or should we stop right now. The problem
# with continuing is that we will not be able to honor breaks before the
# opening brace if we continue.
# Typically we will want to keep trying to make one-line blocks for things
# like sort/map/grep/eval. But it is not always a good idea to make as
# many one-line blocks as possible, so other types are not done. The user
# can always use -mangle.
# If we want to keep going, we will create a new one-line block.
# The blocks which we can keep going are in a hash, but we never want
# to continue if we are at a '-bli' block.
if ( $want_one_line_block{$block_type} && !$is_bli ) {
create_one_line_block( $i_start, 1 );
}
return 0;
}
sub unstore_token_to_go {
# remove most recent token from output stream
my $self = shift;
if ( $max_index_to_go > 0 ) {
$max_index_to_go--;
}
else {
$max_index_to_go = UNDEFINED_INDEX;
}
return;
}
sub compare_indentation_levels {
# Check to see if output line tabbing agrees with input line
# this can be very useful for debugging a script which has an extra
# or missing brace.
my ( $self, $K_first, $guessed_indentation_level, $line_number ) = @_;
return unless ( defined($K_first) );
my $rLL = $self->[_rLL_];
my $structural_indentation_level = $rLL->[$K_first]->[_LEVEL_];
my $radjusted_levels = $self->[_radjusted_levels_];
if ( defined($radjusted_levels) && @{$radjusted_levels} == @{$rLL} ) {
$structural_indentation_level = $radjusted_levels->[$K_first];
}
my $is_closing_block = $rLL->[$K_first]->[_TYPE_] eq '}'
&& $rLL->[$K_first]->[_BLOCK_TYPE_];
if ( $guessed_indentation_level ne $structural_indentation_level ) {
$self->[_last_tabbing_disagreement_] = $line_number;
if ($is_closing_block) {
if ( !$self->[_in_brace_tabbing_disagreement_] ) {
$self->[_in_brace_tabbing_disagreement_] = $line_number;
}
if ( !$self->[_first_brace_tabbing_disagreement_] ) {
$self->[_first_brace_tabbing_disagreement_] = $line_number;
}
}
if ( !$self->[_in_tabbing_disagreement_] ) {
$self->[_tabbing_disagreement_count_]++;
if ( $self->[_tabbing_disagreement_count_] <= MAX_NAG_MESSAGES ) {
write_logfile_entry(
"Start indentation disagreement: input=$guessed_indentation_level; output=$structural_indentation_level\n"
);
}
$self->[_in_tabbing_disagreement_] = $line_number;
$self->[_first_tabbing_disagreement_] = $line_number
unless ( $self->[_first_tabbing_disagreement_] );
}
}
else {
$self->[_in_brace_tabbing_disagreement_] = 0 if ($is_closing_block);
my $in_tabbing_disagreement = $self->[_in_tabbing_disagreement_];
if ($in_tabbing_disagreement) {
if ( $self->[_tabbing_disagreement_count_] <= MAX_NAG_MESSAGES ) {
write_logfile_entry(
"End indentation disagreement from input line $in_tabbing_disagreement\n"
);
if ( $self->[_tabbing_disagreement_count_] == MAX_NAG_MESSAGES )
{
write_logfile_entry(
"No further tabbing disagreements will be noted\n");
}
}
$self->[_in_tabbing_disagreement_] = 0;
}
}
return;
}
###################################################
# CODE SECTION 8: Utilities for setting breakpoints
###################################################
{ ## begin closure set_forced_breakpoint
my $forced_breakpoint_count;
my $forced_breakpoint_undo_count;
my @forced_breakpoint_undo_stack;
my $index_max_forced_break;
# Break before or after certain tokens based on user settings
my %break_before_or_after_token;
BEGIN {
# Updated to use all operators. This fixes case b1054
# Here is the previous simplified version:
## my @q = qw( . : ? and or xor && || );
my @q = @all_operators;
push @q, ',';
@break_before_or_after_token{@q} = (1) x scalar(@q);
}
sub initialize_forced_breakpoint_vars {
$forced_breakpoint_count = 0;
$index_max_forced_break = UNDEFINED_INDEX;
$forced_breakpoint_undo_count = 0;
@forced_breakpoint_undo_stack = ();
return;
}
sub get_forced_breakpoint_count {
return $forced_breakpoint_count;
}
sub get_forced_breakpoint_undo_count {
return $forced_breakpoint_undo_count;
}
sub get_index_max_forced_break {
return $index_max_forced_break;
}
sub set_fake_breakpoint {
# Just bump up the breakpoint count as a signal that there are breaks.
# This is useful if we have breaks but may want to postpone deciding
# where to make them.
$forced_breakpoint_count++;
return;
}
use constant DEBUG_FORCE => 0;
sub set_forced_breakpoint {
my ( $self, $i ) = @_;
return unless defined $i && $i >= 0;
# Back up at a blank in case we need an = break.
# This is a backup fix for cases like b932.
if ( $i > 0 && $types_to_go[$i] eq 'b' ) { $i-- }
# no breaks between welded tokens
return if ( $total_weld_count && $self->is_welded_right_at_i($i) );
my $token = $tokens_to_go[$i];
my $type = $types_to_go[$i];
# For certain tokens, use user settings to decide if we break before or
# after it
if ( $break_before_or_after_token{$token}
&& ( $type eq $token || $type eq 'k' ) )
{
if ( $want_break_before{$token} && $i >= 0 ) { $i-- }
}
# breaks are forced before 'if' and 'unless'
elsif ( $is_if_unless{$token} && $type eq 'k' ) { $i-- }
if ( $i >= 0 && $i <= $max_index_to_go ) {
my $i_nonblank = ( $types_to_go[$i] ne 'b' ) ? $i : $i - 1;
DEBUG_FORCE && do {
my ( $a, $b, $c ) = caller();
print STDOUT
"FORCE $forced_breakpoint_count from $a $c with i=$i_nonblank max=$max_index_to_go tok=$tokens_to_go[$i_nonblank] type=$types_to_go[$i_nonblank] nobr=$nobreak_to_go[$i_nonblank]\n";
};
######################################################################
# NOTE: if we call set_closing_breakpoint below it will then call
# this routing back. So there is the possibility of an infinite
# loop if a programming error is made. As a precaution, I have
# added a check on the forced_breakpoint flag, so that we won't
# keep trying to set it. That will give additional protection
# against a loop.
######################################################################
if ( $i_nonblank >= 0
&& $nobreak_to_go[$i_nonblank] == 0
&& !$forced_breakpoint_to_go[$i_nonblank] )
{
$forced_breakpoint_to_go[$i_nonblank] = 1;
if ( $i_nonblank > $index_max_forced_break ) {
$index_max_forced_break = $i_nonblank;
}
$forced_breakpoint_count++;
$forced_breakpoint_undo_stack[ $forced_breakpoint_undo_count++ ]
= $i_nonblank;
# if we break at an opening container..break at the closing
if ( $is_opening_sequence_token{ $tokens_to_go[$i_nonblank] } )
{
$self->set_closing_breakpoint($i_nonblank);
}
}
}
return;
}
sub clear_breakpoint_undo_stack {
my ($self) = @_;
$forced_breakpoint_undo_count = 0;
return;
}
use constant DEBUG_UNDOBP => 0;
sub undo_forced_breakpoint_stack {
my ( $self, $i_start ) = @_;
# Given $i_start, a non-negative index the 'undo stack' of breakpoints,
# remove all breakpoints from the top of the 'undo stack' down to and
# including index $i_start.
# The 'undo stack' is a stack of all breakpoints made for a batch of
# code.
if ( $i_start < 0 ) {
$i_start = 0;
my ( $a, $b, $c ) = caller();
# Bad call, can only be due to a recent programming change.
# Better stop here.
Fault(
"Program Bug: undo_forced_breakpoint_stack from $a $c has bad i=$i_start "
);
}
while ( $forced_breakpoint_undo_count > $i_start ) {
my $i =
$forced_breakpoint_undo_stack[ --$forced_breakpoint_undo_count ];
if ( $i >= 0 && $i <= $max_index_to_go ) {
$forced_breakpoint_to_go[$i] = 0;
$forced_breakpoint_count--;
DEBUG_UNDOBP && do {
my ( $a, $b, $c ) = caller();
print STDOUT
"UNDOBP: undo forced_breakpoint i=$i $forced_breakpoint_undo_count from $a $c max=$max_index_to_go\n";
};
}
# shouldn't happen, but not a critical error
else {
DEBUG_UNDOBP && do {
my ( $a, $b, $c ) = caller();
print STDOUT
"Program Bug: undo_forced_breakpoint from $a $c has i=$i but max=$max_index_to_go";
};
}
}
return;
}
} ## end closure set_forced_breakpoint
{ ## begin closure set_closing_breakpoint
my %postponed_breakpoint;
sub initialize_postponed_breakpoint {
%postponed_breakpoint = ();
return;
}
sub has_postponed_breakpoint {
my ($seqno) = @_;
return $postponed_breakpoint{$seqno};
}
sub set_closing_breakpoint {
# set a breakpoint at a matching closing token
my ( $self, $i_break ) = @_;
if ( $mate_index_to_go[$i_break] >= 0 ) {
# CAUTION: infinite recursion possible here:
# set_closing_breakpoint calls set_forced_breakpoint, and
# set_forced_breakpoint call set_closing_breakpoint
# ( test files attrib.t, BasicLyx.pm.html).
# Don't reduce the '2' in the statement below
if ( $mate_index_to_go[$i_break] > $i_break + 2 ) {
# break before } ] and ), but sub set_forced_breakpoint will decide
# to break before or after a ? and :
my $inc = ( $tokens_to_go[$i_break] eq '?' ) ? 0 : 1;
$self->set_forced_breakpoint(
$mate_index_to_go[$i_break] - $inc );
}
}
else {
my $type_sequence = $type_sequence_to_go[$i_break];
if ($type_sequence) {
my $closing_token = $matching_token{ $tokens_to_go[$i_break] };
$postponed_breakpoint{$type_sequence} = 1;
}
}
return;
}
} ## end closure set_closing_breakpoint
#########################################
# CODE SECTION 9: Process batches of code
#########################################
{ ## begin closure grind_batch_of_CODE
# The routines in this closure begin the processing of a 'batch' of code.
# A variable to keep track of consecutive nonblank lines so that we can
# insert occasional blanks
my @nonblank_lines_at_depth;
# A variable to remember maximum size of previous batches; this is needed
# by the logical padding routine
my $peak_batch_size;
my $batch_count;
sub initialize_grind_batch_of_CODE {
@nonblank_lines_at_depth = ();
$peak_batch_size = 0;
$batch_count = 0;
return;
}
# sub grind_batch_of_CODE receives sections of code which are the longest
# possible lines without a break. In other words, it receives what is left
# after applying all breaks forced by blank lines, block comments, side
# comments, pod text, and structural braces. Its job is to break this code
# down into smaller pieces, if necessary, which fit within the maximum
# allowed line length. Then it sends the resulting lines of code on down
# the pipeline to the VerticalAligner package, breaking the code into
# continuation lines as necessary. The batch of tokens are in the "to_go"
# arrays. The name 'grind' is slightly suggestive of a machine continually
# breaking down long lines of code, but mainly it is unique and easy to
# remember and find with an editor search.
# The two routines 'process_line_of_CODE' and 'grind_batch_of_CODE' work
# together in the following way:
# - 'process_line_of_CODE' receives the original INPUT lines one-by-one and
# combines them into the largest sequences of tokens which might form a new
# line.
# - 'grind_batch_of_CODE' determines which tokens will form the OUTPUT
# lines.
# So sub 'process_line_of_CODE' builds up the longest possible continouus
# sequences of tokens, regardless of line length, and then
# grind_batch_of_CODE breaks these sequences back down into the new output
# lines.
# Sub 'grind_batch_of_CODE' ships its output lines to the vertical aligner.
use constant DEBUG_GRIND => 0;
sub grind_batch_of_CODE {
my ($self) = @_;
my $file_writer_object = $self->[_file_writer_object_];
my $this_batch = $self->[_this_batch_];
$batch_count++;
my $starting_in_quote = $this_batch->[_starting_in_quote_];
my $ending_in_quote = $this_batch->[_ending_in_quote_];
my $is_static_block_comment = $this_batch->[_is_static_block_comment_];
my $rK_to_go = $this_batch->[_rK_to_go_];
my $ris_seqno_controlling_ci = $self->[_ris_seqno_controlling_ci_];
my $rLL = $self->[_rLL_];
# This routine is only called from sub flush_batch_of_code, so that
# routine is a better spot for debugging.
DEBUG_GRIND && do {
my $token = my $type = "";
if ( $max_index_to_go >= 0 ) {
$token = $tokens_to_go[$max_index_to_go];
$type = $types_to_go[$max_index_to_go];
}
my $output_str = join "", @tokens_to_go[ 0 .. $max_index_to_go ];
print STDERR <= 0 ) {
$inext_to_go[$ilast_nonblank] = $i;
# just in case there are two blanks in a row (shouldn't
# happen)
if ( ++$ilast_nonblank < $i ) {
$inext_to_go[$ilast_nonblank] = $i;
}
}
$ilast_nonblank = $i;
# This is a good spot to efficiently collect information needed
# for breaking lines...
if ( $type eq ',' ) { $comma_count_in_batch++; }
# gather info needed by sub set_continuation_breaks
my $seqno = $type_sequence_to_go[$i];
if ($seqno) {
# remember indexes of any tokens controlling xci
# in this batch. This list is needed by sub undo_ci.
if ( $ris_seqno_controlling_ci->{$seqno} ) {
push @ix_seqno_controlling_ci, $i;
}
if ( $type eq '?' ) {
push @colon_list, $type;
}
elsif ( $type eq ':' ) {
push @colon_list, $type;
}
}
}
}
my $comma_arrow_count_contained =
$self->match_opening_and_closing_tokens();
# tell the -lp option we are outputting a batch so it can close
# any unfinished items in its stack
finish_lp_batch();
# If this line ends in a code block brace, set breaks at any
# previous closing code block braces to breakup a chain of code
# blocks on one line. This is very rare but can happen for
# user-defined subs. For example we might be looking at this:
# BOOL { $server_data{uptime} > 0; } NUM { $server_data{load}; } STR {
my $saw_good_break = 0; # flag to force breaks even if short line
if (
# looking for opening or closing block brace
$block_type_to_go[$max_index_to_go]
# never any good breaks if just one token
&& $max_index_to_go > 0
# but not one of these which are never duplicated on a line:
# until|while|for|if|elsif|else
&& !$is_block_without_semicolon{ $block_type_to_go[$max_index_to_go]
}
)
{
my $lev = $nesting_depth_to_go[$max_index_to_go];
# Walk backwards from the end and
# set break at any closing block braces at the same level.
# But quit if we are not in a chain of blocks.
for ( my $i = $max_index_to_go - 1 ; $i >= 0 ; $i-- ) {
last if ( $levels_to_go[$i] < $lev ); # stop at a lower level
next if ( $levels_to_go[$i] > $lev ); # skip past higher level
if ( $block_type_to_go[$i] ) {
if ( $tokens_to_go[$i] eq '}' ) {
$self->set_forced_breakpoint($i);
$saw_good_break = 1;
}
}
# quit if we see anything besides words, function, blanks
# at this level
elsif ( $types_to_go[$i] !~ /^[\(\)Gwib]$/ ) { last }
}
}
my $imin = 0;
my $imax = $max_index_to_go;
# trim any blank tokens
if ( $types_to_go[$imin] eq 'b' ) { $imin++ }
if ( $types_to_go[$imax] eq 'b' ) { $imax-- }
# anything left to write?
if ( $imin <= $imax ) {
my $last_line_leading_type = $self->[_last_line_leading_type_];
my $last_line_leading_level = $self->[_last_line_leading_level_];
my $last_last_line_leading_level =
$self->[_last_last_line_leading_level_];
# add a blank line before certain key types but not after a comment
if ( $last_line_leading_type ne '#' ) {
my $want_blank = 0;
my $leading_token = $tokens_to_go[$imin];
my $leading_type = $types_to_go[$imin];
# blank lines before subs except declarations and one-liners
if ( $leading_type eq 'i' ) {
if ( $leading_token =~ /$SUB_PATTERN/ ) {
$want_blank = $rOpts->{'blank-lines-before-subs'}
if ( terminal_type_i( $imin, $imax ) !~ /^[\;\}]$/ );
}
# break before all package declarations
elsif ( substr( $leading_token, 0, 8 ) eq 'package ' ) {
$want_blank = $rOpts->{'blank-lines-before-packages'};
}
}
# break before certain key blocks except one-liners
if ( $leading_type eq 'k' ) {
if ( $leading_token eq 'BEGIN' || $leading_token eq 'END' )
{
$want_blank = $rOpts->{'blank-lines-before-subs'}
if ( terminal_type_i( $imin, $imax ) ne '}' );
}
# Break before certain block types if we haven't had a
# break at this level for a while. This is the
# difficult decision..
elsif ($last_line_leading_type ne 'b'
&& $leading_token =~
/^(unless|if|while|until|for|foreach)$/ )
{
my $lc =
$nonblank_lines_at_depth[$last_line_leading_level];
if ( !defined($lc) ) { $lc = 0 }
# patch for RT #128216: no blank line inserted at a level
# change
if ( $levels_to_go[$imin] != $last_line_leading_level )
{
$lc = 0;
}
$want_blank =
$rOpts->{'blanks-before-blocks'}
&& $lc >= $rOpts->{'long-block-line-count'}
&& $self->consecutive_nonblank_lines() >=
$rOpts->{'long-block-line-count'}
&& terminal_type_i( $imin, $imax ) ne '}';
}
}
# Check for blank lines wanted before a closing brace
if ( $leading_token eq '}' ) {
if ( $rOpts->{'blank-lines-before-closing-block'}
&& $block_type_to_go[$imin]
&& $block_type_to_go[$imin] =~
/$blank_lines_before_closing_block_pattern/ )
{
my $nblanks =
$rOpts->{'blank-lines-before-closing-block'};
if ( $nblanks > $want_blank ) {
$want_blank = $nblanks;
}
}
}
if ($want_blank) {
# future: send blank line down normal path to VerticalAligner
$self->flush_vertical_aligner();
$file_writer_object->require_blank_code_lines($want_blank);
}
}
# update blank line variables and count number of consecutive
# non-blank, non-comment lines at this level
$last_last_line_leading_level = $last_line_leading_level;
$last_line_leading_level = $levels_to_go[$imin];
if ( $last_line_leading_level < 0 ) { $last_line_leading_level = 0 }
$last_line_leading_type = $types_to_go[$imin];
if ( $last_line_leading_level == $last_last_line_leading_level
&& $last_line_leading_type ne 'b'
&& $last_line_leading_type ne '#'
&& defined( $nonblank_lines_at_depth[$last_line_leading_level] )
)
{
$nonblank_lines_at_depth[$last_line_leading_level]++;
}
else {
$nonblank_lines_at_depth[$last_line_leading_level] = 1;
}
$self->[_last_line_leading_type_] = $last_line_leading_type;
$self->[_last_line_leading_level_] = $last_line_leading_level;
$self->[_last_last_line_leading_level_] =
$last_last_line_leading_level;
# Flag to remember if we called sub 'pad_array_to_go'.
# Some routines (scan_list(), set_continuation_breaks() ) need some
# extra tokens added at the end of the batch. Most batches do not
# use these routines, so we will avoid calling 'pad_array_to_go'
# unless it is needed.
my $called_pad_array_to_go;
# set all forced breakpoints for good list formatting
my $is_long_line = $max_index_to_go > 0
&& $self->excess_line_length( $imin, $max_index_to_go ) > 0;
my $old_line_count_in_batch =
$max_index_to_go == 0
? 1
: $self->get_old_line_count( $K_to_go[0],
$K_to_go[$max_index_to_go] );
if (
$is_long_line
|| $old_line_count_in_batch > 1
# must always call scan_list() with unbalanced batches because
# it is maintaining some stacks
|| is_unbalanced_batch()
# call scan_list if we might want to break at commas
|| (
$comma_count_in_batch
&& ( $rOpts_maximum_fields_per_table > 0
&& $rOpts_maximum_fields_per_table <=
$comma_count_in_batch
|| $rOpts_comma_arrow_breakpoints == 0 )
)
# call scan_list if user may want to break open some one-line
# hash references
|| ( $comma_arrow_count_contained
&& $rOpts_comma_arrow_breakpoints != 3 )
)
{
# add a couple of extra terminal blank tokens
$self->pad_array_to_go();
$called_pad_array_to_go = 1;
## This caused problems in one version of perl for unknown reasons:
## $saw_good_break ||= scan_list();
my $sgb = $self->scan_list($is_long_line);
$saw_good_break ||= $sgb;
}
# let $ri_first and $ri_last be references to lists of
# first and last tokens of line fragments to output..
my ( $ri_first, $ri_last );
# write a single line if..
if (
# we aren't allowed to add any newlines
!$rOpts_add_newlines
# or,
|| (
# this line is 'short'
!$is_long_line
# and we didn't see a good breakpoint
&& !$saw_good_break
# and we don't already have an interior breakpoint
&& !get_forced_breakpoint_count()
)
)
{
@{$ri_first} = ($imin);
@{$ri_last} = ($imax);
}
# otherwise use multiple lines
else {
# add a couple of extra terminal blank tokens if we haven't
# already done so
$self->pad_array_to_go() unless ($called_pad_array_to_go);
( $ri_first, $ri_last ) =
$self->set_continuation_breaks( $saw_good_break,
\@colon_list );
$self->break_all_chain_tokens( $ri_first, $ri_last );
$self->break_equals( $ri_first, $ri_last );
# now we do a correction step to clean this up a bit
# (The only time we would not do this is for debugging)
if ($rOpts_recombine) {
( $ri_first, $ri_last ) =
$self->recombine_breakpoints( $ri_first, $ri_last );
}
$self->insert_final_ternary_breaks( $ri_first, $ri_last )
if (@colon_list);
}
$self->insert_breaks_before_list_opening_containers( $ri_first,
$ri_last )
if ( %break_before_container_types && $max_index_to_go > 0 );
# do corrector step if -lp option is used
my $do_not_pad = 0;
if ($rOpts_line_up_parentheses) {
$do_not_pad =
$self->correct_lp_indentation( $ri_first, $ri_last );
}
# unmask any invisible line-ending semicolon. They were placed by
# sub respace_tokens but we only now know if we actually need them.
if ( !$tokens_to_go[$imax] && $types_to_go[$imax] eq ';' ) {
my $i = $imax;
my $tok = ';';
my $tok_len = 1;
if ( $want_left_space{';'} != WS_NO ) {
$tok = ' ;';
$tok_len = 2;
}
$tokens_to_go[$i] = $tok;
$token_lengths_to_go[$i] = $tok_len;
my $KK = $K_to_go[$i];
$rLL->[$KK]->[_TOKEN_] = $tok;
$rLL->[$KK]->[_TOKEN_LENGTH_] = $tok_len;
my $line_number = 1 + $self->get_old_line_index($KK);
$self->note_added_semicolon($line_number);
}
if ( $rOpts_one_line_block_semicolons == 0 ) {
$self->delete_one_line_semicolons( $ri_first, $ri_last );
}
# The line breaks for this batch of code have been finalized. Now we
# can to package the results for further processing. We will switch
# from the local '_to_go' buffer arrays (i-index) back to the global
# token arrays (K-index) at this point.
my $rlines_K;
my $index_error;
for ( my $n = 0 ; $n < @{$ri_first} ; $n++ ) {
my $ibeg = $ri_first->[$n];
my $Kbeg = $K_to_go[$ibeg];
my $iend = $ri_last->[$n];
my $Kend = $K_to_go[$iend];
if ( $iend - $ibeg != $Kend - $Kbeg ) {
$index_error = $n unless defined($index_error);
}
push @{$rlines_K},
[ $Kbeg, $Kend, $forced_breakpoint_to_go[$iend] ];
}
# Check correctness of the mapping between the i and K token
# indexes. (The K index is the global index, the i index is the
# batch index). It is important to do this check because an error
# would be disastrous. The reason that we should never see an
# index error here is that sub 'store_token_to_go' has a check to
# make sure that the indexes in batches remain continuous. Since
# sub 'store_token_to_go' controls feeding tokens into batches,
# no index discrepancies should occur unless a recent programming
# change has introduced a bug.
if ( defined($index_error) ) {
# Temporary debug code - should never get here
for ( my $n = 0 ; $n < @{$ri_first} ; $n++ ) {
my $ibeg = $ri_first->[$n];
my $Kbeg = $K_to_go[$ibeg];
my $iend = $ri_last->[$n];
my $Kend = $K_to_go[$iend];
my $idiff = $iend - $ibeg;
my $Kdiff = $Kend - $Kbeg;
print STDERR <[_rlines_K_] = $rlines_K;
$this_batch->[_ibeg0_] = $ri_first->[0];
$this_batch->[_peak_batch_size_] = $peak_batch_size;
$this_batch->[_do_not_pad_] = $do_not_pad;
$this_batch->[_batch_count_] = $batch_count;
$this_batch->[_rix_seqno_controlling_ci_] =
\@ix_seqno_controlling_ci;
$self->send_lines_to_vertical_aligner();
# Insert any requested blank lines after an opening brace. We have
# to skip back before any side comment to find the terminal token
my $iterm;
for ( $iterm = $imax ; $iterm >= $imin ; $iterm-- ) {
next if $types_to_go[$iterm] eq '#';
next if $types_to_go[$iterm] eq 'b';
last;
}
# write requested number of blank lines after an opening block brace
if ( $iterm >= $imin && $types_to_go[$iterm] eq '{' ) {
if ( $rOpts->{'blank-lines-after-opening-block'}
&& $block_type_to_go[$iterm]
&& $block_type_to_go[$iterm] =~
/$blank_lines_after_opening_block_pattern/ )
{
my $nblanks = $rOpts->{'blank-lines-after-opening-block'};
$self->flush_vertical_aligner();
$file_writer_object->require_blank_code_lines($nblanks);
}
}
}
# Remember the largest batch size processed. This is needed by the
# logical padding routine to avoid padding the first nonblank token
if ( $max_index_to_go && $max_index_to_go > $peak_batch_size ) {
$peak_batch_size = $max_index_to_go;
}
return;
}
} ## end closure grind_batch_of_CODE
{ ## begin closure match_opening_and_closing_tokens
# closure to keep track of unbalanced containers.
# arrays shared by the routines in this block:
my %saved_opening_indentation;
my @unmatched_opening_indexes_in_this_batch;
my @unmatched_closing_indexes_in_this_batch;
my %comma_arrow_count;
sub initialize_saved_opening_indentation {
%saved_opening_indentation = ();
return;
}
sub is_unbalanced_batch {
return @unmatched_opening_indexes_in_this_batch +
@unmatched_closing_indexes_in_this_batch;
}
sub match_opening_and_closing_tokens {
# Match up indexes of opening and closing braces, etc, in this batch.
# This has to be done after all tokens are stored because unstoring
# of tokens would otherwise cause trouble.
my ($self) = @_;
my $rwant_container_open = $self->[_rwant_container_open_];
my $rparent_of_seqno = $self->[_rparent_of_seqno_];
@unmatched_opening_indexes_in_this_batch = ();
@unmatched_closing_indexes_in_this_batch = ();
%comma_arrow_count = ();
my $comma_arrow_count_contained = 0;
my $parent_seqno = $self->parent_seqno_by_K( $K_to_go[0] );
foreach my $i ( 0 .. $max_index_to_go ) {
$parent_seqno_to_go[$i] = $parent_seqno;
my $seqno = $type_sequence_to_go[$i];
if ($seqno) {
my $token = $tokens_to_go[$i];
if ( $is_opening_sequence_token{$token} ) {
if ( $is_opening_token{$token} ) {
$parent_seqno = $seqno;
}
if ( $rwant_container_open->{$seqno} ) {
$self->set_forced_breakpoint($i);
}
push @unmatched_opening_indexes_in_this_batch, $i;
}
elsif ( $is_closing_sequence_token{$token} ) {
if ( $is_closing_token{$token} ) {
$parent_seqno = $rparent_of_seqno->{$seqno};
$parent_seqno = SEQ_ROOT unless defined($parent_seqno);
$parent_seqno_to_go[$i] = $parent_seqno;
}
if ( $rwant_container_open->{$seqno} ) {
$self->set_forced_breakpoint( $i - 1 );
}
my $i_mate = pop @unmatched_opening_indexes_in_this_batch;
if ( defined($i_mate) && $i_mate >= 0 ) {
if ( $type_sequence_to_go[$i_mate] ==
$type_sequence_to_go[$i] )
{
$mate_index_to_go[$i] = $i_mate;
$mate_index_to_go[$i_mate] = $i;
my $seqno = $type_sequence_to_go[$i];
if ( $comma_arrow_count{$seqno} ) {
$comma_arrow_count_contained +=
$comma_arrow_count{$seqno};
}
}
else {
push @unmatched_opening_indexes_in_this_batch,
$i_mate;
push @unmatched_closing_indexes_in_this_batch, $i;
}
}
else {
push @unmatched_closing_indexes_in_this_batch, $i;
}
}
}
elsif ( $tokens_to_go[$i] eq '=>' ) {
if (@unmatched_opening_indexes_in_this_batch) {
my $j = $unmatched_opening_indexes_in_this_batch[-1];
my $seqno = $type_sequence_to_go[$j];
$comma_arrow_count{$seqno}++;
}
}
}
return $comma_arrow_count_contained;
}
sub save_opening_indentation {
# This should be called after each batch of tokens is output. It
# saves indentations of lines of all unmatched opening tokens.
# These will be used by sub get_opening_indentation.
my ( $self, $ri_first, $ri_last, $rindentation_list ) = @_;
# QW INDENTATION PATCH 1:
# Also save indentation for multiline qw quotes
my @i_qw;
my $seqno_qw_opening;
if ( $types_to_go[$max_index_to_go] eq 'q' ) {
my $KK = $K_to_go[$max_index_to_go];
$seqno_qw_opening =
$self->[_rstarting_multiline_qw_seqno_by_K_]->{$KK};
if ($seqno_qw_opening) {
push @i_qw, $max_index_to_go;
}
}
# we need to save indentations of any unmatched opening tokens
# in this batch because we may need them in a subsequent batch.
foreach ( @unmatched_opening_indexes_in_this_batch, @i_qw ) {
my $seqno = $type_sequence_to_go[$_];
if ( !$seqno ) {
if ( $seqno_qw_opening && $_ == $max_index_to_go ) {
$seqno = $seqno_qw_opening;
}
else {
# shouldn't happen
$seqno = 'UNKNOWN';
}
}
$saved_opening_indentation{$seqno} = [
lookup_opening_indentation(
$_, $ri_first, $ri_last, $rindentation_list
)
];
}
return;
}
sub get_saved_opening_indentation {
my ($seqno) = @_;
my ( $indent, $offset, $is_leading, $exists ) = ( 0, 0, 0, 0 );
if ($seqno) {
if ( $saved_opening_indentation{$seqno} ) {
( $indent, $offset, $is_leading ) =
@{ $saved_opening_indentation{$seqno} };
$exists = 1;
}
}
# some kind of serious error it doesn't exist
# (example is badfile.t)
return ( $indent, $offset, $is_leading, $exists );
}
} ## end closure match_opening_and_closing_tokens
sub lookup_opening_indentation {
# get the indentation of the line in the current output batch
# which output a selected opening token
#
# given:
# $i_opening - index of an opening token in the current output batch
# whose line indentation we need
# $ri_first - reference to list of the first index $i for each output
# line in this batch
# $ri_last - reference to list of the last index $i for each output line
# in this batch
# $rindentation_list - reference to a list containing the indentation
# used for each line. (NOTE: the first slot in
# this list is the last returned line number, and this is
# followed by the list of indentations).
#
# return
# -the indentation of the line which contained token $i_opening
# -and its offset (number of columns) from the start of the line
my ( $i_opening, $ri_start, $ri_last, $rindentation_list ) = @_;
if ( !@{$ri_last} ) {
# An error here implies a bug introduced by a recent program change.
# Every batch of code has lines.
Fault("Error in opening_indentation: no lines");
return;
}
my $nline = $rindentation_list->[0]; # line number of previous lookup
# reset line location if necessary
$nline = 0 if ( $i_opening < $ri_start->[$nline] );
# find the correct line
unless ( $i_opening > $ri_last->[-1] ) {
while ( $i_opening > $ri_last->[$nline] ) { $nline++; }
}
# Error - token index is out of bounds - shouldn't happen
# A program bug has been introduced in one of the calling routines.
# We better stop here.
else {
my $i_last_line = $ri_last->[-1];
Fault(< $i_last_line = max index of last line
This batch has max index = $max_index_to_go,
EOM
report_definite_bug(); # old coding, will not get here
$nline = $#{$ri_last};
}
$rindentation_list->[0] =
$nline; # save line number to start looking next call
my $ibeg = $ri_start->[$nline];
my $offset = token_sequence_length( $ibeg, $i_opening ) - 1;
my $is_leading = ( $ibeg == $i_opening );
return ( $rindentation_list->[ $nline + 1 ], $offset, $is_leading );
}
{ ## begin closure terminal_type_i
my %is_sort_map_grep_eval_do;
BEGIN {
my @q = qw(sort map grep eval do);
@is_sort_map_grep_eval_do{@q} = (1) x scalar(@q);
}
sub terminal_type_i {
# returns type of last token on this line (terminal token), as follows:
# returns # for a full-line comment
# returns ' ' for a blank line
# otherwise returns final token type
my ( $ibeg, $iend ) = @_;
# Start at the end and work backwards
my $i = $iend;
my $type_i = $types_to_go[$i];
# Check for side comment
if ( $type_i eq '#' ) {
$i--;
if ( $i < $ibeg ) {
return wantarray ? ( $type_i, $ibeg ) : $type_i;
}
$type_i = $types_to_go[$i];
}
# Skip past a blank
if ( $type_i eq 'b' ) {
$i--;
if ( $i < $ibeg ) {
return wantarray ? ( $type_i, $ibeg ) : $type_i;
}
$type_i = $types_to_go[$i];
}
# Found it..make sure it is a BLOCK termination,
# but hide a terminal } after sort/grep/map because it is not
# necessarily the end of the line. (terminal.t)
my $block_type = $block_type_to_go[$i];
if (
$type_i eq '}'
&& ( !$block_type
|| ( $is_sort_map_grep_eval_do{$block_type} ) )
)
{
$type_i = 'b';
}
return wantarray ? ( $type_i, $i ) : $type_i;
}
} ## end closure terminal_type_i
sub pad_array_to_go {
# To simplify coding in scan_list and set_bond_strengths, it helps to
# create some extra blank tokens at the end of the arrays. We also add
# some undef's to help guard against using invalid data.
my ($self) = @_;
$K_to_go[ $max_index_to_go + 1 ] = undef;
$tokens_to_go[ $max_index_to_go + 1 ] = '';
$tokens_to_go[ $max_index_to_go + 2 ] = '';
$tokens_to_go[ $max_index_to_go + 3 ] = undef;
$types_to_go[ $max_index_to_go + 1 ] = 'b';
$types_to_go[ $max_index_to_go + 2 ] = 'b';
$types_to_go[ $max_index_to_go + 3 ] = undef;
$nesting_depth_to_go[ $max_index_to_go + 2 ] = undef;
$nesting_depth_to_go[ $max_index_to_go + 1 ] =
$nesting_depth_to_go[$max_index_to_go];
# /^[R\}\)\]]$/
if ( $is_closing_type{ $types_to_go[$max_index_to_go] } ) {
if ( $nesting_depth_to_go[$max_index_to_go] <= 0 ) {
# Nesting depths are equivalent to the _SLEVEL_ variable which is
# clipped to be >=0 in sub write_line, so it should not be possible
# to get here unless the code has a bracing error which leaves a
# closing brace with zero nesting depth.
unless ( get_saw_brace_error() ) {
warning(
"Program bug in pad_array_to_go: hit nesting error which should have been caught\n"
);
report_definite_bug();
}
}
else {
$nesting_depth_to_go[ $max_index_to_go + 1 ] -= 1;
}
}
# /^[L\{\(\[]$/
elsif ( $is_opening_type{ $types_to_go[$max_index_to_go] } ) {
$nesting_depth_to_go[ $max_index_to_go + 1 ] += 1;
}
return;
}
sub break_all_chain_tokens {
# scan the current breakpoints looking for breaks at certain "chain
# operators" (. : && || + etc) which often occur repeatedly in a long
# statement. If we see a break at any one, break at all similar tokens
# within the same container.
#
my ( $self, $ri_left, $ri_right ) = @_;
my %saw_chain_type;
my %left_chain_type;
my %right_chain_type;
my %interior_chain_type;
my $nmax = @{$ri_right} - 1;
# scan the left and right end tokens of all lines
my $count = 0;
for my $n ( 0 .. $nmax ) {
my $il = $ri_left->[$n];
my $ir = $ri_right->[$n];
my $typel = $types_to_go[$il];
my $typer = $types_to_go[$ir];
$typel = '+' if ( $typel eq '-' ); # treat + and - the same
$typer = '+' if ( $typer eq '-' );
$typel = '*' if ( $typel eq '/' ); # treat * and / the same
$typer = '*' if ( $typer eq '/' );
my $tokenl = $tokens_to_go[$il];
my $tokenr = $tokens_to_go[$ir];
if ( $is_chain_operator{$tokenl} && $want_break_before{$typel} ) {
next if ( $typel eq '?' );
push @{ $left_chain_type{$typel} }, $il;
$saw_chain_type{$typel} = 1;
$count++;
}
if ( $is_chain_operator{$tokenr} && !$want_break_before{$typer} ) {
next if ( $typer eq '?' );
push @{ $right_chain_type{$typer} }, $ir;
$saw_chain_type{$typer} = 1;
$count++;
}
}
return unless $count;
# now look for any interior tokens of the same types
$count = 0;
for my $n ( 0 .. $nmax ) {
my $il = $ri_left->[$n];
my $ir = $ri_right->[$n];
foreach my $i ( $il + 1 .. $ir - 1 ) {
my $type = $types_to_go[$i];
$type = '+' if ( $type eq '-' );
$type = '*' if ( $type eq '/' );
if ( $saw_chain_type{$type} ) {
push @{ $interior_chain_type{$type} }, $i;
$count++;
}
}
}
return unless $count;
# now make a list of all new break points
my @insert_list;
# loop over all chain types
foreach my $type ( keys %saw_chain_type ) {
# quit if just ONE continuation line with leading . For example--
# print LATEXFILE '\framebox{\parbox[c][' . $h . '][t]{' . $w . '}{'
# . $contents;
last if ( $nmax == 1 && $type =~ /^[\.\+]$/ );
# loop over all interior chain tokens
foreach my $itest ( @{ $interior_chain_type{$type} } ) {
# loop over all left end tokens of same type
if ( $left_chain_type{$type} ) {
next if $nobreak_to_go[ $itest - 1 ];
foreach my $i ( @{ $left_chain_type{$type} } ) {
next unless $self->in_same_container_i( $i, $itest );
push @insert_list, $itest - 1;
# Break at matching ? if this : is at a different level.
# For example, the ? before $THRf_DEAD in the following
# should get a break if its : gets a break.
#
# my $flags =
# ( $_ & 1 ) ? ( $_ & 4 ) ? $THRf_DEAD : $THRf_ZOMBIE
# : ( $_ & 4 ) ? $THRf_R_DETACHED
# : $THRf_R_JOINABLE;
if ( $type eq ':'
&& $levels_to_go[$i] != $levels_to_go[$itest] )
{
my $i_question = $mate_index_to_go[$itest];
if ( $i_question > 0 ) {
push @insert_list, $i_question - 1;
}
}
last;
}
}
# loop over all right end tokens of same type
if ( $right_chain_type{$type} ) {
next if $nobreak_to_go[$itest];
foreach my $i ( @{ $right_chain_type{$type} } ) {
next unless $self->in_same_container_i( $i, $itest );
push @insert_list, $itest;
# break at matching ? if this : is at a different level
if ( $type eq ':'
&& $levels_to_go[$i] != $levels_to_go[$itest] )
{
my $i_question = $mate_index_to_go[$itest];
if ( $i_question >= 0 ) {
push @insert_list, $i_question;
}
}
last;
}
}
}
}
# insert any new break points
if (@insert_list) {
$self->insert_additional_breaks( \@insert_list, $ri_left, $ri_right );
}
return;
}
sub insert_additional_breaks {
# this routine will add line breaks at requested locations after
# sub set_continuation_breaks has made preliminary breaks.
my ( $self, $ri_break_list, $ri_first, $ri_last ) = @_;
my $i_f;
my $i_l;
my $line_number = 0;
foreach my $i_break_left ( sort { $a <=> $b } @{$ri_break_list} ) {
next if ( $nobreak_to_go[$i_break_left] );
$i_f = $ri_first->[$line_number];
$i_l = $ri_last->[$line_number];
while ( $i_break_left >= $i_l ) {
$line_number++;
# shouldn't happen unless caller passes bad indexes
if ( $line_number >= @{$ri_last} ) {
warning(
"Non-fatal program bug: couldn't set break at $i_break_left\n"
);
report_definite_bug();
return;
}
$i_f = $ri_first->[$line_number];
$i_l = $ri_last->[$line_number];
}
# Do not leave a blank at the end of a line; back up if necessary
if ( $types_to_go[$i_break_left] eq 'b' ) { $i_break_left-- }
my $i_break_right = $inext_to_go[$i_break_left];
if ( $i_break_left >= $i_f
&& $i_break_left < $i_l
&& $i_break_right > $i_f
&& $i_break_right <= $i_l )
{
splice( @{$ri_first}, $line_number, 1, ( $i_f, $i_break_right ) );
splice( @{$ri_last}, $line_number, 1, ( $i_break_left, $i_l ) );
}
}
return;
}
sub in_same_container_i {
# check to see if tokens at i1 and i2 are in the
# same container, and not separated by a comma, ? or :
# This is an interface between the _to_go arrays to the rLL array
my ( $self, $i1, $i2 ) = @_;
# quick check
return if ( $parent_seqno_to_go[$i1] ne $parent_seqno_to_go[$i2] );
# full check
return $self->in_same_container_K( $K_to_go[$i1], $K_to_go[$i2] );
}
{ ## begin closure in_same_container_K
my $ris_break_token;
my $ris_comma_token;
BEGIN {
# all cases break on seeing commas at same level
my @q = qw( => );
push @q, ',';
@{$ris_comma_token}{@q} = (1) x scalar(@q);
# Non-ternary text also breaks on seeing any of qw(? : || or )
# Example: we would not want to break at any of these .'s
# : "$str"
push @q, qw( or || ? : );
@{$ris_break_token}{@q} = (1) x scalar(@q);
}
sub in_same_container_K {
# Check to see if tokens at K1 and K2 are in the same container,
# and not separated by certain characters: => , ? : || or
# This version uses the newer $rLL data structure.
my ( $self, $K1, $K2 ) = @_;
if ( $K2 < $K1 ) { ( $K1, $K2 ) = ( $K2, $K1 ) }
my $rLL = $self->[_rLL_];
my $depth_1 = $rLL->[$K1]->[_SLEVEL_];
return if ( $depth_1 < 0 );
return unless ( $rLL->[$K2]->[_SLEVEL_] == $depth_1 );
# Select character set to scan for
my $type_1 = $rLL->[$K1]->[_TYPE_];
my $rbreak = ( $type_1 ne ':' ) ? $ris_break_token : $ris_comma_token;
# Fast preliminary loop to verify that tokens are in the same container
my $KK = $K1;
while (1) {
$KK = $rLL->[$KK]->[_KNEXT_SEQ_ITEM_];
last if !defined($KK);
last if ( $KK >= $K2 );
my $depth_K = $rLL->[$KK]->[_SLEVEL_];
return if ( $depth_K < $depth_1 );
next if ( $depth_K > $depth_1 );
if ( $type_1 ne ':' ) {
my $tok_K = $rLL->[$KK]->[_TOKEN_];
return if ( $tok_K eq '?' || $tok_K eq ':' );
}
}
# Slow loop checking for certain characters
###########################################################
# This is potentially a slow routine and not critical.
# For safety just give up for large differences.
# See test file 'infinite_loop.txt'
###########################################################
return if ( $K2 - $K1 > 200 );
foreach my $K ( $K1 + 1 .. $K2 - 1 ) {
my $depth_K = $rLL->[$K]->[_SLEVEL_];
next if ( $depth_K > $depth_1 );
return if ( $depth_K < $depth_1 ); # redundant, checked above
my $tok = $rLL->[$K]->[_TOKEN_];
return if ( $rbreak->{$tok} );
}
return 1;
}
} ## end closure in_same_container_K
sub break_equals {
# Look for assignment operators that could use a breakpoint.
# For example, in the following snippet
#
# $HOME = $ENV{HOME}
# || $ENV{LOGDIR}
# || $pw[7]
# || die "no home directory for user $<";
#
# we could break at the = to get this, which is a little nicer:
# $HOME =
# $ENV{HOME}
# || $ENV{LOGDIR}
# || $pw[7]
# || die "no home directory for user $<";
#
# The logic here follows the logic in set_logical_padding, which
# will add the padding in the second line to improve alignment.
#
my ( $self, $ri_left, $ri_right ) = @_;
my $nmax = @{$ri_right} - 1;
return unless ( $nmax >= 2 );
# scan the left ends of first two lines
my $tokbeg = "";
my $depth_beg;
for my $n ( 1 .. 2 ) {
my $il = $ri_left->[$n];
my $typel = $types_to_go[$il];
my $tokenl = $tokens_to_go[$il];
my $has_leading_op = ( $tokenl =~ /^\w/ )
? $is_chain_operator{$tokenl} # + - * / : ? && ||
: $is_chain_operator{$typel}; # and, or
return unless ($has_leading_op);
if ( $n > 1 ) {
return
unless ( $tokenl eq $tokbeg
&& $nesting_depth_to_go[$il] eq $depth_beg );
}
$tokbeg = $tokenl;
$depth_beg = $nesting_depth_to_go[$il];
}
# now look for any interior tokens of the same types
my $il = $ri_left->[0];
my $ir = $ri_right->[0];
# now make a list of all new break points
my @insert_list;
for ( my $i = $ir - 1 ; $i > $il ; $i-- ) {
my $type = $types_to_go[$i];
if ( $is_assignment{$type}
&& $nesting_depth_to_go[$i] eq $depth_beg )
{
if ( $want_break_before{$type} ) {
push @insert_list, $i - 1;
}
else {
push @insert_list, $i;
}
}
}
# Break after a 'return' followed by a chain of operators
# return ( $^O !~ /win32|dos/i )
# && ( $^O ne 'VMS' )
# && ( $^O ne 'OS2' )
# && ( $^O ne 'MacOS' );
# To give:
# return
# ( $^O !~ /win32|dos/i )
# && ( $^O ne 'VMS' )
# && ( $^O ne 'OS2' )
# && ( $^O ne 'MacOS' );
my $i = 0;
if ( $types_to_go[$i] eq 'k'
&& $tokens_to_go[$i] eq 'return'
&& $ir > $il
&& $nesting_depth_to_go[$i] eq $depth_beg )
{
push @insert_list, $i;
}
return unless (@insert_list);
# One final check...
# scan second and third lines and be sure there are no assignments
# we want to avoid breaking at an = to make something like this:
# unless ( $icon =
# $html_icons{"$type-$state"}
# or $icon = $html_icons{$type}
# or $icon = $html_icons{$state} )
for my $n ( 1 .. 2 ) {
my $il = $ri_left->[$n];
my $ir = $ri_right->[$n];
foreach my $i ( $il + 1 .. $ir ) {
my $type = $types_to_go[$i];
return
if ( $is_assignment{$type}
&& $nesting_depth_to_go[$i] eq $depth_beg );
}
}
# ok, insert any new break point
if (@insert_list) {
$self->insert_additional_breaks( \@insert_list, $ri_left, $ri_right );
}
return;
}
{ ## begin closure recombine_breakpoints
# This routine is called once per batch to see if it would be better
# to combine some of the lines into which the batch has been broken.
my %is_amp_amp;
my %is_ternary;
my %is_math_op;
my %is_plus_minus;
my %is_mult_div;
BEGIN {
my @q;
@q = qw( && || );
@is_amp_amp{@q} = (1) x scalar(@q);
@q = qw( ? : );
@is_ternary{@q} = (1) x scalar(@q);
@q = qw( + - * / );
@is_math_op{@q} = (1) x scalar(@q);
@q = qw( + - );
@is_plus_minus{@q} = (1) x scalar(@q);
@q = qw( * / );
@is_mult_div{@q} = (1) x scalar(@q);
}
sub Debug_dump_breakpoints {
# Debug routine to dump current breakpoints...not normally called
# We are given indexes to the current lines:
# $ri_beg = ref to array of BEGinning indexes of each line
# $ri_end = ref to array of ENDing indexes of each line
my ( $self, $ri_beg, $ri_end, $msg ) = @_;
print STDERR "----Dumping breakpoints from: $msg----\n";
for my $n ( 0 .. @{$ri_end} - 1 ) {
my $ibeg = $ri_beg->[$n];
my $iend = $ri_end->[$n];
my $text = "";
foreach my $i ( $ibeg .. $iend ) {
$text .= $tokens_to_go[$i];
}
print STDERR "$n ($ibeg:$iend) $text\n";
}
print STDERR "----\n";
return;
}
sub delete_one_line_semicolons {
my ( $self, $ri_beg, $ri_end ) = @_;
my $rLL = $self->[_rLL_];
my $K_opening_container = $self->[_K_opening_container_];
# Walk down the lines of this batch and delete any semicolons
# terminating one-line blocks;
my $nmax = @{$ri_end} - 1;
foreach my $n ( 0 .. $nmax ) {
my $i_beg = $ri_beg->[$n];
my $i_e = $ri_end->[$n];
my $K_beg = $K_to_go[$i_beg];
my $K_e = $K_to_go[$i_e];
my $K_end = $K_e;
my $type_end = $rLL->[$K_end]->[_TYPE_];
if ( $type_end eq '#' ) {
$K_end = $self->K_previous_nonblank($K_end);
if ( defined($K_end) ) { $type_end = $rLL->[$K_end]->[_TYPE_]; }
}
# we are looking for a line ending in closing brace
next
unless ( $type_end eq '}' && $rLL->[$K_end]->[_TOKEN_] eq '}' );
# ...and preceded by a semicolon on the same line
my $K_semicolon = $self->K_previous_nonblank($K_end);
next unless defined($K_semicolon);
my $i_semicolon = $i_beg + ( $K_semicolon - $K_beg );
next if ( $i_semicolon <= $i_beg );
next unless ( $rLL->[$K_semicolon]->[_TYPE_] eq ';' );
# Safety check - shouldn't happen - not critical
# This is not worth throwing a Fault, except in DEVEL_MODE
if ( $types_to_go[$i_semicolon] ne ';' ) {
DEVEL_MODE
&& Fault("unexpected type looking for semicolon");
next;
}
# ... with the corresponding opening brace on the same line
my $type_sequence = $rLL->[$K_end]->[_TYPE_SEQUENCE_];
my $K_opening = $K_opening_container->{$type_sequence};
next unless ( defined($K_opening) );
my $i_opening = $i_beg + ( $K_opening - $K_beg );
next if ( $i_opening < $i_beg );
# ... and only one semicolon between these braces
my $semicolon_count = 0;
foreach my $K ( $K_opening + 1 .. $K_semicolon - 1 ) {
if ( $rLL->[$K]->[_TYPE_] eq ';' ) {
$semicolon_count++;
last;
}
}
next if ($semicolon_count);
# ...ok, then make the semicolon invisible
$tokens_to_go[$i_semicolon] = "";
$token_lengths_to_go[$i_semicolon] = 0;
$rLL->[$K_semicolon]->[_TOKEN_] = "";
$rLL->[$K_semicolon]->[_TOKEN_LENGTH_] = 0;
}
return;
}
use constant DEBUG_RECOMBINE => 0;
sub recombine_breakpoints {
# sub set_continuation_breaks is very liberal in setting line breaks
# for long lines, always setting breaks at good breakpoints, even
# when that creates small lines. Sometimes small line fragments
# are produced which would look better if they were combined.
# That's the task of this routine.
#
# We are given indexes to the current lines:
# $ri_beg = ref to array of BEGinning indexes of each line
# $ri_end = ref to array of ENDing indexes of each line
my ( $self, $ri_beg, $ri_end ) = @_;
my $rK_weld_right = $self->[_rK_weld_right_];
my $rK_weld_left = $self->[_rK_weld_left_];
# Make a list of all good joining tokens between the lines
# n-1 and n.
my @joint;
my $nmax = @{$ri_end} - 1;
for my $n ( 1 .. $nmax ) {
my $ibeg_1 = $ri_beg->[ $n - 1 ];
my $iend_1 = $ri_end->[ $n - 1 ];
my $iend_2 = $ri_end->[$n];
my $ibeg_2 = $ri_beg->[$n];
my ( $itok, $itokp, $itokm );
foreach my $itest ( $iend_1, $ibeg_2 ) {
my $type = $types_to_go[$itest];
if ( $is_math_op{$type}
|| $is_amp_amp{$type}
|| $is_assignment{$type}
|| $type eq ':' )
{
$itok = $itest;
}
}
$joint[$n] = [$itok];
}
my $more_to_do = 1;
# We keep looping over all of the lines of this batch
# until there are no more possible recombinations
my $nmax_last = @{$ri_end};
my $reverse = 0;
while ($more_to_do) {
my $n_best = 0;
my $bs_best;
my $nmax = @{$ri_end} - 1;
# Safety check for infinite loop
unless ( $nmax < $nmax_last ) {
# Shouldn't happen because splice below decreases nmax on each
# iteration. An error can only be due to a recent programming
# change.
Fault("Program bug-infinite loop in recombine breakpoints\n");
}
$nmax_last = $nmax;
$more_to_do = 0;
my $skip_Section_3;
my $leading_amp_count = 0;
my $this_line_is_semicolon_terminated;
# loop over all remaining lines in this batch
for my $iter ( 1 .. $nmax ) {
# alternating sweep direction gives symmetric results
# for recombining lines which exceed the line length
# such as eval {{{{.... }}}}
my $n;
if ($reverse) { $n = 1 + $nmax - $iter; }
else { $n = $iter }
#----------------------------------------------------------
# If we join the current pair of lines,
# line $n-1 will become the left part of the joined line
# line $n will become the right part of the joined line
#
# Here are Indexes of the endpoint tokens of the two lines:
#
# -----line $n-1--- | -----line $n-----
# $ibeg_1 $iend_1 | $ibeg_2 $iend_2
# ^
# |
# We want to decide if we should remove the line break
# between the tokens at $iend_1 and $ibeg_2
#
# We will apply a number of ad-hoc tests to see if joining
# here will look ok. The code will just issue a 'next'
# command if the join doesn't look good. If we get through
# the gauntlet of tests, the lines will be recombined.
#----------------------------------------------------------
#
# beginning and ending tokens of the lines we are working on
my $ibeg_1 = $ri_beg->[ $n - 1 ];
my $iend_1 = $ri_end->[ $n - 1 ];
my $iend_2 = $ri_end->[$n];
my $ibeg_2 = $ri_beg->[$n];
my $ibeg_nmax = $ri_beg->[$nmax];
# combined line cannot be too long
my $excess = $self->excess_line_length( $ibeg_1, $iend_2, 1 );
next if ( $excess > 0 );
my $type_iend_1 = $types_to_go[$iend_1];
my $type_iend_2 = $types_to_go[$iend_2];
my $type_ibeg_1 = $types_to_go[$ibeg_1];
my $type_ibeg_2 = $types_to_go[$ibeg_2];
# terminal token of line 2 if any side comment is ignored:
my $iend_2t = $iend_2;
my $type_iend_2t = $type_iend_2;
# some beginning indexes of other lines, which may not exist
my $ibeg_0 = $n > 1 ? $ri_beg->[ $n - 2 ] : -1;
my $ibeg_3 = $n < $nmax ? $ri_beg->[ $n + 1 ] : -1;
my $ibeg_4 = $n + 2 <= $nmax ? $ri_beg->[ $n + 2 ] : -1;
my $bs_tweak = 0;
#my $depth_increase=( $nesting_depth_to_go[$ibeg_2] -
# $nesting_depth_to_go[$ibeg_1] );
DEBUG_RECOMBINE && do {
print STDERR
"RECOMBINE: n=$n imid=$iend_1 if=$ibeg_1 type=$type_ibeg_1 =$tokens_to_go[$ibeg_1] next_type=$type_ibeg_2 next_tok=$tokens_to_go[$ibeg_2]\n";
};
# If line $n is the last line, we set some flags and
# do any special checks for it
if ( $n == $nmax ) {
# a terminal '{' should stay where it is
# unless preceded by a fat comma
next if ( $type_ibeg_2 eq '{' && $type_iend_1 ne '=>' );
if ( $type_iend_2 eq '#'
&& $iend_2 - $ibeg_2 >= 2
&& $types_to_go[ $iend_2 - 1 ] eq 'b' )
{
$iend_2t = $iend_2 - 2;
$type_iend_2t = $types_to_go[$iend_2t];
}
$this_line_is_semicolon_terminated = $type_iend_2t eq ';';
}
#----------------------------------------------------------
# Recombine Section 0:
# Examine the special token joining this line pair, if any.
# Put as many tests in this section to avoid duplicate code and
# to make formatting independent of whether breaks are to the
# left or right of an operator.
#----------------------------------------------------------
my ($itok) = @{ $joint[$n] };
if ($itok) {
my $type = $types_to_go[$itok];
if ( $type eq ':' ) {
# do not join at a colon unless it disobeys the break
# request
if ( $itok eq $iend_1 ) {
next unless $want_break_before{$type};
}
else {
$leading_amp_count++;
next if $want_break_before{$type};
}
} ## end if ':'
# handle math operators + - * /
elsif ( $is_math_op{$type} ) {
# Combine these lines if this line is a single
# number, or if it is a short term with same
# operator as the previous line. For example, in
# the following code we will combine all of the
# short terms $A, $B, $C, $D, $E, $F, together
# instead of leaving them one per line:
# my $time =
# $A * $B * $C * $D * $E * $F *
# ( 2. * $eps * $sigma * $area ) *
# ( 1. / $tcold**3 - 1. / $thot**3 );
# This can be important in math-intensive code.
my $good_combo;
my $itokp = min( $inext_to_go[$itok], $iend_2 );
my $itokpp = min( $inext_to_go[$itokp], $iend_2 );
my $itokm = max( $iprev_to_go[$itok], $ibeg_1 );
my $itokmm = max( $iprev_to_go[$itokm], $ibeg_1 );
# check for a number on the right
if ( $types_to_go[$itokp] eq 'n' ) {
# ok if nothing else on right
if ( $itokp == $iend_2 ) {
$good_combo = 1;
}
else {
# look one more token to right..
# okay if math operator or some termination
$good_combo =
( ( $itokpp == $iend_2 )
&& $is_math_op{ $types_to_go[$itokpp] } )
|| $types_to_go[$itokpp] =~ /^[#,;]$/;
}
}
# check for a number on the left
if ( !$good_combo && $types_to_go[$itokm] eq 'n' ) {
# okay if nothing else to left
if ( $itokm == $ibeg_1 ) {
$good_combo = 1;
}
# otherwise look one more token to left
else {
# okay if math operator, comma, or assignment
$good_combo = ( $itokmm == $ibeg_1 )
&& ( $is_math_op{ $types_to_go[$itokmm] }
|| $types_to_go[$itokmm] =~ /^[,]$/
|| $is_assignment{ $types_to_go[$itokmm] }
);
}
}
# look for a single short token either side of the
# operator
if ( !$good_combo ) {
# Slight adjustment factor to make results
# independent of break before or after operator in
# long summed lists. (An operator and a space make
# two spaces).
my $two = ( $itok eq $iend_1 ) ? 2 : 0;
$good_combo =
# numbers or id's on both sides of this joint
$types_to_go[$itokp] =~ /^[in]$/
&& $types_to_go[$itokm] =~ /^[in]$/
# one of the two lines must be short:
&& (
(
# no more than 2 nonblank tokens right of
# joint
$itokpp == $iend_2
# short
&& token_sequence_length( $itokp, $iend_2 )
< $two +
$rOpts_short_concatenation_item_length
)
|| (
# no more than 2 nonblank tokens left of
# joint
$itokmm == $ibeg_1
# short
&& token_sequence_length( $ibeg_1, $itokm )
< 2 - $two +
$rOpts_short_concatenation_item_length
)
)
# keep pure terms; don't mix +- with */
&& !(
$is_plus_minus{$type}
&& ( $is_mult_div{ $types_to_go[$itokmm] }
|| $is_mult_div{ $types_to_go[$itokpp] } )
)
&& !(
$is_mult_div{$type}
&& ( $is_plus_minus{ $types_to_go[$itokmm] }
|| $is_plus_minus{ $types_to_go[$itokpp] } )
)
;
}
# it is also good to combine if we can reduce to 2 lines
if ( !$good_combo ) {
# index on other line where same token would be in a
# long chain.
my $iother =
( $itok == $iend_1 ) ? $iend_2 : $ibeg_1;
$good_combo =
$n == 2
&& $n == $nmax
&& $types_to_go[$iother] ne $type;
}
next unless ($good_combo);
} ## end math
elsif ( $is_amp_amp{$type} ) {
##TBD
} ## end &&, ||
elsif ( $is_assignment{$type} ) {
##TBD
} ## end assignment
}
#----------------------------------------------------------
# Recombine Section 1:
# Join welded nested containers immediately
#----------------------------------------------------------
if (
$total_weld_count
&& ( $type_sequence_to_go[$iend_1]
&& defined( $rK_weld_right->{ $K_to_go[$iend_1] } )
|| $type_sequence_to_go[$ibeg_2]
&& defined( $rK_weld_left->{ $K_to_go[$ibeg_2] } ) )
)
{
$n_best = $n;
last;
}
$reverse = 0;
#----------------------------------------------------------
# Recombine Section 2:
# Examine token at $iend_1 (right end of first line of pair)
#----------------------------------------------------------
# an isolated '}' may join with a ';' terminated segment
if ( $type_iend_1 eq '}' ) {
# Check for cases where combining a semicolon terminated
# statement with a previous isolated closing paren will
# allow the combined line to be outdented. This is
# generally a good move. For example, we can join up
# the last two lines here:
# (
# $dev, $ino, $mode, $nlink, $uid, $gid, $rdev,
# $size, $atime, $mtime, $ctime, $blksize, $blocks
# )
# = stat($file);
#
# to get:
# (
# $dev, $ino, $mode, $nlink, $uid, $gid, $rdev,
# $size, $atime, $mtime, $ctime, $blksize, $blocks
# ) = stat($file);
#
# which makes the parens line up.
#
# Another example, from Joe Matarazzo, probably looks best
# with the 'or' clause appended to the trailing paren:
# $self->some_method(
# PARAM1 => 'foo',
# PARAM2 => 'bar'
# ) or die "Some_method didn't work";
#
# But we do not want to do this for something like the -lp
# option where the paren is not outdentable because the
# trailing clause will be far to the right.
#
# The logic here is synchronized with the logic in sub
# sub set_adjusted_indentation, which actually does
# the outdenting.
#
$skip_Section_3 ||= $this_line_is_semicolon_terminated
# only one token on last line
&& $ibeg_1 == $iend_1
# must be structural paren
&& $tokens_to_go[$iend_1] eq ')'
# style must allow outdenting,
&& !$closing_token_indentation{')'}
# only leading '&&', '||', and ':' if no others seen
# (but note: our count made below could be wrong
# due to intervening comments)
&& ( $leading_amp_count == 0
|| $type_ibeg_2 !~ /^(:|\&\&|\|\|)$/ )
# but leading colons probably line up with a
# previous colon or question (count could be wrong).
&& $type_ibeg_2 ne ':'
# only one step in depth allowed. this line must not
# begin with a ')' itself.
&& ( $nesting_depth_to_go[$iend_1] ==
$nesting_depth_to_go[$iend_2] + 1 );
# YVES patch 2 of 2:
# Allow cuddled eval chains, like this:
# eval {
# #STUFF;
# 1; # return true
# } or do {
# #handle error
# };
# This patch works together with a patch in
# setting adjusted indentation (where the closing eval
# brace is outdented if possible).
# The problem is that an 'eval' block has continuation
# indentation and it looks better to undo it in some
# cases. If we do not use this patch we would get:
# eval {
# #STUFF;
# 1; # return true
# }
# or do {
# #handle error
# };
# The alternative, for uncuddled style, is to create
# a patch in set_adjusted_indentation which undoes
# the indentation of a leading line like 'or do {'.
# This doesn't work well with -icb through
if (
$block_type_to_go[$iend_1] eq 'eval'
&& !$rOpts->{'line-up-parentheses'}
&& !$rOpts->{'indent-closing-brace'}
&& $tokens_to_go[$iend_2] eq '{'
&& (
( $type_ibeg_2 =~ /^(\&\&|\|\|)$/ )
|| ( $type_ibeg_2 eq 'k'
&& $is_and_or{ $tokens_to_go[$ibeg_2] } )
|| $is_if_unless{ $tokens_to_go[$ibeg_2] }
)
)
{
$skip_Section_3 ||= 1;
}
next
unless (
$skip_Section_3
# handle '.' and '?' specially below
|| ( $type_ibeg_2 =~ /^[\.\?]$/ )
);
}
elsif ( $type_iend_1 eq '{' ) {
# YVES
# honor breaks at opening brace
# Added to prevent recombining something like this:
# } || eval { package main;
next if $forced_breakpoint_to_go[$iend_1];
}
# do not recombine lines with ending &&, ||,
elsif ( $is_amp_amp{$type_iend_1} ) {
next unless $want_break_before{$type_iend_1};
}
# Identify and recombine a broken ?/: chain
elsif ( $type_iend_1 eq '?' ) {
# Do not recombine different levels
next
if ( $levels_to_go[$ibeg_1] ne $levels_to_go[$ibeg_2] );
# do not recombine unless next line ends in :
next unless $type_iend_2 eq ':';
}
# for lines ending in a comma...
elsif ( $type_iend_1 eq ',' ) {
# Do not recombine at comma which is following the
# input bias.
# TODO: might be best to make a special flag
next if ( $old_breakpoint_to_go[$iend_1] );
# An isolated '},' may join with an identifier + ';'
# This is useful for the class of a 'bless' statement
# (bless.t)
if ( $type_ibeg_1 eq '}'
&& $type_ibeg_2 eq 'i' )
{
next
unless ( ( $ibeg_1 == ( $iend_1 - 1 ) )
&& ( $iend_2 == ( $ibeg_2 + 1 ) )
&& $this_line_is_semicolon_terminated );
# override breakpoint
$forced_breakpoint_to_go[$iend_1] = 0;
}
# but otherwise ..
else {
# do not recombine after a comma unless this will leave
# just 1 more line
next unless ( $n + 1 >= $nmax );
# do not recombine if there is a change in indentation depth
next
if (
$levels_to_go[$iend_1] != $levels_to_go[$iend_2] );
# do not recombine a "complex expression" after a
# comma. "complex" means no parens.
my $saw_paren;
foreach my $ii ( $ibeg_2 .. $iend_2 ) {
if ( $tokens_to_go[$ii] eq '(' ) {
$saw_paren = 1;
last;
}
}
next if $saw_paren;
}
}
# opening paren..
elsif ( $type_iend_1 eq '(' ) {
# No longer doing this
}
elsif ( $type_iend_1 eq ')' ) {
# No longer doing this
}
# keep a terminal for-semicolon
elsif ( $type_iend_1 eq 'f' ) {
next;
}
# if '=' at end of line ...
elsif ( $is_assignment{$type_iend_1} ) {
# keep break after = if it was in input stream
# this helps prevent 'blinkers'
next if $old_breakpoint_to_go[$iend_1]
# don't strand an isolated '='
&& $iend_1 != $ibeg_1;
my $is_short_quote =
( $type_ibeg_2 eq 'Q'
&& $ibeg_2 == $iend_2
&& token_sequence_length( $ibeg_2, $ibeg_2 ) <
$rOpts_short_concatenation_item_length );
my $is_ternary =
( $type_ibeg_1 eq '?'
&& ( $ibeg_3 >= 0 && $types_to_go[$ibeg_3] eq ':' ) );
# always join an isolated '=', a short quote, or if this
# will put ?/: at start of adjacent lines
if ( $ibeg_1 != $iend_1
&& !$is_short_quote
&& !$is_ternary )
{
next
unless (
(
# unless we can reduce this to two lines
$nmax < $n + 2
# or three lines, the last with a leading semicolon
|| ( $nmax == $n + 2
&& $types_to_go[$ibeg_nmax] eq ';' )
# or the next line ends with a here doc
|| $type_iend_2 eq 'h'
# or the next line ends in an open paren or brace
# and the break hasn't been forced [dima.t]
|| ( !$forced_breakpoint_to_go[$iend_1]
&& $type_iend_2 eq '{' )
)
# do not recombine if the two lines might align well
# this is a very approximate test for this
&& (
# RT#127633 - the leading tokens are not operators
( $type_ibeg_2 ne $tokens_to_go[$ibeg_2] )
# or they are different
|| ( $ibeg_3 >= 0
&& $type_ibeg_2 ne $types_to_go[$ibeg_3] )
)
);
if (
# Recombine if we can make two lines
$nmax >= $n + 2
# -lp users often prefer this:
# my $title = function($env, $env, $sysarea,
# "bubba Borrower Entry");
# so we will recombine if -lp is used we have
# ending comma
&& ( !$rOpts_line_up_parentheses
|| $type_iend_2 ne ',' )
)
{
# otherwise, scan the rhs line up to last token for
# complexity. Note that we are not counting the last
# token in case it is an opening paren.
my $tv = 0;
my $depth = $nesting_depth_to_go[$ibeg_2];
foreach my $i ( $ibeg_2 + 1 .. $iend_2 - 1 ) {
if ( $nesting_depth_to_go[$i] != $depth ) {
$tv++;
last if ( $tv > 1 );
}
$depth = $nesting_depth_to_go[$i];
}
# ok to recombine if no level changes before last token
if ( $tv > 0 ) {
# otherwise, do not recombine if more than two
# level changes.
next if ( $tv > 1 );
# check total complexity of the two adjacent lines
# that will occur if we do this join
my $istop =
( $n < $nmax )
? $ri_end->[ $n + 1 ]
: $iend_2;
foreach my $i ( $iend_2 .. $istop ) {
if ( $nesting_depth_to_go[$i] != $depth ) {
$tv++;
last if ( $tv > 2 );
}
$depth = $nesting_depth_to_go[$i];
}
# do not recombine if total is more than 2 level changes
next if ( $tv > 2 );
}
}
}
unless ( $tokens_to_go[$ibeg_2] =~ /^[\{\(\[]$/ ) {
$forced_breakpoint_to_go[$iend_1] = 0;
}
}
# for keywords..
elsif ( $type_iend_1 eq 'k' ) {
# make major control keywords stand out
# (recombine.t)
next
if (
#/^(last|next|redo|return)$/
$is_last_next_redo_return{ $tokens_to_go[$iend_1] }
# but only if followed by multiple lines
&& $n < $nmax
);
if ( $is_and_or{ $tokens_to_go[$iend_1] } ) {
next
unless $want_break_before{ $tokens_to_go[$iend_1] };
}
}
#----------------------------------------------------------
# Recombine Section 3:
# Examine token at $ibeg_2 (left end of second line of pair)
#----------------------------------------------------------
# join lines identified above as capable of
# causing an outdented line with leading closing paren
# Note that we are skipping the rest of this section
# and the rest of the loop to do the join
if ($skip_Section_3) {
$forced_breakpoint_to_go[$iend_1] = 0;
$n_best = $n;
last;
}
# handle lines with leading &&, ||
elsif ( $is_amp_amp{$type_ibeg_2} ) {
$leading_amp_count++;
# ok to recombine if it follows a ? or :
# and is followed by an open paren..
my $ok =
( $is_ternary{$type_ibeg_1}
&& $tokens_to_go[$iend_2] eq '(' )
# or is followed by a ? or : at same depth
#
# We are looking for something like this. We can
# recombine the && line with the line above to make the
# structure more clear:
# return
# exists $G->{Attr}->{V}
# && exists $G->{Attr}->{V}->{$u}
# ? %{ $G->{Attr}->{V}->{$u} }
# : ();
#
# We should probably leave something like this alone:
# return
# exists $G->{Attr}->{E}
# && exists $G->{Attr}->{E}->{$u}
# && exists $G->{Attr}->{E}->{$u}->{$v}
# ? %{ $G->{Attr}->{E}->{$u}->{$v} }
# : ();
# so that we either have all of the &&'s (or ||'s)
# on one line, as in the first example, or break at
# each one as in the second example. However, it
# sometimes makes things worse to check for this because
# it prevents multiple recombinations. So this is not done.
|| ( $ibeg_3 >= 0
&& $is_ternary{ $types_to_go[$ibeg_3] }
&& $nesting_depth_to_go[$ibeg_3] ==
$nesting_depth_to_go[$ibeg_2] );
next if !$ok && $want_break_before{$type_ibeg_2};
$forced_breakpoint_to_go[$iend_1] = 0;
# tweak the bond strength to give this joint priority
# over ? and :
$bs_tweak = 0.25;
}
# Identify and recombine a broken ?/: chain
elsif ( $type_ibeg_2 eq '?' ) {
# Do not recombine different levels
my $lev = $levels_to_go[$ibeg_2];
next if ( $lev ne $levels_to_go[$ibeg_1] );
# Do not recombine a '?' if either next line or
# previous line does not start with a ':'. The reasons
# are that (1) no alignment of the ? will be possible
# and (2) the expression is somewhat complex, so the
# '?' is harder to see in the interior of the line.
my $follows_colon = $ibeg_1 >= 0 && $type_ibeg_1 eq ':';
my $precedes_colon =
$ibeg_3 >= 0 && $types_to_go[$ibeg_3] eq ':';
next unless ( $follows_colon || $precedes_colon );
# we will always combining a ? line following a : line
if ( !$follows_colon ) {
# ...otherwise recombine only if it looks like a chain.
# we will just look at a few nearby lines to see if
# this looks like a chain.
my $local_count = 0;
foreach my $ii ( $ibeg_0, $ibeg_1, $ibeg_3, $ibeg_4 ) {
$local_count++
if $ii >= 0
&& $types_to_go[$ii] eq ':'
&& $levels_to_go[$ii] == $lev;
}
next unless ( $local_count > 1 );
}
$forced_breakpoint_to_go[$iend_1] = 0;
}
# do not recombine lines with leading '.'
elsif ( $type_ibeg_2 eq '.' ) {
my $i_next_nonblank = min( $inext_to_go[$ibeg_2], $iend_2 );
next
unless (
# ... unless there is just one and we can reduce
# this to two lines if we do. For example, this
#
#
# $bodyA .=
# '($dummy, $pat) = &get_next_tex_cmd;' . '$args .= $pat;'
#
# looks better than this:
# $bodyA .= '($dummy, $pat) = &get_next_tex_cmd;'
# . '$args .= $pat;'
(
$n == 2
&& $n == $nmax
&& $type_ibeg_1 ne $type_ibeg_2
)
# ... or this would strand a short quote , like this
# . "some long quote"
# . "\n";
|| ( $types_to_go[$i_next_nonblank] eq 'Q'
&& $i_next_nonblank >= $iend_2 - 1
&& $token_lengths_to_go[$i_next_nonblank] <
$rOpts_short_concatenation_item_length )
);
}
# handle leading keyword..
elsif ( $type_ibeg_2 eq 'k' ) {
# handle leading "or"
if ( $tokens_to_go[$ibeg_2] eq 'or' ) {
next
unless (
$this_line_is_semicolon_terminated
&& (
$type_ibeg_1 eq '}'
|| (
# following 'if' or 'unless' or 'or'
$type_ibeg_1 eq 'k'
&& $is_if_unless{ $tokens_to_go[$ibeg_1] }
# important: only combine a very simple or
# statement because the step below may have
# combined a trailing 'and' with this or,
# and we do not want to then combine
# everything together
&& ( $iend_2 - $ibeg_2 <= 7 )
)
)
);
#X: RT #81854
$forced_breakpoint_to_go[$iend_1] = 0
unless $old_breakpoint_to_go[$iend_1];
}
# handle leading 'and' and 'xor'
elsif ($tokens_to_go[$ibeg_2] eq 'and'
|| $tokens_to_go[$ibeg_2] eq 'xor' )
{
# Decide if we will combine a single terminal 'and'
# after an 'if' or 'unless'.
# This looks best with the 'and' on the same
# line as the 'if':
#
# $a = 1
# if $seconds and $nu < 2;
#
# But this looks better as shown:
#
# $a = 1
# if !$this->{Parents}{$_}
# or $this->{Parents}{$_} eq $_;
#
next
unless (
$this_line_is_semicolon_terminated
&& (
# following 'if' or 'unless' or 'or'
$type_ibeg_1 eq 'k'
&& ( $is_if_unless{ $tokens_to_go[$ibeg_1] }
|| $tokens_to_go[$ibeg_1] eq 'or' )
)
);
}
# handle leading "if" and "unless"
elsif ( $is_if_unless{ $tokens_to_go[$ibeg_2] } ) {
# Combine something like:
# next
# if ( $lang !~ /${l}$/i );
# into:
# next if ( $lang !~ /${l}$/i );
next
unless (
$this_line_is_semicolon_terminated
# previous line begins with 'and' or 'or'
&& $type_ibeg_1 eq 'k'
&& $is_and_or{ $tokens_to_go[$ibeg_1] }
);
}
# handle all other leading keywords
else {
# keywords look best at start of lines,
# but combine things like "1 while"
unless ( $is_assignment{$type_iend_1} ) {
next
if ( ( $type_iend_1 ne 'k' )
&& ( $tokens_to_go[$ibeg_2] ne 'while' ) );
}
}
}
# similar treatment of && and || as above for 'and' and 'or':
# NOTE: This block of code is currently bypassed because
# of a previous block but is retained for possible future use.
elsif ( $is_amp_amp{$type_ibeg_2} ) {
# maybe looking at something like:
# unless $TEXTONLY || $item =~ m%|p>|a|img)%i;
next
unless (
$this_line_is_semicolon_terminated
# previous line begins with an 'if' or 'unless' keyword
&& $type_ibeg_1 eq 'k'
&& $is_if_unless{ $tokens_to_go[$ibeg_1] }
);
}
# handle line with leading = or similar
elsif ( $is_assignment{$type_ibeg_2} ) {
next unless ( $n == 1 || $n == $nmax );
next if $old_breakpoint_to_go[$iend_1];
next
unless (
# unless we can reduce this to two lines
$nmax == 2
# or three lines, the last with a leading semicolon
|| ( $nmax == 3 && $types_to_go[$ibeg_nmax] eq ';' )
# or the next line ends with a here doc
|| $type_iend_2 eq 'h'
# or this is a short line ending in ;
|| ( $n == $nmax && $this_line_is_semicolon_terminated )
);
$forced_breakpoint_to_go[$iend_1] = 0;
}
#----------------------------------------------------------
# Recombine Section 4:
# Combine the lines if we arrive here and it is possible
#----------------------------------------------------------
# honor hard breakpoints
next if ( $forced_breakpoint_to_go[$iend_1] > 0 );
my $bs = $bond_strength_to_go[$iend_1] + $bs_tweak;
# Require a few extra spaces before recombining lines if we are
# at an old breakpoint unless this is a simple list or terminal
# line. The goal is to avoid oscillating between two
# quasi-stable end states. For example this snippet caused
# problems:
## my $this =
## bless {
## TText => "[" . ( join ',', map { "\"$_\"" } split "\n", $_ ) . "]"
## },
## $type;
next
if ( $old_breakpoint_to_go[$iend_1]
&& !$this_line_is_semicolon_terminated
&& $n < $nmax
&& $excess + 4 > 0
&& $type_iend_2 ne ',' );
# do not recombine if we would skip in indentation levels
if ( $n < $nmax ) {
my $if_next = $ri_beg->[ $n + 1 ];
next
if (
$levels_to_go[$ibeg_1] < $levels_to_go[$ibeg_2]
&& $levels_to_go[$ibeg_2] < $levels_to_go[$if_next]
# but an isolated 'if (' is undesirable
&& !(
$n == 1
&& $iend_1 - $ibeg_1 <= 2
&& $type_ibeg_1 eq 'k'
&& $tokens_to_go[$ibeg_1] eq 'if'
&& $tokens_to_go[$iend_1] ne '('
)
);
}
# honor no-break's
next if ( $bs >= NO_BREAK - 1 );
# remember the pair with the greatest bond strength
if ( !$n_best ) {
$n_best = $n;
$bs_best = $bs;
}
else {
if ( $bs > $bs_best ) {
$n_best = $n;
$bs_best = $bs;
}
}
}
# recombine the pair with the greatest bond strength
if ($n_best) {
splice @{$ri_beg}, $n_best, 1;
splice @{$ri_end}, $n_best - 1, 1;
splice @joint, $n_best, 1;
# keep going if we are still making progress
$more_to_do++;
}
}
return ( $ri_beg, $ri_end );
}
} ## end closure recombine_breakpoints
sub insert_final_ternary_breaks {
my ( $self, $ri_left, $ri_right ) = @_;
# Called once per batch to look for and do any final line breaks for
# long ternary chains
my $nmax = @{$ri_right} - 1;
# scan the left and right end tokens of all lines
my $count = 0;
my $i_first_colon = -1;
for my $n ( 0 .. $nmax ) {
my $il = $ri_left->[$n];
my $ir = $ri_right->[$n];
my $typel = $types_to_go[$il];
my $typer = $types_to_go[$ir];
return if ( $typel eq '?' );
return if ( $typer eq '?' );
if ( $typel eq ':' ) { $i_first_colon = $il; last; }
elsif ( $typer eq ':' ) { $i_first_colon = $ir; last; }
}
# For long ternary chains,
# if the first : we see has its ? is in the interior
# of a preceding line, then see if there are any good
# breakpoints before the ?.
if ( $i_first_colon > 0 ) {
my $i_question = $mate_index_to_go[$i_first_colon];
if ( $i_question > 0 ) {
my @insert_list;
for ( my $ii = $i_question - 1 ; $ii >= 0 ; $ii -= 1 ) {
my $token = $tokens_to_go[$ii];
my $type = $types_to_go[$ii];
# For now, a good break is either a comma or,
# in a long chain, a 'return'.
# Patch for RT #126633: added the $nmax>1 check to avoid
# breaking after a return for a simple ternary. For longer
# chains the break after return allows vertical alignment, so
# it is still done. So perltidy -wba='?' will not break
# immediately after the return in the following statement:
# sub x {
# return 0 ? 'aaaaaaaaaaaaaaaaaaaaa' :
# 'bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb';
# }
if (
(
$type eq ','
|| $type eq 'k' && ( $nmax > 1 && $token eq 'return' )
)
&& $self->in_same_container_i( $ii, $i_question )
)
{
push @insert_list, $ii;
last;
}
}
# insert any new break points
if (@insert_list) {
$self->insert_additional_breaks( \@insert_list, $ri_left,
$ri_right );
}
}
}
return;
}
sub insert_breaks_before_list_opening_containers {
my ( $self, $ri_left, $ri_right ) = @_;
# This routine is called once per batch to implement the parameters
# --break-before-hash-brace, etc.
# Nothing to do if none of these parameters has been set
return unless %break_before_container_types;
my $nmax = @{$ri_right} - 1;
return unless ( $nmax >= 0 );
my $rLL = $self->[_rLL_];
my $rbreak_before_container_by_seqno =
$self->[_rbreak_before_container_by_seqno_];
my $rK_weld_left = $self->[_rK_weld_left_];
# scan the ends of all lines
my @insert_list;
for my $n ( 0 .. $nmax ) {
my $il = $ri_left->[$n];
my $ir = $ri_right->[$n];
next unless ( $ir > $il );
my $Kl = $K_to_go[$il];
my $Kr = $K_to_go[$ir];
my $Kend = $Kr;
my $type_end = $rLL->[$Kr]->[_TYPE_];
# Backup before any side comment
if ( $type_end eq '#' ) {
$Kend = $self->K_previous_nonblank($Kr);
next unless defined($Kend);
$type_end = $rLL->[$Kend]->[_TYPE_];
}
# Backup to the start of any weld; fix for b1173.
if ($total_weld_count) {
my $Kend_test = $rK_weld_left->{$Kend};
if ( defined($Kend_test) && $Kend_test > $Kl ) {
$Kend = $Kend_test;
$Kend_test = $rK_weld_left->{$Kend};
}
# Do not break if we did not back up to the start of a weld
# (shouldn't happen)
next if ( defined($Kend_test) );
}
my $token = $rLL->[$Kend]->[_TOKEN_];
next unless ( $is_opening_token{$token} );
next unless ( $Kl < $Kend - 1 );
my $seqno = $rLL->[$Kend]->[_TYPE_SEQUENCE_];
next unless ( defined($seqno) );
# Use the flag which was previously set
next unless ( $rbreak_before_container_by_seqno->{$seqno} );
# Install a break before this opening token.
my $Kbreak = $self->K_previous_nonblank($Kend);
my $ibreak = $Kbreak - $Kl + $il;
next if ( $ibreak < $il );
next if ( $nobreak_to_go[$ibreak] );
push @insert_list, $ibreak;
}
# insert any new break points
if (@insert_list) {
$self->insert_additional_breaks( \@insert_list, $ri_left, $ri_right );
}
return;
}
sub note_added_semicolon {
my ( $self, $line_number ) = @_;
$self->[_last_added_semicolon_at_] = $line_number;
if ( $self->[_added_semicolon_count_] == 0 ) {
$self->[_first_added_semicolon_at_] = $line_number;
}
$self->[_added_semicolon_count_]++;
write_logfile_entry("Added ';' here\n");
return;
}
sub note_deleted_semicolon {
my ( $self, $line_number ) = @_;
$self->[_last_deleted_semicolon_at_] = $line_number;
if ( $self->[_deleted_semicolon_count_] == 0 ) {
$self->[_first_deleted_semicolon_at_] = $line_number;
}
$self->[_deleted_semicolon_count_]++;
write_logfile_entry("Deleted unnecessary ';' at line $line_number\n");
return;
}
sub note_embedded_tab {
my ( $self, $line_number ) = @_;
$self->[_embedded_tab_count_]++;
$self->[_last_embedded_tab_at_] = $line_number;
if ( !$self->[_first_embedded_tab_at_] ) {
$self->[_first_embedded_tab_at_] = $line_number;
}
if ( $self->[_embedded_tab_count_] <= MAX_NAG_MESSAGES ) {
write_logfile_entry("Embedded tabs in quote or pattern\n");
}
return;
}
sub correct_lp_indentation {
# When the -lp option is used, we need to make a last pass through
# each line to correct the indentation positions in case they differ
# from the predictions. This is necessary because perltidy uses a
# predictor/corrector method for aligning with opening parens. The
# predictor is usually good, but sometimes stumbles. The corrector
# tries to patch things up once the actual opening paren locations
# are known.
my ( $self, $ri_first, $ri_last ) = @_;
my $do_not_pad = 0;
# Note on flag '$do_not_pad':
# We want to avoid a situation like this, where the aligner inserts
# whitespace before the '=' to align it with a previous '=', because
# otherwise the parens might become mis-aligned in a situation like
# this, where the '=' has become aligned with the previous line,
# pushing the opening '(' forward beyond where we want it.
#
# $mkFloor::currentRoom = '';
# $mkFloor::c_entry = $c->Entry(
# -width => '10',
# -relief => 'sunken',
# ...
# );
#
# We leave it to the aligner to decide how to do this.
# first remove continuation indentation if appropriate
my $max_line = @{$ri_first} - 1;
# looking at each line of this batch..
my ( $ibeg, $iend );
foreach my $line ( 0 .. $max_line ) {
$ibeg = $ri_first->[$line];
$iend = $ri_last->[$line];
# looking at each token in this output line..
foreach my $i ( $ibeg .. $iend ) {
# How many space characters to place before this token
# for special alignment. Actual padding is done in the
# continue block.
# looking for next unvisited indentation item
my $indentation = $leading_spaces_to_go[$i];
if ( !$indentation->get_marked() ) {
$indentation->set_marked(1);
# looking for indentation item for which we are aligning
# with parens, braces, and brackets
next unless ( $indentation->get_align_paren() );
# skip closed container on this line
if ( $i > $ibeg ) {
my $im = max( $ibeg, $iprev_to_go[$i] );
if ( $type_sequence_to_go[$im]
&& $mate_index_to_go[$im] <= $iend )
{
next;
}
}
if ( $line == 1 && $i == $ibeg ) {
$do_not_pad = 1;
}
# Ok, let's see what the error is and try to fix it
my $actual_pos;
my $predicted_pos = $indentation->get_spaces();
if ( $i > $ibeg ) {
# token is mid-line - use length to previous token
$actual_pos = total_line_length( $ibeg, $i - 1 );
# for mid-line token, we must check to see if all
# additional lines have continuation indentation,
# and remove it if so. Otherwise, we do not get
# good alignment.
my $closing_index = $indentation->get_closed();
if ( $closing_index > $iend ) {
my $ibeg_next = $ri_first->[ $line + 1 ];
if ( $ci_levels_to_go[$ibeg_next] > 0 ) {
$self->undo_lp_ci( $line, $i, $closing_index,
$ri_first, $ri_last );
}
}
}
elsif ( $line > 0 ) {
# handle case where token starts a new line;
# use length of previous line
my $ibegm = $ri_first->[ $line - 1 ];
my $iendm = $ri_last->[ $line - 1 ];
$actual_pos = total_line_length( $ibegm, $iendm );
# follow -pt style
++$actual_pos
if ( $types_to_go[ $iendm + 1 ] eq 'b' );
}
else {
# token is first character of first line of batch
$actual_pos = $predicted_pos;
}
my $move_right = $actual_pos - $predicted_pos;
# done if no error to correct (gnu2.t)
if ( $move_right == 0 ) {
$indentation->set_recoverable_spaces($move_right);
next;
}
# if we have not seen closure for this indentation in
# this batch, we can only pass on a request to the
# vertical aligner
my $closing_index = $indentation->get_closed();
if ( $closing_index < 0 ) {
$indentation->set_recoverable_spaces($move_right);
next;
}
# If necessary, look ahead to see if there is really any
# leading whitespace dependent on this whitespace, and
# also find the longest line using this whitespace.
# Since it is always safe to move left if there are no
# dependents, we only need to do this if we may have
# dependent nodes or need to move right.
my $right_margin = 0;
my $have_child = $indentation->get_have_child();
my %saw_indentation;
my $line_count = 1;
$saw_indentation{$indentation} = $indentation;
if ( $have_child || $move_right > 0 ) {
$have_child = 0;
my $max_length = 0;
if ( $i == $ibeg ) {
$max_length = total_line_length( $ibeg, $iend );
}
# look ahead at the rest of the lines of this batch..
foreach my $line_t ( $line + 1 .. $max_line ) {
my $ibeg_t = $ri_first->[$line_t];
my $iend_t = $ri_last->[$line_t];
last if ( $closing_index <= $ibeg_t );
# remember all different indentation objects
my $indentation_t = $leading_spaces_to_go[$ibeg_t];
$saw_indentation{$indentation_t} = $indentation_t;
$line_count++;
# remember longest line in the group
my $length_t = total_line_length( $ibeg_t, $iend_t );
if ( $length_t > $max_length ) {
$max_length = $length_t;
}
}
$right_margin =
$maximum_line_length_at_level[ $levels_to_go[$ibeg] ] -
$max_length;
if ( $right_margin < 0 ) { $right_margin = 0 }
}
my $first_line_comma_count =
grep { $_ eq ',' } @types_to_go[ $ibeg .. $iend ];
my $comma_count = $indentation->get_comma_count();
my $arrow_count = $indentation->get_arrow_count();
# This is a simple approximate test for vertical alignment:
# if we broke just after an opening paren, brace, bracket,
# and there are 2 or more commas in the first line,
# and there are no '=>'s,
# then we are probably vertically aligned. We could set
# an exact flag in sub scan_list, but this is good
# enough.
my $indentation_count = keys %saw_indentation;
my $is_vertically_aligned =
( $i == $ibeg
&& $first_line_comma_count > 1
&& $indentation_count == 1
&& ( $arrow_count == 0 || $arrow_count == $line_count ) );
# Make the move if possible ..
if (
# we can always move left
$move_right < 0
# but we should only move right if we are sure it will
# not spoil vertical alignment
|| ( $comma_count == 0 )
|| ( $comma_count > 0 && !$is_vertically_aligned )
)
{
my $move =
( $move_right <= $right_margin )
? $move_right
: $right_margin;
foreach ( keys %saw_indentation ) {
$saw_indentation{$_}
->permanently_decrease_available_spaces( -$move );
}
}
# Otherwise, record what we want and the vertical aligner
# will try to recover it.
else {
$indentation->set_recoverable_spaces($move_right);
}
}
}
}
return $do_not_pad;
}
sub undo_lp_ci {
# If there is a single, long parameter within parens, like this:
#
# $self->command( "/msg "
# . $infoline->chan
# . " You said $1, but did you know that it's square was "
# . $1 * $1 . " ?" );
#
# we can remove the continuation indentation of the 2nd and higher lines
# to achieve this effect, which is more pleasing:
#
# $self->command("/msg "
# . $infoline->chan
# . " You said $1, but did you know that it's square was "
# . $1 * $1 . " ?");
my ( $self, $line_open, $i_start, $closing_index, $ri_first, $ri_last ) =
@_;
my $max_line = @{$ri_first} - 1;
# must be multiple lines
return unless $max_line > $line_open;
my $lev_start = $levels_to_go[$i_start];
my $ci_start_plus = 1 + $ci_levels_to_go[$i_start];
# see if all additional lines in this container have continuation
# indentation
my $n;
my $line_1 = 1 + $line_open;
for ( $n = $line_1 ; $n <= $max_line ; ++$n ) {
my $ibeg = $ri_first->[$n];
my $iend = $ri_last->[$n];
if ( $ibeg eq $closing_index ) { $n--; last }
return if ( $lev_start != $levels_to_go[$ibeg] );
return if ( $ci_start_plus != $ci_levels_to_go[$ibeg] );
last if ( $closing_index <= $iend );
}
# we can reduce the indentation of all continuation lines
my $continuation_line_count = $n - $line_open;
@ci_levels_to_go[ @{$ri_first}[ $line_1 .. $n ] ] =
(0) x ($continuation_line_count);
@leading_spaces_to_go[ @{$ri_first}[ $line_1 .. $n ] ] =
@reduced_spaces_to_go[ @{$ri_first}[ $line_1 .. $n ] ];
return;
}
###############################################
# CODE SECTION 10: Code to break long statments
###############################################
sub set_continuation_breaks {
# Called once per batch to set breaks in long lines.
# Define an array of indexes for inserting newline characters to
# keep the line lengths below the maximum desired length. There is
# an implied break after the last token, so it need not be included.
# Method:
# This routine is part of series of routines which adjust line
# lengths. It is only called if a statement is longer than the
# maximum line length, or if a preliminary scanning located
# desirable break points. Sub scan_list has already looked at
# these tokens and set breakpoints (in array
# $forced_breakpoint_to_go[$i]) where it wants breaks (for example
# after commas, after opening parens, and before closing parens).
# This routine will honor these breakpoints and also add additional
# breakpoints as necessary to keep the line length below the maximum
# requested. It bases its decision on where the 'bond strength' is
# lowest.
# Output: returns references to the arrays:
# @i_first
# @i_last
# which contain the indexes $i of the first and last tokens on each
# line.
# In addition, the array:
# $forced_breakpoint_to_go[$i]
# may be updated to be =1 for any index $i after which there must be
# a break. This signals later routines not to undo the breakpoint.
my ( $self, $saw_good_break, $rcolon_list ) = @_;
# @{$rcolon_list} is a list of all the ? and : tokens in the batch, in
# order.
use constant DEBUG_BREAKPOINTS => 0;
my @i_first = (); # the first index to output
my @i_last = (); # the last index to output
my @i_colon_breaks = (); # needed to decide if we have to break at ?'s
if ( $types_to_go[0] eq ':' ) { push @i_colon_breaks, 0 }
$self->set_bond_strengths();
my $imin = 0;
my $imax = $max_index_to_go;
if ( $types_to_go[$imin] eq 'b' ) { $imin++ }
if ( $types_to_go[$imax] eq 'b' ) { $imax-- }
my $i_begin = $imin; # index for starting next iteration
my $leading_spaces = leading_spaces_to_go($imin);
my $line_count = 0;
my $last_break_strength = NO_BREAK;
my $i_last_break = -1;
my $max_bias = 0.001;
my $tiny_bias = 0.0001;
my $leading_alignment_token = "";
my $leading_alignment_type = "";
# see if any ?/:'s are in order
my $colons_in_order = 1;
my $last_tok = "";
foreach ( @{$rcolon_list} ) {
if ( $_ eq $last_tok ) { $colons_in_order = 0; last }
$last_tok = $_;
}
# This is a sufficient but not necessary condition for colon chain
my $is_colon_chain = ( $colons_in_order && @{$rcolon_list} > 2 );
my $Msg = "";
#-------------------------------------------------------
# BEGINNING of main loop to set continuation breakpoints
# Keep iterating until we reach the end
#-------------------------------------------------------
while ( $i_begin <= $imax ) {
my $lowest_strength = NO_BREAK;
my $starting_sum = $summed_lengths_to_go[$i_begin];
my $i_lowest = -1;
my $i_test = -1;
my $lowest_next_token = '';
my $lowest_next_type = 'b';
my $i_lowest_next_nonblank = -1;
my $maximum_line_length =
$maximum_line_length_at_level[ $levels_to_go[$i_begin] ];
#-------------------------------------------------------
# BEGINNING of inner loop to find the best next breakpoint
#-------------------------------------------------------
my $strength = NO_BREAK;
for ( $i_test = $i_begin ; $i_test <= $imax ; $i_test++ ) {
my $type = $types_to_go[$i_test];
my $token = $tokens_to_go[$i_test];
my $next_type = $types_to_go[ $i_test + 1 ];
my $next_token = $tokens_to_go[ $i_test + 1 ];
my $i_next_nonblank = $inext_to_go[$i_test];
my $next_nonblank_type = $types_to_go[$i_next_nonblank];
my $next_nonblank_token = $tokens_to_go[$i_next_nonblank];
my $next_nonblank_block_type = $block_type_to_go[$i_next_nonblank];
# adjustments to the previous bond strength may have been made, and
# we must keep the bond strength of a token and its following blank
# the same;
my $last_strength = $strength;
$strength = $bond_strength_to_go[$i_test];
if ( $type eq 'b' ) { $strength = $last_strength }
# reduce strength a bit to break ties at an old comma breakpoint ...
if (
$old_breakpoint_to_go[$i_test]
# Patch: limited to just commas to avoid blinking states
&& $type eq ','
# which is a 'good' breakpoint, meaning ...
# we don't want to break before it
&& !$want_break_before{$type}
# and either we want to break before the next token
# or the next token is not short (i.e. not a '*', '/' etc.)
&& $i_next_nonblank <= $imax
&& ( $want_break_before{$next_nonblank_type}
|| $token_lengths_to_go[$i_next_nonblank] > 2
|| $next_nonblank_type eq ','
|| $is_opening_type{$next_nonblank_type} )
)
{
$strength -= $tiny_bias;
DEBUG_BREAKPOINTS && do { $Msg .= " :-bias at i=$i_test" };
}
# otherwise increase strength a bit if this token would be at the
# maximum line length. This is necessary to avoid blinking
# in the above example when the -iob flag is added.
else {
my $len =
$leading_spaces +
$summed_lengths_to_go[ $i_test + 1 ] -
$starting_sum;
if ( $len >= $maximum_line_length ) {
$strength += $tiny_bias;
DEBUG_BREAKPOINTS && do { $Msg .= " :+bias at i=$i_test" };
}
}
my $must_break = 0;
# Force an immediate break at certain operators
# with lower level than the start of the line,
# unless we've already seen a better break.
#
##############################################
# Note on an issue with a preceding ?
##############################################
# We don't include a ? in the above list, but there may
# be a break at a previous ? if the line is long.
# Because of this we do not want to force a break if
# there is a previous ? on this line. For now the best way
# to do this is to not break if we have seen a lower strength
# point, which is probably a ?.
#
# Example of unwanted breaks we are avoiding at a '.' following a ?
# from pod2html using perltidy -gnu:
# )
# ? "\n<A NAME=\""
# . $value
# . "\">\n$text</A>\n"
# : "\n$type$pod2.html\#" . $value . "\">$text<\/A>\n";
if (
( $strength <= $lowest_strength )
&& ( $nesting_depth_to_go[$i_begin] >
$nesting_depth_to_go[$i_next_nonblank] )
&& (
$next_nonblank_type =~ /^(\.|\&\&|\|\|)$/
|| ( $next_nonblank_type eq 'k'
&& $next_nonblank_token =~ /^(and|or)$/ )
)
)
{
$self->set_forced_breakpoint($i_next_nonblank);
DEBUG_BREAKPOINTS
&& do { $Msg .= " :Forced break at i=$i_next_nonblank" };
}
if (
# Try to put a break where requested by scan_list
$forced_breakpoint_to_go[$i_test]
# break between ) { in a continued line so that the '{' can
# be outdented
# See similar logic in scan_list which catches instances
# where a line is just something like ') {'. We have to
# be careful because the corresponding block keyword might
# not be on the first line, such as 'for' here:
#
# eval {
# for ("a") {
# for $x ( 1, 2 ) { local $_ = "b"; s/(.*)/+$1/ }
# }
# };
#
|| (
$line_count
&& ( $token eq ')' )
&& ( $next_nonblank_type eq '{' )
&& ($next_nonblank_block_type)
&& ( $next_nonblank_block_type ne $tokens_to_go[$i_begin] )
# RT #104427: Dont break before opening sub brace because
# sub block breaks handled at higher level, unless
# it looks like the preceding list is long and broken
&& !(
$next_nonblank_block_type =~ /$ANYSUB_PATTERN/
&& ( $nesting_depth_to_go[$i_begin] ==
$nesting_depth_to_go[$i_next_nonblank] )
)
&& !$rOpts->{'opening-brace-always-on-right'}
)
# There is an implied forced break at a terminal opening brace
|| ( ( $type eq '{' ) && ( $i_test == $imax ) )
)
{
# Forced breakpoints must sometimes be overridden, for example
# because of a side comment causing a NO_BREAK. It is easier
# to catch this here than when they are set.
if ( $strength < NO_BREAK - 1 ) {
$strength = $lowest_strength - $tiny_bias;
$must_break = 1;
DEBUG_BREAKPOINTS
&& do { $Msg .= " :set must_break at i=$i_next_nonblank" };
}
}
# quit if a break here would put a good terminal token on
# the next line and we already have a possible break
if (
!$must_break
&& ( $next_nonblank_type eq ';' || $next_nonblank_type eq ',' )
&& (
(
$leading_spaces +
$summed_lengths_to_go[ $i_next_nonblank + 1 ] -
$starting_sum
) > $maximum_line_length
)
)
{
if ( $i_lowest >= 0 ) {
DEBUG_BREAKPOINTS && do {
$Msg .= " :quit at good terminal='$next_nonblank_type'";
};
last;
}
}
# Avoid a break which would strand a single punctuation
# token. For example, we do not want to strand a leading
# '.' which is followed by a long quoted string.
# But note that we do want to do this with -extrude (l=1)
# so please test any changes to this code on -extrude.
if (
!$must_break
&& ( $i_test == $i_begin )
&& ( $i_test < $imax )
&& ( $token eq $type )
&& (
(
$leading_spaces +
$summed_lengths_to_go[ $i_test + 1 ] -
$starting_sum
) < $maximum_line_length
)
)
{
$i_test = min( $imax, $inext_to_go[$i_test] );
DEBUG_BREAKPOINTS && do {
$Msg .= " :redo at i=$i_test";
};
redo;
}
if ( ( $strength <= $lowest_strength ) && ( $strength < NO_BREAK ) )
{
# break at previous best break if it would have produced
# a leading alignment of certain common tokens, and it
# is different from the latest candidate break
if ($leading_alignment_type) {
DEBUG_BREAKPOINTS && do {
$Msg .=
" :last at leading_alignment='$leading_alignment_type'";
};
last;
}
# Force at least one breakpoint if old code had good
# break It is only called if a breakpoint is required or
# desired. This will probably need some adjustments
# over time. A goal is to try to be sure that, if a new
# side comment is introduced into formatted text, then
# the same breakpoints will occur. scbreak.t
if (
$i_test == $imax # we are at the end
&& !get_forced_breakpoint_count()
&& $saw_good_break # old line had good break
&& $type =~ /^[#;\{]$/ # and this line ends in
# ';' or side comment
&& $i_last_break < 0 # and we haven't made a break
&& $i_lowest >= 0 # and we saw a possible break
&& $i_lowest < $imax - 1 # (but not just before this ;)
&& $strength - $lowest_strength < 0.5 * WEAK # and it's good
)
{
DEBUG_BREAKPOINTS && do {
$Msg .= " :last at good old break\n";
};
last;
}
# Do not skip past an important break point in a short final
# segment. For example, without this check we would miss the
# break at the final / in the following code:
#
# $depth_stop =
# ( $tau * $mass_pellet * $q_0 *
# ( 1. - exp( -$t_stop / $tau ) ) -
# 4. * $pi * $factor * $k_ice *
# ( $t_melt - $t_ice ) *
# $r_pellet *
# $t_stop ) /
# ( $rho_ice * $Qs * $pi * $r_pellet**2 );
#
if (
$line_count > 2
&& $i_lowest >= 0 # and we saw a possible break
&& $i_lowest < $i_test
&& $i_test > $imax - 2
&& $nesting_depth_to_go[$i_begin] >
$nesting_depth_to_go[$i_lowest]
&& $lowest_strength < $last_break_strength - .5 * WEAK
)
{
# Make this break for math operators for now
my $ir = $inext_to_go[$i_lowest];
my $il = $iprev_to_go[$ir];
if ( $types_to_go[$il] =~ /^[\/\*\+\-\%]$/
|| $types_to_go[$ir] =~ /^[\/\*\+\-\%]$/ )
{
DEBUG_BREAKPOINTS && do {
$Msg .= " :last-noskip_short";
};
last;
}
}
# Update the minimum bond strength location
$lowest_strength = $strength;
$i_lowest = $i_test;
$lowest_next_token = $next_nonblank_token;
$lowest_next_type = $next_nonblank_type;
$i_lowest_next_nonblank = $i_next_nonblank;
if ($must_break) {
DEBUG_BREAKPOINTS && do {
$Msg .= " :last-must_break";
};
last;
}
# set flags to remember if a break here will produce a
# leading alignment of certain common tokens
if ( $line_count > 0
&& $i_test < $imax
&& ( $lowest_strength - $last_break_strength <= $max_bias )
)
{
my $i_last_end = $iprev_to_go[$i_begin];
my $tok_beg = $tokens_to_go[$i_begin];
my $type_beg = $types_to_go[$i_begin];
if (
# check for leading alignment of certain tokens
(
$tok_beg eq $next_nonblank_token
&& $is_chain_operator{$tok_beg}
&& ( $type_beg eq 'k'
|| $type_beg eq $tok_beg )
&& $nesting_depth_to_go[$i_begin] >=
$nesting_depth_to_go[$i_next_nonblank]
)
|| ( $tokens_to_go[$i_last_end] eq $token
&& $is_chain_operator{$token}
&& ( $type eq 'k' || $type eq $token )
&& $nesting_depth_to_go[$i_last_end] >=
$nesting_depth_to_go[$i_test] )
)
{
$leading_alignment_token = $next_nonblank_token;
$leading_alignment_type = $next_nonblank_type;
}
}
}
my $too_long = ( $i_test >= $imax );
if ( !$too_long ) {
my $next_length =
$leading_spaces +
$summed_lengths_to_go[ $i_test + 2 ] -
$starting_sum;
$too_long = $next_length > $maximum_line_length;
# To prevent blinkers we will avoid leaving a token exactly at
# the line length limit unless it is the last token or one of
# several "good" types.
#
# The following code was a blinker with -pbp before this
# modification:
## $last_nonblank_token eq '('
## && $is_indirect_object_taker{ $paren_type
## [$paren_depth] }
# The issue causing the problem is that if the
# term [$paren_depth] gets broken across a line then
# the whitespace routine doesn't see both opening and closing
# brackets and will format like '[ $paren_depth ]'. This
# leads to an oscillation in length depending if we break
# before the closing bracket or not.
if ( !$too_long
&& $i_test + 1 < $imax
&& $next_nonblank_type ne ','
&& !$is_closing_type{$next_nonblank_type} )
{
$too_long = $next_length >= $maximum_line_length;
DEBUG_BREAKPOINTS && do {
$Msg .= " :too_long=$too_long" if ($too_long);
}
}
}
DEBUG_BREAKPOINTS && do {
my $ltok = $token;
my $rtok = $next_nonblank_token ? $next_nonblank_token : "";
my $i_testp2 = $i_test + 2;
if ( $i_testp2 > $max_index_to_go + 1 ) {
$i_testp2 = $max_index_to_go + 1;
}
if ( length($ltok) > 6 ) { $ltok = substr( $ltok, 0, 8 ) }
if ( length($rtok) > 6 ) { $rtok = substr( $rtok, 0, 8 ) }
print STDOUT
"BREAK: i=$i_test imax=$imax $types_to_go[$i_test] $next_nonblank_type sp=($leading_spaces) lnext= $summed_lengths_to_go[$i_testp2] 2long=$too_long str=$strength $ltok $rtok\n";
};
# allow one extra terminal token after exceeding line length
# if it would strand this token.
if ( $rOpts_fuzzy_line_length
&& $too_long
&& $i_lowest == $i_test
&& $token_lengths_to_go[$i_test] > 1
&& ( $next_nonblank_type eq ';' || $next_nonblank_type eq ',' )
)
{
$too_long = 0;
DEBUG_BREAKPOINTS && do {
$Msg .= " :do_not_strand next='$next_nonblank_type'";
};
}
# we are done if...
if (
# ... no more space and we have a break
$too_long && $i_lowest >= 0
# ... or no more tokens
|| $i_test == $imax
)
{
DEBUG_BREAKPOINTS && do {
$Msg .=
" :Done-too_long=$too_long or i_lowest=$i_lowest or $i_test==imax";
};
last;
}
}
#-------------------------------------------------------
# END of inner loop to find the best next breakpoint
# Now decide exactly where to put the breakpoint
#-------------------------------------------------------
# it's always ok to break at imax if no other break was found
if ( $i_lowest < 0 ) { $i_lowest = $imax }
# semi-final index calculation
my $i_next_nonblank = $inext_to_go[$i_lowest];
my $next_nonblank_type = $types_to_go[$i_next_nonblank];
my $next_nonblank_token = $tokens_to_go[$i_next_nonblank];
#-------------------------------------------------------
# ?/: rule 1 : if a break here will separate a '?' on this
# line from its closing ':', then break at the '?' instead.
#-------------------------------------------------------
foreach my $i ( $i_begin + 1 .. $i_lowest - 1 ) {
next unless ( $tokens_to_go[$i] eq '?' );
# do not break if probable sequence of ?/: statements
next if ($is_colon_chain);
# do not break if statement is broken by side comment
next
if ( $tokens_to_go[$max_index_to_go] eq '#'
&& terminal_type_i( 0, $max_index_to_go ) !~ /^[\;\}]$/ );
# no break needed if matching : is also on the line
next
if ( $mate_index_to_go[$i] >= 0
&& $mate_index_to_go[$i] <= $i_next_nonblank );
$i_lowest = $i;
if ( $want_break_before{'?'} ) { $i_lowest-- }
last;
}
#-------------------------------------------------------
# END of inner loop to find the best next breakpoint:
# Break the line after the token with index i=$i_lowest
#-------------------------------------------------------
# final index calculation
$i_next_nonblank = $inext_to_go[$i_lowest];
$next_nonblank_type = $types_to_go[$i_next_nonblank];
$next_nonblank_token = $tokens_to_go[$i_next_nonblank];
DEBUG_BREAKPOINTS
&& print STDOUT
"BREAK: best is i = $i_lowest strength = $lowest_strength;\nReason>> $Msg\n";
$Msg = "";
#-------------------------------------------------------
# ?/: rule 2 : if we break at a '?', then break at its ':'
#
# Note: this rule is also in sub scan_list to handle a break
# at the start and end of a line (in case breaks are dictated
# by side comments).
#-------------------------------------------------------
if ( $next_nonblank_type eq '?' ) {
$self->set_closing_breakpoint($i_next_nonblank);
}
elsif ( $types_to_go[$i_lowest] eq '?' ) {
$self->set_closing_breakpoint($i_lowest);
}
#-------------------------------------------------------
# ?/: rule 3 : if we break at a ':' then we save
# its location for further work below. We may need to go
# back and break at its '?'.
#-------------------------------------------------------
if ( $next_nonblank_type eq ':' ) {
push @i_colon_breaks, $i_next_nonblank;
}
elsif ( $types_to_go[$i_lowest] eq ':' ) {
push @i_colon_breaks, $i_lowest;
}
# here we should set breaks for all '?'/':' pairs which are
# separated by this line
$line_count++;
# save this line segment, after trimming blanks at the ends
push( @i_first,
( $types_to_go[$i_begin] eq 'b' ) ? $i_begin + 1 : $i_begin );
push( @i_last,
( $types_to_go[$i_lowest] eq 'b' ) ? $i_lowest - 1 : $i_lowest );
# set a forced breakpoint at a container opening, if necessary, to
# signal a break at a closing container. Excepting '(' for now.
if (
(
$tokens_to_go[$i_lowest] eq '{'
|| $tokens_to_go[$i_lowest] eq '['
)
&& !$forced_breakpoint_to_go[$i_lowest]
)
{
$self->set_closing_breakpoint($i_lowest);
}
# get ready to go again
$i_begin = $i_lowest + 1;
$last_break_strength = $lowest_strength;
$i_last_break = $i_lowest;
$leading_alignment_token = "";
$leading_alignment_type = "";
$lowest_next_token = '';
$lowest_next_type = 'b';
if ( ( $i_begin <= $imax ) && ( $types_to_go[$i_begin] eq 'b' ) ) {
$i_begin++;
}
# update indentation size
if ( $i_begin <= $imax ) {
$leading_spaces = leading_spaces_to_go($i_begin);
DEBUG_BREAKPOINTS
&& print STDOUT
"updating leading spaces to be $leading_spaces at i=$i_begin\n";
}
}
#-------------------------------------------------------
# END of main loop to set continuation breakpoints
# Now go back and make any necessary corrections
#-------------------------------------------------------
#-------------------------------------------------------
# ?/: rule 4 -- if we broke at a ':', then break at
# corresponding '?' unless this is a chain of ?: expressions
#-------------------------------------------------------
if (@i_colon_breaks) {
# using a simple method for deciding if we are in a ?/: chain --
# this is a chain if it has multiple ?/: pairs all in order;
# otherwise not.
# Note that if line starts in a ':' we count that above as a break
my $is_chain = ( $colons_in_order && @i_colon_breaks > 1 );
unless ($is_chain) {
my @insert_list = ();
foreach (@i_colon_breaks) {
my $i_question = $mate_index_to_go[$_];
if ( $i_question >= 0 ) {
if ( $want_break_before{'?'} ) {
$i_question = $iprev_to_go[$i_question];
}
if ( $i_question >= 0 ) {
push @insert_list, $i_question;
}
}
$self->insert_additional_breaks( \@insert_list, \@i_first,
\@i_last );
}
}
}
return ( \@i_first, \@i_last );
}
###########################################
# CODE SECTION 11: Code to break long lists
###########################################
{ ## begin closure scan_list
# These routines and variables are involved in finding good
# places to break long lists.
my (
$block_type, $current_depth,
$depth, $i,
$i_last_nonblank_token, $last_colon_sequence_number,
$last_nonblank_token, $last_nonblank_type,
$last_nonblank_block_type, $last_old_breakpoint_count,
$minimum_depth, $next_nonblank_block_type,
$next_nonblank_token, $next_nonblank_type,
$old_breakpoint_count, $starting_breakpoint_count,
$starting_depth, $token,
$type, $type_sequence,
);
my (
@breakpoint_stack, @breakpoint_undo_stack,
@comma_index, @container_type,
@identifier_count_stack, @index_before_arrow,
@interrupted_list, @item_count_stack,
@last_comma_index, @last_dot_index,
@last_nonblank_type, @old_breakpoint_count_stack,
@opening_structure_index_stack, @rfor_semicolon_list,
@has_old_logical_breakpoints, @rand_or_list,
@i_equals, @override_cab3,
@type_sequence_stack,
);
# these arrays must retain values between calls
my ( @has_broken_sublist, @dont_align, @want_comma_break );
my $length_tol;
my $length_tol_boost;
sub initialize_scan_list {
@dont_align = ();
@has_broken_sublist = ();
@want_comma_break = ();
####################################################
# Set tolerances to prevent formatting instabilities
####################################################
# Define tolerances to use when checking if closed
# containers will fit on one line. This is necessary to avoid
# formatting instability. The basic tolerance is based on the
# following:
# - Always allow for at least one extra space after a closing token so
# that we do not strand a comma or semicolon. (oneline.t).
# - Use an increased line length tolerance when -ci > -i to avoid
# blinking states (case b923 and others).
$length_tol =
1 + max( 0, $rOpts_continuation_indentation - $rOpts_indent_columns );
# In addition, it may be necessary to use a few extra tolerance spaces
# when -lp is used and/or when -xci is used. The history of this
# so far is as follows:
# FIX1: At least 3 characters were been found to be required for -lp
# to fixes cases b1059 b1063 b1117.
# FIX2: Further testing showed that we need a total of 3 extra spaces
# when -lp is set for non-lists, and at least 2 spaces when -lp and
# -xci are set.
# Fixes cases b1063 b1103 b1134 b1135 b1136 b1138 b1140 b1143 b1144
# b1145 b1146 b1147 b1148 b1151 b1152 b1153 b1154 b1156 b1157 b1164
# b1165
# FIX3: To fix cases b1169 b1170 b1171, an update was made in sub
# 'find_token_starting_list' to go back before an initial blank space.
# This fixed these three cases, and allowed the tolerances to be
# reduced to continue to fix all other known cases of instability.
# This gives the current tolerance formulation (note that
# variable $length_tol_boost is always 0 now):
$length_tol_boost = 0;
if ($rOpts_line_up_parentheses) {
if ( $rOpts->{'extended-continuation-indentation'} ) {
$length_tol += 2;
$length_tol_boost = 0; # was 1 for FIX2, 0 for FIX3
}
else {
$length_tol_boost = 0; # was 3 for FIX2, 0 for FIX3
}
}
# The -xci option alone also needs a slightly larger tol for non-lists
elsif ( $rOpts->{'extended-continuation-indentation'} ) {
$length_tol_boost = 0; # was 1 for FIX2, 0 for FIX3
}
return;
}
# routine to define essential variables when we go 'up' to
# a new depth
sub check_for_new_minimum_depth {
my $depth = shift;
if ( $depth < $minimum_depth ) {
$minimum_depth = $depth;
# these arrays need not retain values between calls
$breakpoint_stack[$depth] = $starting_breakpoint_count;
$container_type[$depth] = "";
$identifier_count_stack[$depth] = 0;
$index_before_arrow[$depth] = -1;
$interrupted_list[$depth] = 1;
$item_count_stack[$depth] = 0;
$last_nonblank_type[$depth] = "";
$opening_structure_index_stack[$depth] = -1;
$breakpoint_undo_stack[$depth] = undef;
$comma_index[$depth] = undef;
$last_comma_index[$depth] = undef;
$last_dot_index[$depth] = undef;
$old_breakpoint_count_stack[$depth] = undef;
$has_old_logical_breakpoints[$depth] = 0;
$rand_or_list[$depth] = [];
$rfor_semicolon_list[$depth] = [];
$i_equals[$depth] = -1;
# these arrays must retain values between calls
if ( !defined( $has_broken_sublist[$depth] ) ) {
$dont_align[$depth] = 0;
$has_broken_sublist[$depth] = 0;
$want_comma_break[$depth] = 0;
}
}
return;
}
# routine to decide which commas to break at within a container;
# returns:
# $bp_count = number of comma breakpoints set
# $do_not_break_apart = a flag indicating if container need not
# be broken open
sub set_comma_breakpoints {
my ( $self, $dd ) = @_;
my $bp_count = 0;
my $do_not_break_apart = 0;
# anything to do?
if ( $item_count_stack[$dd] ) {
# handle commas not in containers...
if ( $dont_align[$dd] ) {
$self->do_uncontained_comma_breaks($dd);
}
# handle commas within containers...
else {
my $fbc = get_forced_breakpoint_count();
# always open comma lists not preceded by keywords,
# barewords, identifiers (that is, anything that doesn't
# look like a function call)
my $must_break_open = $last_nonblank_type[$dd] !~ /^[kwiU]$/;
$self->set_comma_breakpoints_do(
{
depth => $dd,
i_opening_paren => $opening_structure_index_stack[$dd],
i_closing_paren => $i,
item_count => $item_count_stack[$dd],
identifier_count => $identifier_count_stack[$dd],
rcomma_index => $comma_index[$dd],
next_nonblank_type => $next_nonblank_type,
list_type => $container_type[$dd],
interrupted => $interrupted_list[$dd],
rdo_not_break_apart => \$do_not_break_apart,
must_break_open => $must_break_open,
has_broken_sublist => $has_broken_sublist[$dd],
}
);
$bp_count = get_forced_breakpoint_count() - $fbc;
$do_not_break_apart = 0 if $must_break_open;
}
}
return ( $bp_count, $do_not_break_apart );
}
# These types are excluded at breakpoints to prevent blinking
my %is_uncontained_comma_break_excluded_type;
BEGIN {
my @q = qw< L { ( [ ? : + - >;
@is_uncontained_comma_break_excluded_type{@q} = (1) x scalar(@q);
}
sub do_uncontained_comma_breaks {
# Handle commas not in containers...
# This is a catch-all routine for commas that we
# don't know what to do with because the don't fall
# within containers. We will bias the bond strength
# to break at commas which ended lines in the input
# file. This usually works better than just trying
# to put as many items on a line as possible. A
# downside is that if the input file is garbage it
# won't work very well. However, the user can always
# prevent following the old breakpoints with the
# -iob flag.
my ( $self, $dd ) = @_;
my $bias = -.01;
my $old_comma_break_count = 0;
foreach my $ii ( @{ $comma_index[$dd] } ) {
if ( $old_breakpoint_to_go[$ii] ) {
$old_comma_break_count++;
$bond_strength_to_go[$ii] = $bias;
# reduce bias magnitude to force breaks in order
$bias *= 0.99;
}
}
# Also put a break before the first comma if
# (1) there was a break there in the input, and
# (2) there was exactly one old break before the first comma break
# (3) OLD: there are multiple old comma breaks
# (3) NEW: there are one or more old comma breaks (see return example)
# (4) the first comma is at the starting level ...
# ... fixes cases b064 b065 b068 b210 b747
#
# For example, we will follow the user and break after
# 'print' in this snippet:
# print
# "conformability (Not the same dimension)\n",
# "\t", $have, " is ", text_unit($hu), "\n",
# "\t", $want, " is ", text_unit($wu), "\n",
# ;
#
# Another example, just one comma, where we will break after
# the return:
# return
# $x * cos($a) - $y * sin($a),
# $x * sin($a) + $y * cos($a);
# Breaking a print statement:
# print SAVEOUT
# ( $? & 127 ) ? " (SIG#" . ( $? & 127 ) . ")" : "",
# ( $? & 128 ) ? " -- core dumped" : "", "\n";
#
# But we will not force a break after the opening paren here
# (causes a blinker):
# $heap->{stream}->set_output_filter(
# poe::filter::reference->new('myotherfreezer') ),
# ;
#
my $i_first_comma = $comma_index[$dd]->[0];
my $level_comma = $levels_to_go[$i_first_comma];
if ( $old_breakpoint_to_go[$i_first_comma]
&& $level_comma == $levels_to_go[0] )
{
my $ibreak = -1;
my $obp_count = 0;
for ( my $ii = $i_first_comma - 1 ; $ii >= 0 ; $ii -= 1 ) {
if ( $old_breakpoint_to_go[$ii] ) {
$obp_count++;
last if ( $obp_count > 1 );
$ibreak = $ii
if ( $levels_to_go[$ii] == $level_comma );
}
}
# Changed rule from multiple old commas to just one here:
if ( $ibreak >= 0 && $obp_count == 1 && $old_comma_break_count > 0 )
{
my $ibreakm = $ibreak;
$ibreakm-- if ( $types_to_go[$ibreakm] eq 'b' );
if ( $ibreakm >= 0 ) {
# In order to avoid blinkers we have to be fairly
# restrictive:
# Rule 1: Do not to break before an opening token
# Rule 2: avoid breaking at ternary operators
# (see b931, which is similar to the above print example)
# Rule 3: Do not break at chain operators to fix case b1119
# - The previous test was '$typem !~ /^[\(\{\[L\?\:]$/'
# Be sure to test any changes to these rules against runs
# with -l=0 such as the 'bbvt' test (perltidyrc_colin)
# series.
my $typem = $types_to_go[$ibreakm];
if ( !$is_uncontained_comma_break_excluded_type{$typem} ) {
$self->set_forced_breakpoint($ibreak);
}
}
}
}
return;
}
my %is_logical_container;
my %quick_filter;
BEGIN {
my @q = qw# if elsif unless while and or err not && | || ? : ! #;
@is_logical_container{@q} = (1) x scalar(@q);
# This filter will allow most tokens to skip past a section of code
%quick_filter = %is_assignment;
@q = qw# => . ; < > ~ #;
push @q, ',';
@quick_filter{@q} = (1) x scalar(@q);
}
sub set_for_semicolon_breakpoints {
my ( $self, $dd ) = @_;
foreach ( @{ $rfor_semicolon_list[$dd] } ) {
$self->set_forced_breakpoint($_);
}
return;
}
sub set_logical_breakpoints {
my ( $self, $dd ) = @_;
if (
$item_count_stack[$dd] == 0
&& $is_logical_container{ $container_type[$dd] }
|| $has_old_logical_breakpoints[$dd]
)
{
# Look for breaks in this order:
# 0 1 2 3
# or and || &&
foreach my $i ( 0 .. 3 ) {
if ( $rand_or_list[$dd][$i] ) {
foreach ( @{ $rand_or_list[$dd][$i] } ) {
$self->set_forced_breakpoint($_);
}
# break at any 'if' and 'unless' too
foreach ( @{ $rand_or_list[$dd][4] } ) {
$self->set_forced_breakpoint($_);
}
$rand_or_list[$dd] = [];
last;
}
}
}
return;
}
sub is_unbreakable_container {
# never break a container of one of these types
# because bad things can happen (map1.t)
my $dd = shift;
return $is_sort_map_grep{ $container_type[$dd] };
}
sub scan_list {
my ( $self, $is_long_line ) = @_;
# This routine is responsible for setting line breaks for all lists,
# so that hierarchical structure can be displayed and so that list
# items can be vertically aligned. The output of this routine is
# stored in the array @forced_breakpoint_to_go, which is used to set
# final breakpoints.
# It is called once per batch if the batch is a list.
my $rLL = $self->[_rLL_];
my $ris_list_by_seqno = $self->[_ris_list_by_seqno_];
my $ris_broken_container = $self->[_ris_broken_container_];
my $rbreak_before_container_by_seqno =
$self->[_rbreak_before_container_by_seqno_];
$starting_depth = $nesting_depth_to_go[0];
$block_type = ' ';
$current_depth = $starting_depth;
$i = -1;
$last_colon_sequence_number = -1;
$last_nonblank_token = ';';
$last_nonblank_type = ';';
$last_nonblank_block_type = ' ';
$last_old_breakpoint_count = 0;
$minimum_depth = $current_depth + 1; # forces update in check below
$old_breakpoint_count = 0;
$starting_breakpoint_count = get_forced_breakpoint_count();
$token = ';';
$type = ';';
$type_sequence = '';
my $total_depth_variation = 0;
my $i_old_assignment_break;
my $depth_last = $starting_depth;
check_for_new_minimum_depth($current_depth);
my $want_previous_breakpoint = -1;
my $saw_good_breakpoint;
my $i_line_end = -1;
my $i_line_start = -1;
# loop over all tokens in this batch
while ( ++$i <= $max_index_to_go ) {
if ( $type ne 'b' ) {
$i_last_nonblank_token = $i - 1;
$last_nonblank_type = $type;
$last_nonblank_token = $token;
$last_nonblank_block_type = $block_type;
} ## end if ( $type ne 'b' )
$type = $types_to_go[$i];
$block_type = $block_type_to_go[$i];
$token = $tokens_to_go[$i];
$type_sequence = $type_sequence_to_go[$i];
my $next_type = $types_to_go[ $i + 1 ];
my $next_token = $tokens_to_go[ $i + 1 ];
my $i_next_nonblank = ( ( $next_type eq 'b' ) ? $i + 2 : $i + 1 );
$next_nonblank_type = $types_to_go[$i_next_nonblank];
$next_nonblank_token = $tokens_to_go[$i_next_nonblank];
$next_nonblank_block_type = $block_type_to_go[$i_next_nonblank];
# set break if flag was set
if ( $want_previous_breakpoint >= 0 ) {
$self->set_forced_breakpoint($want_previous_breakpoint);
$want_previous_breakpoint = -1;
}
$last_old_breakpoint_count = $old_breakpoint_count;
# Fixed for case b1097 to not consider old breaks at highly
# stressed locations, such as types 'L' and 'R'. It might be
# useful to generalize this concept in the future by looking at
# actual bond strengths.
if ( $old_breakpoint_to_go[$i]
&& $type ne 'L'
&& $next_nonblank_type ne 'R' )
{
$i_line_end = $i;
$i_line_start = $i_next_nonblank;
$old_breakpoint_count++;
# Break before certain keywords if user broke there and
# this is a 'safe' break point. The idea is to retain
# any preferred breaks for sequential list operations,
# like a schwartzian transform.
if ($rOpts_break_at_old_keyword_breakpoints) {
if (
$next_nonblank_type eq 'k'
&& $is_keyword_returning_list{$next_nonblank_token}
&& ( $type =~ /^[=\)\]\}Riw]$/
|| $type eq 'k'
&& $is_keyword_returning_list{$token} )
)
{
# we actually have to set this break next time through
# the loop because if we are at a closing token (such
# as '}') which forms a one-line block, this break might
# get undone.
# And do not do this at an equals if the user wants
# breaks before an equals (blinker cases b434 b903)
unless ( $type eq '=' && $want_break_before{$type} ) {
$want_previous_breakpoint = $i;
}
} ## end if ( $next_nonblank_type...)
} ## end if ($rOpts_break_at_old_keyword_breakpoints)
# Break before attributes if user broke there
if ($rOpts_break_at_old_attribute_breakpoints) {
if ( $next_nonblank_type eq 'A' ) {
$want_previous_breakpoint = $i;
}
}
# remember an = break as possible good break point
if ( $is_assignment{$type} ) {
$i_old_assignment_break = $i;
}
elsif ( $is_assignment{$next_nonblank_type} ) {
$i_old_assignment_break = $i_next_nonblank;
}
} ## end if ( $old_breakpoint_to_go...)
next if ( $type eq 'b' );
$depth = $nesting_depth_to_go[ $i + 1 ];
$total_depth_variation += abs( $depth - $depth_last );
$depth_last = $depth;
# safety check - be sure we always break after a comment
# Shouldn't happen .. an error here probably means that the
# nobreak flag did not get turned off correctly during
# formatting.
if ( $type eq '#' ) {
if ( $i != $max_index_to_go ) {
warning(
"Non-fatal program bug: backup logic required to break after a comment\n"
);
report_definite_bug();
$nobreak_to_go[$i] = 0;
$self->set_forced_breakpoint($i);
} ## end if ( $i != $max_index_to_go)
} ## end if ( $type eq '#' )
# Force breakpoints at certain tokens in long lines.
# Note that such breakpoints will be undone later if these tokens
# are fully contained within parens on a line.
if (
# break before a keyword within a line
$type eq 'k'
&& $i > 0
# if one of these keywords:
# /^(if|unless|while|until|for)$/
&& $is_if_unless_while_until_for{$token}
# but do not break at something like '1 while'
&& ( $last_nonblank_type ne 'n' || $i > 2 )
# and let keywords follow a closing 'do' brace
&& $last_nonblank_block_type ne 'do'
&& (
$is_long_line
# or container is broken (by side-comment, etc)
|| ( $next_nonblank_token eq '('
&& $mate_index_to_go[$i_next_nonblank] < $i )
)
)
{
$self->set_forced_breakpoint( $i - 1 );
} ## end if ( $type eq 'k' && $i...)
# remember locations of '||' and '&&' for possible breaks if we
# decide this is a long logical expression.
if ( $type eq '||' ) {
push @{ $rand_or_list[$depth][2] }, $i;
++$has_old_logical_breakpoints[$depth]
if ( ( $i == $i_line_start || $i == $i_line_end )
&& $rOpts_break_at_old_logical_breakpoints );
} ## end elsif ( $type eq '||' )
elsif ( $type eq '&&' ) {
push @{ $rand_or_list[$depth][3] }, $i;
++$has_old_logical_breakpoints[$depth]
if ( ( $i == $i_line_start || $i == $i_line_end )
&& $rOpts_break_at_old_logical_breakpoints );
} ## end elsif ( $type eq '&&' )
elsif ( $type eq 'f' ) {
push @{ $rfor_semicolon_list[$depth] }, $i;
}
elsif ( $type eq 'k' ) {
if ( $token eq 'and' ) {
push @{ $rand_or_list[$depth][1] }, $i;
++$has_old_logical_breakpoints[$depth]
if ( ( $i == $i_line_start || $i == $i_line_end )
&& $rOpts_break_at_old_logical_breakpoints );
} ## end if ( $token eq 'and' )
# break immediately at 'or's which are probably not in a logical
# block -- but we will break in logical breaks below so that
# they do not add to the forced_breakpoint_count
elsif ( $token eq 'or' ) {
push @{ $rand_or_list[$depth][0] }, $i;
++$has_old_logical_breakpoints[$depth]
if ( ( $i == $i_line_start || $i == $i_line_end )
&& $rOpts_break_at_old_logical_breakpoints );
if ( $is_logical_container{ $container_type[$depth] } ) {
}
else {
if ($is_long_line) { $self->set_forced_breakpoint($i) }
elsif ( ( $i == $i_line_start || $i == $i_line_end )
&& $rOpts_break_at_old_logical_breakpoints )
{
$saw_good_breakpoint = 1;
}
} ## end else [ if ( $is_logical_container...)]
} ## end elsif ( $token eq 'or' )
elsif ( $token eq 'if' || $token eq 'unless' ) {
push @{ $rand_or_list[$depth][4] }, $i;
if ( ( $i == $i_line_start || $i == $i_line_end )
&& $rOpts_break_at_old_logical_breakpoints )
{
$self->set_forced_breakpoint($i);
}
} ## end elsif ( $token eq 'if' ||...)
} ## end elsif ( $type eq 'k' )
elsif ( $is_assignment{$type} ) {
$i_equals[$depth] = $i;
}
if ($type_sequence) {
# handle any postponed closing breakpoints
if ( $is_closing_sequence_token{$token} ) {
if ( $type eq ':' ) {
$last_colon_sequence_number = $type_sequence;
# retain break at a ':' line break
if ( ( $i == $i_line_start || $i == $i_line_end )
&& $rOpts_break_at_old_ternary_breakpoints )
{
$self->set_forced_breakpoint($i);
# break at previous '='
if ( $i_equals[$depth] > 0 ) {
$self->set_forced_breakpoint(
$i_equals[$depth] );
$i_equals[$depth] = -1;
}
} ## end if ( ( $i == $i_line_start...))
} ## end if ( $type eq ':' )
if ( has_postponed_breakpoint($type_sequence) ) {
my $inc = ( $type eq ':' ) ? 0 : 1;
$self->set_forced_breakpoint( $i - $inc );
}
} ## end if ( $is_closing_sequence_token{$token} )
# set breaks at ?/: if they will get separated (and are
# not a ?/: chain), or if the '?' is at the end of the
# line
elsif ( $token eq '?' ) {
my $i_colon = $mate_index_to_go[$i];
if (
$i_colon <= 0 # the ':' is not in this batch
|| $i == 0 # this '?' is the first token of the line
|| $i ==
$max_index_to_go # or this '?' is the last token
)
{
# don't break at a '?' if preceded by ':' on
# this line of previous ?/: pair on this line.
# This is an attempt to preserve a chain of ?/:
# expressions (elsif2.t). And don't break if
# this has a side comment.
$self->set_forced_breakpoint($i)
unless (
$type_sequence == (
$last_colon_sequence_number +
TYPE_SEQUENCE_INCREMENT
)
|| $tokens_to_go[$max_index_to_go] eq '#'
);
$self->set_closing_breakpoint($i);
} ## end if ( $i_colon <= 0 ||...)
} ## end elsif ( $token eq '?' )
} ## end if ($type_sequence)
#print "LISTX sees: i=$i type=$type tok=$token block=$block_type depth=$depth\n";
#------------------------------------------------------------
# Handle Increasing Depth..
#
# prepare for a new list when depth increases
# token $i is a '(','{', or '['
#------------------------------------------------------------
if ( $depth > $current_depth ) {
$type_sequence_stack[$depth] = $type_sequence;
$override_cab3[$depth] =
$rOpts_comma_arrow_breakpoints == 3
&& $type_sequence
&& $self->[_roverride_cab3_]->{$type_sequence};
$breakpoint_stack[$depth] = get_forced_breakpoint_count();
$breakpoint_undo_stack[$depth] =
get_forced_breakpoint_undo_count();
$has_broken_sublist[$depth] = 0;
$identifier_count_stack[$depth] = 0;
$index_before_arrow[$depth] = -1;
$interrupted_list[$depth] = 0;
$item_count_stack[$depth] = 0;
$last_comma_index[$depth] = undef;
$last_dot_index[$depth] = undef;
$last_nonblank_type[$depth] = $last_nonblank_type;
$old_breakpoint_count_stack[$depth] = $old_breakpoint_count;
$opening_structure_index_stack[$depth] = $i;
$rand_or_list[$depth] = [];
$rfor_semicolon_list[$depth] = [];
$i_equals[$depth] = -1;
$want_comma_break[$depth] = 0;
$container_type[$depth] =
# k => && || ? : .
$is_container_label_type{$last_nonblank_type}
? $last_nonblank_token
: "";
$has_old_logical_breakpoints[$depth] = 0;
# if line ends here then signal closing token to break
if ( $next_nonblank_type eq 'b' || $next_nonblank_type eq '#' )
{
$self->set_closing_breakpoint($i);
}
# Not all lists of values should be vertically aligned..
$dont_align[$depth] =
# code BLOCKS are handled at a higher level
( $block_type ne "" )
# certain paren lists
|| ( $type eq '(' ) && (
# it does not usually look good to align a list of
# identifiers in a parameter list, as in:
# my($var1, $var2, ...)
# (This test should probably be refined, for now I'm just
# testing for any keyword)
( $last_nonblank_type eq 'k' )
# a trailing '(' usually indicates a non-list
|| ( $next_nonblank_type eq '(' )
);
# patch to outdent opening brace of long if/for/..
# statements (like this one). See similar coding in
# set_continuation breaks. We have also catch it here for
# short line fragments which otherwise will not go through
# set_continuation_breaks.
if (
$block_type
# if we have the ')' but not its '(' in this batch..
&& ( $last_nonblank_token eq ')' )
&& $mate_index_to_go[$i_last_nonblank_token] < 0
# and user wants brace to left
&& !$rOpts->{'opening-brace-always-on-right'}
&& ( $type eq '{' ) # should be true
&& ( $token eq '{' ) # should be true
)
{
$self->set_forced_breakpoint( $i - 1 );
} ## end if ( $block_type && ( ...))
} ## end if ( $depth > $current_depth)
#------------------------------------------------------------
# Handle Decreasing Depth..
#
# finish off any old list when depth decreases
# token $i is a ')','}', or ']'
#------------------------------------------------------------
elsif ( $depth < $current_depth ) {
check_for_new_minimum_depth($depth);
# force all outer logical containers to break after we see on
# old breakpoint
$has_old_logical_breakpoints[$depth] ||=
$has_old_logical_breakpoints[$current_depth];
# Patch to break between ') {' if the paren list is broken.
# There is similar logic in set_continuation_breaks for
# non-broken lists.
if ( $token eq ')'
&& $next_nonblank_block_type
&& $interrupted_list[$current_depth]
&& $next_nonblank_type eq '{'
&& !$rOpts->{'opening-brace-always-on-right'} )
{
$self->set_forced_breakpoint($i);
} ## end if ( $token eq ')' && ...
#print "LISTY sees: i=$i type=$type tok=$token block=$block_type depth=$depth next=$next_nonblank_type next_block=$next_nonblank_block_type inter=$interrupted_list[$current_depth]\n";
# set breaks at commas if necessary
my ( $bp_count, $do_not_break_apart ) =
$self->set_comma_breakpoints($current_depth);
my $i_opening = $opening_structure_index_stack[$current_depth];
my $saw_opening_structure = ( $i_opening >= 0 );
# this term is long if we had to break at interior commas..
my $is_long_term = $bp_count > 0;
# If this is a short container with one or more comma arrows,
# then we will mark it as a long term to open it if requested.
# $rOpts_comma_arrow_breakpoints =
# 0 - open only if comma precedes closing brace
# 1 - stable: except for one line blocks
# 2 - try to form 1 line blocks
# 3 - ignore =>
# 4 - always open up if vt=0
# 5 - stable: even for one line blocks if vt=0
# PATCH: Modify the -cab flag if we are not processing a list:
# We only want the -cab flag to apply to list containers, so
# for non-lists we use the default and stable -cab=5 value.
# Fixes case b939a.
my $cab_flag = $rOpts_comma_arrow_breakpoints;
if ( $type_sequence && !$ris_list_by_seqno->{$type_sequence} ) {
$cab_flag = 5;
}
if ( !$is_long_term
&& $saw_opening_structure
&& $is_opening_token{ $tokens_to_go[$i_opening] }
&& $index_before_arrow[ $depth + 1 ] > 0
&& !$opening_vertical_tightness{ $tokens_to_go[$i_opening] }
)
{
$is_long_term =
$cab_flag == 4
|| $cab_flag == 0 && $last_nonblank_token eq ','
|| $cab_flag == 5 && $old_breakpoint_to_go[$i_opening];
} ## end if ( !$is_long_term &&...)
# mark term as long if the length between opening and closing
# parens exceeds allowed line length
if ( !$is_long_term && $saw_opening_structure ) {
my $i_opening_minus =
$self->find_token_starting_list($i_opening);
my $excess =
$self->excess_line_length( $i_opening_minus, $i );
my $tol =
$length_tol_boost
&& !$ris_list_by_seqno->{$type_sequence}
? $length_tol + $length_tol_boost
: $length_tol;
# Patch to avoid blinking with -bbxi=2 and -cab=2
# in which variations in -ci cause unstable formatting
# in edge cases. We just always add one ci level so that
# the formatting is independent of the -BBX results.
# Fixes cases b1137 b1149 b1150 b1155 b1158 b1159 b1160
# b1161 b1166 b1167 b1168
if ( !$ci_levels_to_go[$i_opening]
&& $rbreak_before_container_by_seqno->{$type_sequence} )
{
$tol += $rOpts->{'continuation-indentation'};
}
$is_long_term = $excess + $tol > 0;
} ## end if ( !$is_long_term &&...)
# We've set breaks after all comma-arrows. Now we have to
# undo them if this can be a one-line block
# (the only breakpoints set will be due to comma-arrows)
if (
# user doesn't require breaking after all comma-arrows
( $cab_flag != 0 ) && ( $cab_flag != 4 )
# and if the opening structure is in this batch
&& $saw_opening_structure
# and either on the same old line
&& (
$old_breakpoint_count_stack[$current_depth] ==
$last_old_breakpoint_count
# or user wants to form long blocks with arrows
|| $cab_flag == 2
# if -cab=3 is overridden then use -cab=2 behavior
|| $cab_flag == 3 && $override_cab3[$current_depth]
)
# and we made breakpoints between the opening and closing
&& ( $breakpoint_undo_stack[$current_depth] <
get_forced_breakpoint_undo_count() )
# and this block is short enough to fit on one line
# Note: use < because need 1 more space for possible comma
&& !$is_long_term
)
{
$self->undo_forced_breakpoint_stack(
$breakpoint_undo_stack[$current_depth] );
} ## end if ( ( $rOpts_comma_arrow_breakpoints...))
# now see if we have any comma breakpoints left
my $has_comma_breakpoints =
( $breakpoint_stack[$current_depth] !=
get_forced_breakpoint_count() );
# update broken-sublist flag of the outer container
$has_broken_sublist[$depth] =
$has_broken_sublist[$depth]
|| $has_broken_sublist[$current_depth]
|| $is_long_term
|| $has_comma_breakpoints;
# Having come to the closing ')', '}', or ']', now we have to decide if we
# should 'open up' the structure by placing breaks at the opening and
# closing containers. This is a tricky decision. Here are some of the
# basic considerations:
#
# -If this is a BLOCK container, then any breakpoints will have already
# been set (and according to user preferences), so we need do nothing here.
#
# -If we have a comma-separated list for which we can align the list items,
# then we need to do so because otherwise the vertical aligner cannot
# currently do the alignment.
#
# -If this container does itself contain a container which has been broken
# open, then it should be broken open to properly show the structure.
#
# -If there is nothing to align, and no other reason to break apart,
# then do not do it.
#
# We will not break open the parens of a long but 'simple' logical expression.
# For example:
#
# This is an example of a simple logical expression and its formatting:
#
# if ( $bigwasteofspace1 && $bigwasteofspace2
# || $bigwasteofspace3 && $bigwasteofspace4 )
#
# Most people would prefer this than the 'spacey' version:
#
# if (
# $bigwasteofspace1 && $bigwasteofspace2
# || $bigwasteofspace3 && $bigwasteofspace4
# )
#
# To illustrate the rules for breaking logical expressions, consider:
#
# FULLY DENSE:
# if ( $opt_excl
# and ( exists $ids_excl_uc{$id_uc}
# or grep $id_uc =~ /$_/, @ids_excl_uc ))
#
# This is on the verge of being difficult to read. The current default is to
# open it up like this:
#
# DEFAULT:
# if (
# $opt_excl
# and ( exists $ids_excl_uc{$id_uc}
# or grep $id_uc =~ /$_/, @ids_excl_uc )
# )
#
# This is a compromise which tries to avoid being too dense and to spacey.
# A more spaced version would be:
#
# SPACEY:
# if (
# $opt_excl
# and (
# exists $ids_excl_uc{$id_uc}
# or grep $id_uc =~ /$_/, @ids_excl_uc
# )
# )
#
# Some people might prefer the spacey version -- an option could be added. The
# innermost expression contains a long block '( exists $ids_... ')'.
#
# Here is how the logic goes: We will force a break at the 'or' that the
# innermost expression contains, but we will not break apart its opening and
# closing containers because (1) it contains no multi-line sub-containers itself,
# and (2) there is no alignment to be gained by breaking it open like this
#
# and (
# exists $ids_excl_uc{$id_uc}
# or grep $id_uc =~ /$_/, @ids_excl_uc
# )
#
# (although this looks perfectly ok and might be good for long expressions). The
# outer 'if' container, though, contains a broken sub-container, so it will be
# broken open to avoid too much density. Also, since it contains no 'or's, there
# will be a forced break at its 'and'.
# set some flags telling something about this container..
my $is_simple_logical_expression = 0;
if ( $item_count_stack[$current_depth] == 0
&& $saw_opening_structure
&& $tokens_to_go[$i_opening] eq '('
&& $is_logical_container{ $container_type[$current_depth] }
)
{
# This seems to be a simple logical expression with
# no existing breakpoints. Set a flag to prevent
# opening it up.
if ( !$has_comma_breakpoints ) {
$is_simple_logical_expression = 1;
}
# This seems to be a simple logical expression with
# breakpoints (broken sublists, for example). Break
# at all 'or's and '||'s.
else {
$self->set_logical_breakpoints($current_depth);
}
} ## end if ( $item_count_stack...)
if ( $is_long_term
&& @{ $rfor_semicolon_list[$current_depth] } )
{
$self->set_for_semicolon_breakpoints($current_depth);
# open up a long 'for' or 'foreach' container to allow
# leading term alignment unless -lp is used.
$has_comma_breakpoints = 1
unless $rOpts_line_up_parentheses;
} ## end if ( $is_long_term && ...)
if (
# breaks for code BLOCKS are handled at a higher level
!$block_type
# we do not need to break at the top level of an 'if'
# type expression
&& !$is_simple_logical_expression
## modification to keep ': (' containers vertically tight;
## but probably better to let user set -vt=1 to avoid
## inconsistency with other paren types
## && ($container_type[$current_depth] ne ':')
# otherwise, we require one of these reasons for breaking:
&& (
# - this term has forced line breaks
$has_comma_breakpoints
# - the opening container is separated from this batch
# for some reason (comment, blank line, code block)
# - this is a non-paren container spanning multiple lines
|| !$saw_opening_structure
# - this is a long block contained in another breakable
# container
|| $is_long_term && !$self->is_in_block_by_i($i_opening)
)
)
{
# For -lp option, we must put a breakpoint before
# the token which has been identified as starting
# this indentation level. This is necessary for
# proper alignment.
if ( $rOpts_line_up_parentheses && $saw_opening_structure )
{
my $item = $leading_spaces_to_go[ $i_opening + 1 ];
if ( $i_opening + 1 < $max_index_to_go
&& $types_to_go[ $i_opening + 1 ] eq 'b' )
{
$item = $leading_spaces_to_go[ $i_opening + 2 ];
}
if ( defined($item) ) {
my $i_start_2;
my $K_start_2 = $item->get_starting_index_K();
if ( defined($K_start_2) ) {
$i_start_2 = $K_start_2 - $K_to_go[0];
}
if (
defined($i_start_2)
# we are breaking after an opening brace, paren,
# so don't break before it too
&& $i_start_2 ne $i_opening
&& $i_start_2 >= 0
&& $i_start_2 <= $max_index_to_go
)
{
# Only break for breakpoints at the same
# indentation level as the opening paren
my $test1 = $nesting_depth_to_go[$i_opening];
my $test2 = $nesting_depth_to_go[$i_start_2];
if ( $test2 == $test1 ) {
# Back up at a blank (fixes case b932)
my $ibr = $i_start_2 - 1;
if ( $ibr > 0
&& $types_to_go[$ibr] eq 'b' )
{
$ibr--;
}
$self->set_forced_breakpoint($ibr);
}
} ## end if ( defined($i_start_2...))
} ## end if ( defined($item) )
} ## end if ( $rOpts_line_up_parentheses...)
# break after opening structure.
# note: break before closing structure will be automatic
if ( $minimum_depth <= $current_depth ) {
$self->set_forced_breakpoint($i_opening)
unless ( $do_not_break_apart
|| is_unbreakable_container($current_depth) );
# break at ',' of lower depth level before opening token
if ( $last_comma_index[$depth] ) {
$self->set_forced_breakpoint(
$last_comma_index[$depth] );
}
# break at '.' of lower depth level before opening token
if ( $last_dot_index[$depth] ) {
$self->set_forced_breakpoint(
$last_dot_index[$depth] );
}
# break before opening structure if preceded by another
# closing structure and a comma. This is normally
# done by the previous closing brace, but not
# if it was a one-line block.
if ( $i_opening > 2 ) {
my $i_prev =
( $types_to_go[ $i_opening - 1 ] eq 'b' )
? $i_opening - 2
: $i_opening - 1;
if (
$types_to_go[$i_prev] eq ','
&& ( $types_to_go[ $i_prev - 1 ] eq ')'
|| $types_to_go[ $i_prev - 1 ] eq '}' )
)
{
$self->set_forced_breakpoint($i_prev);
}
# also break before something like ':(' or '?('
# if appropriate.
elsif (
$types_to_go[$i_prev] =~ /^([k\:\?]|&&|\|\|)$/ )
{
my $token_prev = $tokens_to_go[$i_prev];
if ( $want_break_before{$token_prev} ) {
$self->set_forced_breakpoint($i_prev);
}
} ## end elsif ( $types_to_go[$i_prev...])
} ## end if ( $i_opening > 2 )
} ## end if ( $minimum_depth <=...)
# break after comma following closing structure
if ( $next_type eq ',' ) {
$self->set_forced_breakpoint( $i + 1 );
}
# break before an '=' following closing structure
if (
$is_assignment{$next_nonblank_type}
&& ( $breakpoint_stack[$current_depth] !=
get_forced_breakpoint_count() )
)
{
$self->set_forced_breakpoint($i);
} ## end if ( $is_assignment{$next_nonblank_type...})
# break at any comma before the opening structure Added
# for -lp, but seems to be good in general. It isn't
# obvious how far back to look; the '5' below seems to
# work well and will catch the comma in something like
# push @list, myfunc( $param, $param, ..
my $icomma = $last_comma_index[$depth];
if ( defined($icomma) && ( $i_opening - $icomma ) < 5 ) {
unless ( $forced_breakpoint_to_go[$icomma] ) {
$self->set_forced_breakpoint($icomma);
}
}
} # end logic to open up a container
# Break open a logical container open if it was already open
elsif ($is_simple_logical_expression
&& $has_old_logical_breakpoints[$current_depth] )
{
$self->set_logical_breakpoints($current_depth);
}
# Handle long container which does not get opened up
elsif ($is_long_term) {
# must set fake breakpoint to alert outer containers that
# they are complex
set_fake_breakpoint();
} ## end elsif ($is_long_term)
} ## end elsif ( $depth < $current_depth)
#------------------------------------------------------------
# Handle this token
#------------------------------------------------------------
$current_depth = $depth;
# most token types can skip the rest of this loop
next unless ( $quick_filter{$type} );
# handle comma-arrow
if ( $type eq '=>' ) {
next if ( $last_nonblank_type eq '=>' );
next if $rOpts_break_at_old_comma_breakpoints;
next
if ( $rOpts_comma_arrow_breakpoints == 3
&& !$override_cab3[$depth] );
$want_comma_break[$depth] = 1;
$index_before_arrow[$depth] = $i_last_nonblank_token;
next;
} ## end if ( $type eq '=>' )
elsif ( $type eq '.' ) {
$last_dot_index[$depth] = $i;
}
# Turn off alignment if we are sure that this is not a list
# environment. To be safe, we will do this if we see certain
# non-list tokens, such as ';', and also the environment is
# not a list. Note that '=' could be in any of the = operators
# (lextest.t). We can't just use the reported environment
# because it can be incorrect in some cases.
elsif ( ( $type =~ /^[\;\<\>\~]$/ || $is_assignment{$type} )
&& !$self->is_in_list_by_i($i) )
{
$dont_align[$depth] = 1;
$want_comma_break[$depth] = 0;
$index_before_arrow[$depth] = -1;
} ## end elsif ( ( $type =~ /^[\;\<\>\~]$/...))
# now just handle any commas
next unless ( $type eq ',' );
$last_dot_index[$depth] = undef;
$last_comma_index[$depth] = $i;
# break here if this comma follows a '=>'
# but not if there is a side comment after the comma
if ( $want_comma_break[$depth] ) {
if ( $next_nonblank_type =~ /^[\)\}\]R]$/ ) {
if ($rOpts_comma_arrow_breakpoints) {
$want_comma_break[$depth] = 0;
next;
}
}
$self->set_forced_breakpoint($i)
unless ( $next_nonblank_type eq '#' );
# break before the previous token if it looks safe
# Example of something that we will not try to break before:
# DBI::SQL_SMALLINT() => $ado_consts->{adSmallInt},
# Also we don't want to break at a binary operator (like +):
# $c->createOval(
# $x + $R, $y +
# $R => $x - $R,
# $y - $R, -fill => 'black',
# );
my $ibreak = $index_before_arrow[$depth] - 1;
if ( $ibreak > 0
&& $tokens_to_go[ $ibreak + 1 ] !~ /^[\)\}\]]$/ )
{
if ( $tokens_to_go[$ibreak] eq '-' ) { $ibreak-- }
if ( $types_to_go[$ibreak] eq 'b' ) { $ibreak-- }
if ( $types_to_go[$ibreak] =~ /^[,wiZCUG\(\{\[]$/ ) {
# don't break pointer calls, such as the following:
# File::Spec->curdir => 1,
# (This is tokenized as adjacent 'w' tokens)
##if ( $tokens_to_go[ $ibreak + 1 ] !~ /^->/ ) {
# And don't break before a comma, as in the following:
# ( LONGER_THAN,=> 1,
# EIGHTY_CHARACTERS,=> 2,
# CAUSES_FORMATTING,=> 3,
# LIKE_THIS,=> 4,
# );
# This example is for -tso but should be general rule
if ( $tokens_to_go[ $ibreak + 1 ] ne '->'
&& $tokens_to_go[ $ibreak + 1 ] ne ',' )
{
$self->set_forced_breakpoint($ibreak);
}
} ## end if ( $types_to_go[$ibreak...])
} ## end if ( $ibreak > 0 && $tokens_to_go...)
$want_comma_break[$depth] = 0;
$index_before_arrow[$depth] = -1;
# handle list which mixes '=>'s and ','s:
# treat any list items so far as an interrupted list
$interrupted_list[$depth] = 1;
next;
} ## end if ( $want_comma_break...)
# break after all commas above starting depth
if ( $depth < $starting_depth && !$dont_align[$depth] ) {
$self->set_forced_breakpoint($i)
unless ( $next_nonblank_type eq '#' );
next;
}
# add this comma to the list..
my $item_count = $item_count_stack[$depth];
if ( $item_count == 0 ) {
# but do not form a list with no opening structure
# for example:
# open INFILE_COPY, ">$input_file_copy"
# or die ("very long message");
if ( ( $opening_structure_index_stack[$depth] < 0 )
&& $self->is_in_block_by_i($i) )
{
$dont_align[$depth] = 1;
}
} ## end if ( $item_count == 0 )
$comma_index[$depth][$item_count] = $i;
++$item_count_stack[$depth];
if ( $last_nonblank_type =~ /^[iR\]]$/ ) {
$identifier_count_stack[$depth]++;
}
} ## end while ( ++$i <= $max_index_to_go)
#-------------------------------------------
# end of loop over all tokens in this batch
#-------------------------------------------
# set breaks for any unfinished lists ..
for ( my $dd = $current_depth ; $dd >= $minimum_depth ; $dd-- ) {
$interrupted_list[$dd] = 1;
$has_broken_sublist[$dd] = 1 if ( $dd < $current_depth );
$self->set_comma_breakpoints($dd);
$self->set_logical_breakpoints($dd)
if ( $has_old_logical_breakpoints[$dd] );
$self->set_for_semicolon_breakpoints($dd);
# break open container...
my $i_opening = $opening_structure_index_stack[$dd];
$self->set_forced_breakpoint($i_opening)
unless (
is_unbreakable_container($dd)
# Avoid a break which would place an isolated ' or "
# on a line
|| ( $type eq 'Q'
&& $i_opening >= $max_index_to_go - 2
&& ( $token eq "'" || $token eq '"' ) )
);
} ## end for ( my $dd = $current_depth...)
# Return a flag indicating if the input file had some good breakpoints.
# This flag will be used to force a break in a line shorter than the
# allowed line length.
if ( $has_old_logical_breakpoints[$current_depth] ) {
$saw_good_breakpoint = 1;
}
# A complex line with one break at an = has a good breakpoint.
# This is not complex ($total_depth_variation=0):
# $res1
# = 10;
#
# This is complex ($total_depth_variation=6):
# $res2 =
# (is_boundp("a", 'self-insert') && is_boundp("b", 'self-insert'));
elsif ($i_old_assignment_break
&& $total_depth_variation > 4
&& $old_breakpoint_count == 1 )
{
$saw_good_breakpoint = 1;
} ## end elsif ( $i_old_assignment_break...)
return $saw_good_breakpoint;
} ## end sub scan_list
} ## end closure scan_list
my %is_kwiZ;
BEGIN {
# Added 'w' to fix b1172
my @q = qw(k w i Z);
@is_kwiZ{@q} = (1) x scalar(@q);
}
sub find_token_starting_list {
# When testing to see if a block will fit on one line, some
# previous token(s) may also need to be on the line; particularly
# if this is a sub call. So we will look back at least one
# token.
my ( $self, $i_opening_paren ) = @_;
# This will be the return index
my $i_opening_minus = $i_opening_paren;
goto RETURN if ( $i_opening_minus <= 0 );
my $im1 = $i_opening_paren - 1;
my ( $iprev_nb, $type_prev_nb ) = ( $im1, $types_to_go[$im1] );
if ( $type_prev_nb eq 'b' && $iprev_nb > 0 ) {
$iprev_nb -= 1;
$type_prev_nb = $types_to_go[$iprev_nb];
}
if ( $type_prev_nb eq ',' ) {
# a previous comma is a good break point
# $i_opening_minus = $i_opening_paren;
}
elsif ( $tokens_to_go[$i_opening_paren] eq '(' ) {
$i_opening_minus = $im1;
# Walk back to improve length estimate...
# FIX for cases b1169 b1170 b1171: start walking back
# at the previous nonblank. This makes the result insensitive
# to the flag --space-function-paren, and similar.
# previous loop: for ( my $j = $im1 ; $j >= 0 ; $j-- ) {
for ( my $j = $iprev_nb ; $j >= 0 ; $j-- ) {
last if ( $types_to_go[$j] =~ /^[\(\[\{L\}\]\)Rb,]$/ );
$i_opening_minus = $j;
}
if ( $types_to_go[$i_opening_minus] eq 'b' ) { $i_opening_minus++ }
}
# Handle non-parens
elsif ( $is_kwiZ{$type_prev_nb} ) { $i_opening_minus = $iprev_nb }
RETURN:
return $i_opening_minus;
}
{ ## begin closure set_comma_breakpoints_do
my %is_keyword_with_special_leading_term;
BEGIN {
# These keywords have prototypes which allow a special leading item
# followed by a list
my @q =
qw(formline grep kill map printf sprintf push chmod join pack unshift);
@is_keyword_with_special_leading_term{@q} = (1) x scalar(@q);
}
use constant DEBUG_SPARSE => 0;
sub set_comma_breakpoints_do {
# Given a list with some commas, set breakpoints at some of the
# commas, if necessary, to make it easy to read.
my ( $self, $rinput_hash ) = @_;
my $depth = $rinput_hash->{depth};
my $i_opening_paren = $rinput_hash->{i_opening_paren};
my $i_closing_paren = $rinput_hash->{i_closing_paren};
my $item_count = $rinput_hash->{item_count};
my $identifier_count = $rinput_hash->{identifier_count};
my $rcomma_index = $rinput_hash->{rcomma_index};
my $next_nonblank_type = $rinput_hash->{next_nonblank_type};
my $list_type = $rinput_hash->{list_type};
my $interrupted = $rinput_hash->{interrupted};
my $rdo_not_break_apart = $rinput_hash->{rdo_not_break_apart};
my $must_break_open = $rinput_hash->{must_break_open};
my $has_broken_sublist = $rinput_hash->{has_broken_sublist};
# nothing to do if no commas seen
return if ( $item_count < 1 );
my $i_first_comma = $rcomma_index->[0];
my $i_true_last_comma = $rcomma_index->[ $item_count - 1 ];
my $i_last_comma = $i_true_last_comma;
if ( $i_last_comma >= $max_index_to_go ) {
$i_last_comma = $rcomma_index->[ --$item_count - 1 ];
return if ( $item_count < 1 );
}
#---------------------------------------------------------------
# find lengths of all items in the list to calculate page layout
#---------------------------------------------------------------
my $comma_count = $item_count;
my @item_lengths;
my @i_term_begin;
my @i_term_end;
my @i_term_comma;
my $i_prev_plus;
my @max_length = ( 0, 0 );
my $first_term_length;
my $i = $i_opening_paren;
my $is_odd = 1;
foreach my $j ( 0 .. $comma_count - 1 ) {
$is_odd = 1 - $is_odd;
$i_prev_plus = $i + 1;
$i = $rcomma_index->[$j];
my $i_term_end =
( $i == 0 || $types_to_go[ $i - 1 ] eq 'b' ) ? $i - 2 : $i - 1;
my $i_term_begin =
( $types_to_go[$i_prev_plus] eq 'b' )
? $i_prev_plus + 1
: $i_prev_plus;
push @i_term_begin, $i_term_begin;
push @i_term_end, $i_term_end;
push @i_term_comma, $i;
# note: currently adding 2 to all lengths (for comma and space)
my $length =
2 + token_sequence_length( $i_term_begin, $i_term_end );
push @item_lengths, $length;
if ( $j == 0 ) {
$first_term_length = $length;
}
else {
if ( $length > $max_length[$is_odd] ) {
$max_length[$is_odd] = $length;
}
}
}
# now we have to make a distinction between the comma count and item
# count, because the item count will be one greater than the comma
# count if the last item is not terminated with a comma
my $i_b =
( $types_to_go[ $i_last_comma + 1 ] eq 'b' )
? $i_last_comma + 1
: $i_last_comma;
my $i_e =
( $types_to_go[ $i_closing_paren - 1 ] eq 'b' )
? $i_closing_paren - 2
: $i_closing_paren - 1;
my $i_effective_last_comma = $i_last_comma;
my $last_item_length = token_sequence_length( $i_b + 1, $i_e );
if ( $last_item_length > 0 ) {
# add 2 to length because other lengths include a comma and a blank
$last_item_length += 2;
push @item_lengths, $last_item_length;
push @i_term_begin, $i_b + 1;
push @i_term_end, $i_e;
push @i_term_comma, undef;
my $i_odd = $item_count % 2;
if ( $last_item_length > $max_length[$i_odd] ) {
$max_length[$i_odd] = $last_item_length;
}
$item_count++;
$i_effective_last_comma = $i_e + 1;
if ( $types_to_go[ $i_b + 1 ] =~ /^[iR\]]$/ ) {
$identifier_count++;
}
}
#---------------------------------------------------------------
# End of length calculations
#---------------------------------------------------------------
#---------------------------------------------------------------
# Compound List Rule 1:
# Break at (almost) every comma for a list containing a broken
# sublist. This has higher priority than the Interrupted List
# Rule.
#---------------------------------------------------------------
if ($has_broken_sublist) {
# Break at every comma except for a comma between two
# simple, small terms. This prevents long vertical
# columns of, say, just 0's.
my $small_length = 10; # 2 + actual maximum length wanted
# We'll insert a break in long runs of small terms to
# allow alignment in uniform tables.
my $skipped_count = 0;
my $columns = table_columns_available($i_first_comma);
my $fields = int( $columns / $small_length );
if ( $rOpts_maximum_fields_per_table
&& $fields > $rOpts_maximum_fields_per_table )
{
$fields = $rOpts_maximum_fields_per_table;
}
my $max_skipped_count = $fields - 1;
my $is_simple_last_term = 0;
my $is_simple_next_term = 0;
foreach my $j ( 0 .. $item_count ) {
$is_simple_last_term = $is_simple_next_term;
$is_simple_next_term = 0;
if ( $j < $item_count
&& $i_term_end[$j] == $i_term_begin[$j]
&& $item_lengths[$j] <= $small_length )
{
$is_simple_next_term = 1;
}
next if $j == 0;
if ( $is_simple_last_term
&& $is_simple_next_term
&& $skipped_count < $max_skipped_count )
{
$skipped_count++;
}
else {
$skipped_count = 0;
my $i = $i_term_comma[ $j - 1 ];
last unless defined $i;
$self->set_forced_breakpoint($i);
}
}
# always break at the last comma if this list is
# interrupted; we wouldn't want to leave a terminal '{', for
# example.
if ($interrupted) {
$self->set_forced_breakpoint($i_true_last_comma);
}
return;
}
#my ( $a, $b, $c ) = caller();
#print "LISTX: in set_list $a $c interrupt=$interrupted count=$item_count
#i_first = $i_first_comma i_last=$i_last_comma max=$max_index_to_go\n";
#print "depth=$depth has_broken=$has_broken_sublist[$depth] is_multi=$is_multiline opening_paren=($i_opening_paren) \n";
#---------------------------------------------------------------
# Interrupted List Rule:
# A list is forced to use old breakpoints if it was interrupted
# by side comments or blank lines, or requested by user.
#---------------------------------------------------------------
if ( $rOpts_break_at_old_comma_breakpoints
|| $interrupted
|| $i_opening_paren < 0 )
{
$self->copy_old_breakpoints( $i_first_comma, $i_true_last_comma );
return;
}
#---------------------------------------------------------------
# Looks like a list of items. We have to look at it and size it up.
#---------------------------------------------------------------
my $opening_token = $tokens_to_go[$i_opening_paren];
my $opening_is_in_block = $self->is_in_block_by_i($i_opening_paren);
#-------------------------------------------------------------------
# Return if this will fit on one line
#-------------------------------------------------------------------
my $i_opening_minus = $self->find_token_starting_list($i_opening_paren);
return
unless $self->excess_line_length( $i_opening_minus, $i_closing_paren )
> 0;
#-------------------------------------------------------------------
# Now we know that this block spans multiple lines; we have to set
# at least one breakpoint -- real or fake -- as a signal to break
# open any outer containers.
#-------------------------------------------------------------------
set_fake_breakpoint();
# be sure we do not extend beyond the current list length
if ( $i_effective_last_comma >= $max_index_to_go ) {
$i_effective_last_comma = $max_index_to_go - 1;
}
# Set a flag indicating if we need to break open to keep -lp
# items aligned. This is necessary if any of the list terms
# exceeds the available space after the '('.
my $need_lp_break_open = $must_break_open;
if ( $rOpts_line_up_parentheses && !$must_break_open ) {
my $columns_if_unbroken =
$maximum_line_length_at_level[ $levels_to_go[$i_opening_minus] ]
- total_line_length( $i_opening_minus, $i_opening_paren );
$need_lp_break_open =
( $max_length[0] > $columns_if_unbroken )
|| ( $max_length[1] > $columns_if_unbroken )
|| ( $first_term_length > $columns_if_unbroken );
}
# Specify if the list must have an even number of fields or not.
# It is generally safest to assume an even number, because the
# list items might be a hash list. But if we can be sure that
# it is not a hash, then we can allow an odd number for more
# flexibility.
my $odd_or_even = 2; # 1 = odd field count ok, 2 = want even count
if ( $identifier_count >= $item_count - 1
|| $is_assignment{$next_nonblank_type}
|| ( $list_type && $list_type ne '=>' && $list_type !~ /^[\:\?]$/ )
)
{
$odd_or_even = 1;
}
# do we have a long first term which should be
# left on a line by itself?
my $use_separate_first_term = (
$odd_or_even == 1 # only if we can use 1 field/line
&& $item_count > 3 # need several items
&& $first_term_length >
2 * $max_length[0] - 2 # need long first term
&& $first_term_length >
2 * $max_length[1] - 2 # need long first term
);
# or do we know from the type of list that the first term should
# be placed alone?
if ( !$use_separate_first_term ) {
if ( $is_keyword_with_special_leading_term{$list_type} ) {
$use_separate_first_term = 1;
# should the container be broken open?
if ( $item_count < 3 ) {
if ( $i_first_comma - $i_opening_paren < 4 ) {
${$rdo_not_break_apart} = 1;
}
}
elsif ($first_term_length < 20
&& $i_first_comma - $i_opening_paren < 4 )
{
my $columns = table_columns_available($i_first_comma);
if ( $first_term_length < $columns ) {
${$rdo_not_break_apart} = 1;
}
}
}
}
# if so,
if ($use_separate_first_term) {
# ..set a break and update starting values
$use_separate_first_term = 1;
$self->set_forced_breakpoint($i_first_comma);
$i_opening_paren = $i_first_comma;
$i_first_comma = $rcomma_index->[1];
$item_count--;
return if $comma_count == 1;
shift @item_lengths;
shift @i_term_begin;
shift @i_term_end;
shift @i_term_comma;
}
# if not, update the metrics to include the first term
else {
if ( $first_term_length > $max_length[0] ) {
$max_length[0] = $first_term_length;
}
}
# Field width parameters
my $pair_width = ( $max_length[0] + $max_length[1] );
my $max_width =
( $max_length[0] > $max_length[1] ) ? $max_length[0] : $max_length[1];
# Number of free columns across the page width for laying out tables
my $columns = table_columns_available($i_first_comma);
# Estimated maximum number of fields which fit this space
# This will be our first guess
my $number_of_fields_max =
maximum_number_of_fields( $columns, $odd_or_even, $max_width,
$pair_width );
my $number_of_fields = $number_of_fields_max;
# Find the best-looking number of fields
# and make this our second guess if possible
my ( $number_of_fields_best, $ri_ragged_break_list,
$new_identifier_count )
= $self->study_list_complexity( \@i_term_begin, \@i_term_end,
\@item_lengths, $max_width );
if ( $number_of_fields_best != 0
&& $number_of_fields_best < $number_of_fields_max )
{
$number_of_fields = $number_of_fields_best;
}
# ----------------------------------------------------------------------
# If we are crowded and the -lp option is being used, try to
# undo some indentation
# ----------------------------------------------------------------------
if (
$rOpts_line_up_parentheses
&& (
$number_of_fields == 0
|| ( $number_of_fields == 1
&& $number_of_fields != $number_of_fields_best )
)
)
{
my $available_spaces =
$self->get_available_spaces_to_go($i_first_comma);
if ( $available_spaces > 0 ) {
my $spaces_wanted = $max_width - $columns; # for 1 field
if ( $number_of_fields_best == 0 ) {
$number_of_fields_best =
get_maximum_fields_wanted( \@item_lengths );
}
if ( $number_of_fields_best != 1 ) {
my $spaces_wanted_2 =
1 + $pair_width - $columns; # for 2 fields
if ( $available_spaces > $spaces_wanted_2 ) {
$spaces_wanted = $spaces_wanted_2;
}
}
if ( $spaces_wanted > 0 ) {
my $deleted_spaces =
$self->reduce_lp_indentation( $i_first_comma,
$spaces_wanted );
# redo the math
if ( $deleted_spaces > 0 ) {
$columns = table_columns_available($i_first_comma);
$number_of_fields_max =
maximum_number_of_fields( $columns, $odd_or_even,
$max_width, $pair_width );
$number_of_fields = $number_of_fields_max;
if ( $number_of_fields_best == 1
&& $number_of_fields >= 1 )
{
$number_of_fields = $number_of_fields_best;
}
}
}
}
}
# try for one column if two won't work
if ( $number_of_fields <= 0 ) {
$number_of_fields = int( $columns / $max_width );
}
# The user can place an upper bound on the number of fields,
# which can be useful for doing maintenance on tables
if ( $rOpts_maximum_fields_per_table
&& $number_of_fields > $rOpts_maximum_fields_per_table )
{
$number_of_fields = $rOpts_maximum_fields_per_table;
}
# How many columns (characters) and lines would this container take
# if no additional whitespace were added?
my $packed_columns = token_sequence_length( $i_opening_paren + 1,
$i_effective_last_comma + 1 );
if ( $columns <= 0 ) { $columns = 1 } # avoid divide by zero
my $packed_lines = 1 + int( $packed_columns / $columns );
# are we an item contained in an outer list?
my $in_hierarchical_list = $next_nonblank_type =~ /^[\}\,]$/;
if ( $number_of_fields <= 0 ) {
# #---------------------------------------------------------------
# # We're in trouble. We can't find a single field width that works.
# # There is no simple answer here; we may have a single long list
# # item, or many.
# #---------------------------------------------------------------
#
# In many cases, it may be best to not force a break if there is just one
# comma, because the standard continuation break logic will do a better
# job without it.
#
# In the common case that all but one of the terms can fit
# on a single line, it may look better not to break open the
# containing parens. Consider, for example
#
# $color =
# join ( '/',
# sort { $color_value{$::a} <=> $color_value{$::b}; }
# keys %colors );
#
# which will look like this with the container broken:
#
# $color = join (
# '/',
# sort { $color_value{$::a} <=> $color_value{$::b}; } keys %colors
# );
#
# Here is an example of this rule for a long last term:
#
# log_message( 0, 256, 128,
# "Number of routes in adj-RIB-in to be considered: $peercount" );
#
# And here is an example with a long first term:
#
# $s = sprintf(
# "%2d wallclock secs (%$f usr %$f sys + %$f cusr %$f csys = %$f CPU)",
# $r, $pu, $ps, $cu, $cs, $tt
# )
# if $style eq 'all';
my $i_last_comma = $rcomma_index->[ $comma_count - 1 ];
my $long_last_term =
$self->excess_line_length( 0, $i_last_comma ) <= 0;
my $long_first_term =
$self->excess_line_length( $i_first_comma + 1, $max_index_to_go )
<= 0;
# break at every comma ...
if (
# if requested by user or is best looking
$number_of_fields_best == 1
# or if this is a sublist of a larger list
|| $in_hierarchical_list
# or if multiple commas and we don't have a long first or last
# term
|| ( $comma_count > 1
&& !( $long_last_term || $long_first_term ) )
)
{
foreach ( 0 .. $comma_count - 1 ) {
$self->set_forced_breakpoint( $rcomma_index->[$_] );
}
}
elsif ($long_last_term) {
$self->set_forced_breakpoint($i_last_comma);
${$rdo_not_break_apart} = 1 unless $must_break_open;
}
elsif ($long_first_term) {
$self->set_forced_breakpoint($i_first_comma);
}
else {
# let breaks be defined by default bond strength logic
}
return;
}
# --------------------------------------------------------
# We have a tentative field count that seems to work.
# How many lines will this require?
# --------------------------------------------------------
my $formatted_lines = $item_count / ($number_of_fields);
if ( $formatted_lines != int $formatted_lines ) {
$formatted_lines = 1 + int $formatted_lines;
}
# So far we've been trying to fill out to the right margin. But
# compact tables are easier to read, so let's see if we can use fewer
# fields without increasing the number of lines.
$number_of_fields =
compactify_table( $item_count, $number_of_fields, $formatted_lines,
$odd_or_even );
# How many spaces across the page will we fill?
my $columns_per_line =
( int $number_of_fields / 2 ) * $pair_width +
( $number_of_fields % 2 ) * $max_width;
my $formatted_columns;
if ( $number_of_fields > 1 ) {
$formatted_columns =
( $pair_width * ( int( $item_count / 2 ) ) +
( $item_count % 2 ) * $max_width );
}
else {
$formatted_columns = $max_width * $item_count;
}
if ( $formatted_columns < $packed_columns ) {
$formatted_columns = $packed_columns;
}
my $unused_columns = $formatted_columns - $packed_columns;
# set some empirical parameters to help decide if we should try to
# align; high sparsity does not look good, especially with few lines
my $sparsity = ($unused_columns) / ($formatted_columns);
my $max_allowed_sparsity =
( $item_count < 3 ) ? 0.1
: ( $packed_lines == 1 ) ? 0.15
: ( $packed_lines == 2 ) ? 0.4
: 0.7;
# Begin check for shortcut methods, which avoid treating a list
# as a table for relatively small parenthesized lists. These
# are usually easier to read if not formatted as tables.
if (
$packed_lines <= 2 # probably can fit in 2 lines
&& $item_count < 9 # doesn't have too many items
&& $opening_is_in_block # not a sub-container
&& $opening_token eq '(' # is paren list
)
{
# Shortcut method 1: for -lp and just one comma:
# This is a no-brainer, just break at the comma.
if (
$rOpts_line_up_parentheses # -lp
&& $item_count == 2 # two items, one comma
&& !$must_break_open
)
{
my $i_break = $rcomma_index->[0];
$self->set_forced_breakpoint($i_break);
${$rdo_not_break_apart} = 1;
return;
}
# method 2 is for most small ragged lists which might look
# best if not displayed as a table.
if (
( $number_of_fields == 2 && $item_count == 3 )
|| (
$new_identifier_count > 0 # isn't all quotes
&& $sparsity > 0.15
) # would be fairly spaced gaps if aligned
)
{
my $break_count = $self->set_ragged_breakpoints( \@i_term_comma,
$ri_ragged_break_list );
++$break_count if ($use_separate_first_term);
# NOTE: we should really use the true break count here,
# which can be greater if there are large terms and
# little space, but usually this will work well enough.
unless ($must_break_open) {
if ( $break_count <= 1 ) {
${$rdo_not_break_apart} = 1;
}
elsif ( $rOpts_line_up_parentheses && !$need_lp_break_open )
{
${$rdo_not_break_apart} = 1;
}
}
return;
}
} # end shortcut methods
# debug stuff
DEBUG_SPARSE && do {
print STDOUT
"SPARSE:cols=$columns commas=$comma_count items:$item_count ids=$identifier_count pairwidth=$pair_width fields=$number_of_fields lines packed: $packed_lines packed_cols=$packed_columns fmtd:$formatted_lines cols /line:$columns_per_line unused:$unused_columns fmtd:$formatted_columns sparsity=$sparsity allow=$max_allowed_sparsity\n";
};
#---------------------------------------------------------------
# Compound List Rule 2:
# If this list is too long for one line, and it is an item of a
# larger list, then we must format it, regardless of sparsity
# (ian.t). One reason that we have to do this is to trigger
# Compound List Rule 1, above, which causes breaks at all commas of
# all outer lists. In this way, the structure will be properly
# displayed.
#---------------------------------------------------------------
# Decide if this list is too long for one line unless broken
my $total_columns = table_columns_available($i_opening_paren);
my $too_long = $packed_columns > $total_columns;
# For a paren list, include the length of the token just before the
# '(' because this is likely a sub call, and we would have to
# include the sub name on the same line as the list. This is still
# imprecise, but not too bad. (steve.t)
if ( !$too_long && $i_opening_paren > 0 && $opening_token eq '(' ) {
$too_long = $self->excess_line_length( $i_opening_minus,
$i_effective_last_comma + 1 ) > 0;
}
# FIXME: For an item after a '=>', try to include the length of the
# thing before the '=>'. This is crude and should be improved by
# actually looking back token by token.
if ( !$too_long && $i_opening_paren > 0 && $list_type eq '=>' ) {
my $i_opening_minus = $i_opening_paren - 4;
if ( $i_opening_minus >= 0 ) {
$too_long = $self->excess_line_length( $i_opening_minus,
$i_effective_last_comma + 1 ) > 0;
}
}
# Always break lists contained in '[' and '{' if too long for 1 line,
# and always break lists which are too long and part of a more complex
# structure.
my $must_break_open_container = $must_break_open
|| ( $too_long
&& ( $in_hierarchical_list || $opening_token ne '(' ) );
#print "LISTX: next=$next_nonblank_type avail cols=$columns packed=$packed_columns must format = $must_break_open_container too-long=$too_long opening=$opening_token list_type=$list_type formatted_lines=$formatted_lines packed=$packed_lines max_sparsity= $max_allowed_sparsity sparsity=$sparsity \n";
#---------------------------------------------------------------
# The main decision:
# Now decide if we will align the data into aligned columns. Do not
# attempt to align columns if this is a tiny table or it would be
# too spaced. It seems that the more packed lines we have, the
# sparser the list that can be allowed and still look ok.
#---------------------------------------------------------------
if ( ( $formatted_lines < 3 && $packed_lines < $formatted_lines )
|| ( $formatted_lines < 2 )
|| ( $unused_columns > $max_allowed_sparsity * $formatted_columns )
)
{
#---------------------------------------------------------------
# too sparse: would look ugly if aligned in a table;
#---------------------------------------------------------------
# use old breakpoints if this is a 'big' list
if ( $packed_lines > 2 && $item_count > 10 ) {
write_logfile_entry("List sparse: using old breakpoints\n");
$self->copy_old_breakpoints( $i_first_comma, $i_last_comma );
}
# let the continuation logic handle it if 2 lines
else {
my $break_count = $self->set_ragged_breakpoints( \@i_term_comma,
$ri_ragged_break_list );
++$break_count if ($use_separate_first_term);
unless ($must_break_open_container) {
if ( $break_count <= 1 ) {
${$rdo_not_break_apart} = 1;
}
elsif ( $rOpts_line_up_parentheses && !$need_lp_break_open )
{
${$rdo_not_break_apart} = 1;
}
}
}
return;
}
#---------------------------------------------------------------
# go ahead and format as a table
#---------------------------------------------------------------
write_logfile_entry(
"List: auto formatting with $number_of_fields fields/row\n");
my $j_first_break =
$use_separate_first_term ? $number_of_fields : $number_of_fields - 1;
for (
my $j = $j_first_break ;
$j < $comma_count ;
$j += $number_of_fields
)
{
my $i = $rcomma_index->[$j];
$self->set_forced_breakpoint($i);
}
return;
}
} ## end closure set_comma_breakpoints_do
sub study_list_complexity {
# Look for complex tables which should be formatted with one term per line.
# Returns the following:
#
# \@i_ragged_break_list = list of good breakpoints to avoid lines
# which are hard to read
# $number_of_fields_best = suggested number of fields based on
# complexity; = 0 if any number may be used.
#
my ( $self, $ri_term_begin, $ri_term_end, $ritem_lengths, $max_width ) = @_;
my $item_count = @{$ri_term_begin};
my $complex_item_count = 0;
my $number_of_fields_best = $rOpts_maximum_fields_per_table;
my $i_max = @{$ritem_lengths} - 1;
##my @item_complexity;
my $i_last_last_break = -3;
my $i_last_break = -2;
my @i_ragged_break_list;
my $definitely_complex = 30;
my $definitely_simple = 12;
my $quote_count = 0;
for my $i ( 0 .. $i_max ) {
my $ib = $ri_term_begin->[$i];
my $ie = $ri_term_end->[$i];
# define complexity: start with the actual term length
my $weighted_length = ( $ritem_lengths->[$i] - 2 );
##TBD: join types here and check for variations
##my $str=join "", @tokens_to_go[$ib..$ie];
my $is_quote = 0;
if ( $types_to_go[$ib] =~ /^[qQ]$/ ) {
$is_quote = 1;
$quote_count++;
}
elsif ( $types_to_go[$ib] =~ /^[w\-]$/ ) {
$quote_count++;
}
if ( $ib eq $ie ) {
if ( $is_quote && $tokens_to_go[$ib] =~ /\s/ ) {
$complex_item_count++;
$weighted_length *= 2;
}
else {
}
}
else {
if ( grep { $_ eq 'b' } @types_to_go[ $ib .. $ie ] ) {
$complex_item_count++;
$weighted_length *= 2;
}
if ( grep { $_ eq '..' } @types_to_go[ $ib .. $ie ] ) {
$weighted_length += 4;
}
}
# add weight for extra tokens.
$weighted_length += 2 * ( $ie - $ib );
## my $BUB = join '', @tokens_to_go[$ib..$ie];
## print "# COMPLEXITY:$weighted_length $BUB\n";
##push @item_complexity, $weighted_length;
# now mark a ragged break after this item it if it is 'long and
# complex':
if ( $weighted_length >= $definitely_complex ) {
# if we broke after the previous term
# then break before it too
if ( $i_last_break == $i - 1
&& $i > 1
&& $i_last_last_break != $i - 2 )
{
## FIXME: don't strand a small term
pop @i_ragged_break_list;
push @i_ragged_break_list, $i - 2;
push @i_ragged_break_list, $i - 1;
}
push @i_ragged_break_list, $i;
$i_last_last_break = $i_last_break;
$i_last_break = $i;
}
# don't break before a small last term -- it will
# not look good on a line by itself.
elsif ($i == $i_max
&& $i_last_break == $i - 1
&& $weighted_length <= $definitely_simple )
{
pop @i_ragged_break_list;
}
}
my $identifier_count = $i_max + 1 - $quote_count;
# Need more tuning here..
if ( $max_width > 12
&& $complex_item_count > $item_count / 2
&& $number_of_fields_best != 2 )
{
$number_of_fields_best = 1;
}
return ( $number_of_fields_best, \@i_ragged_break_list, $identifier_count );
}
sub get_maximum_fields_wanted {
# Not all tables look good with more than one field of items.
# This routine looks at a table and decides if it should be
# formatted with just one field or not.
# This coding is still under development.
my ($ritem_lengths) = @_;
my $number_of_fields_best = 0;
# For just a few items, we tentatively assume just 1 field.
my $item_count = @{$ritem_lengths};
if ( $item_count <= 5 ) {
$number_of_fields_best = 1;
}
# For larger tables, look at it both ways and see what looks best
else {
my $is_odd = 1;
my @max_length = ( 0, 0 );
my @last_length_2 = ( undef, undef );
my @first_length_2 = ( undef, undef );
my $last_length = undef;
my $total_variation_1 = 0;
my $total_variation_2 = 0;
my @total_variation_2 = ( 0, 0 );
foreach my $j ( 0 .. $item_count - 1 ) {
$is_odd = 1 - $is_odd;
my $length = $ritem_lengths->[$j];
if ( $length > $max_length[$is_odd] ) {
$max_length[$is_odd] = $length;
}
if ( defined($last_length) ) {
my $dl = abs( $length - $last_length );
$total_variation_1 += $dl;
}
$last_length = $length;
my $ll = $last_length_2[$is_odd];
if ( defined($ll) ) {
my $dl = abs( $length - $ll );
$total_variation_2[$is_odd] += $dl;
}
else {
$first_length_2[$is_odd] = $length;
}
$last_length_2[$is_odd] = $length;
}
$total_variation_2 = $total_variation_2[0] + $total_variation_2[1];
my $factor = ( $item_count > 10 ) ? 1 : ( $item_count > 5 ) ? 0.75 : 0;
unless ( $total_variation_2 < $factor * $total_variation_1 ) {
$number_of_fields_best = 1;
}
}
return ($number_of_fields_best);
}
sub table_columns_available {
my $i_first_comma = shift;
my $columns =
$maximum_line_length_at_level[ $levels_to_go[$i_first_comma] ] -
leading_spaces_to_go($i_first_comma);
# Patch: the vertical formatter does not line up lines whose lengths
# exactly equal the available line length because of allowances
# that must be made for side comments. Therefore, the number of
# available columns is reduced by 1 character.
$columns -= 1;
return $columns;
}
sub maximum_number_of_fields {
# how many fields will fit in the available space?
my ( $columns, $odd_or_even, $max_width, $pair_width ) = @_;
my $max_pairs = int( $columns / $pair_width );
my $number_of_fields = $max_pairs * 2;
if ( $odd_or_even == 1
&& $max_pairs * $pair_width + $max_width <= $columns )
{
$number_of_fields++;
}
return $number_of_fields;
}
sub compactify_table {
# given a table with a certain number of fields and a certain number
# of lines, see if reducing the number of fields will make it look
# better.
my ( $item_count, $number_of_fields, $formatted_lines, $odd_or_even ) = @_;
if ( $number_of_fields >= $odd_or_even * 2 && $formatted_lines > 0 ) {
my $min_fields;
for (
$min_fields = $number_of_fields ;
$min_fields >= $odd_or_even
&& $min_fields * $formatted_lines >= $item_count ;
$min_fields -= $odd_or_even
)
{
$number_of_fields = $min_fields;
}
}
return $number_of_fields;
}
sub set_ragged_breakpoints {
# Set breakpoints in a list that cannot be formatted nicely as a
# table.
my ( $self, $ri_term_comma, $ri_ragged_break_list ) = @_;
my $break_count = 0;
foreach ( @{$ri_ragged_break_list} ) {
my $j = $ri_term_comma->[$_];
if ($j) {
$self->set_forced_breakpoint($j);
$break_count++;
}
}
return $break_count;
}
sub copy_old_breakpoints {
my ( $self, $i_first_comma, $i_last_comma ) = @_;
for my $i ( $i_first_comma .. $i_last_comma ) {
if ( $old_breakpoint_to_go[$i] ) {
$self->set_forced_breakpoint($i);
}
}
return;
}
sub set_nobreaks {
my ( $self, $i, $j ) = @_;
if ( $i >= 0 && $i <= $j && $j <= $max_index_to_go ) {
0 && do {
my ( $a, $b, $c ) = caller();
my $forced_breakpoint_count = get_forced_breakpoint_count();
print STDOUT
"NOBREAK: forced_breakpoint $forced_breakpoint_count from $a $c with i=$i max=$max_index_to_go type=$types_to_go[$i]\n";
};
@nobreak_to_go[ $i .. $j ] = (1) x ( $j - $i + 1 );
}
# shouldn't happen; non-critical error
else {
0 && do {
my ( $a, $b, $c ) = caller();
print STDOUT
"NOBREAK ERROR: from $a $c with i=$i j=$j max=$max_index_to_go\n";
};
}
return;
}
###############################################
# CODE SECTION 12: Code for setting indentation
###############################################
sub token_sequence_length {
# return length of tokens ($ibeg .. $iend) including $ibeg & $iend
# returns 0 if $ibeg > $iend (shouldn't happen)
my ( $ibeg, $iend ) = @_;
return 0 if ( !defined($iend) || $iend < 0 || $ibeg > $iend );
return $summed_lengths_to_go[ $iend + 1 ] if ( $ibeg < 0 );
return $summed_lengths_to_go[ $iend + 1 ] - $summed_lengths_to_go[$ibeg];
}
sub total_line_length {
# return length of a line of tokens ($ibeg .. $iend)
my ( $ibeg, $iend ) = @_;
# original coding:
#return leading_spaces_to_go($ibeg) + token_sequence_length( $ibeg, $iend );
# this is basically sub 'leading_spaces_to_go':
my $indentation = $leading_spaces_to_go[$ibeg];
if ( ref($indentation) ) { $indentation = $indentation->get_spaces() }
return $indentation + $summed_lengths_to_go[ $iend + 1 ] -
$summed_lengths_to_go[$ibeg];
}
sub excess_line_length {
# return number of characters by which a line of tokens ($ibeg..$iend)
# exceeds the allowable line length.
# NOTE: Profiling shows that this is a critical routine for efficiency.
# Therefore I have eliminated additional calls to subs from it.
my ( $self, $ibeg, $iend, $ignore_right_weld ) = @_;
# Original expression for line length
##$length = leading_spaces_to_go($ibeg) + token_sequence_length( $ibeg, $iend );
# This is basically sub 'leading_spaces_to_go':
my $indentation = $leading_spaces_to_go[$ibeg];
if ( ref($indentation) ) { $indentation = $indentation->get_spaces() }
my $length =
$indentation +
$summed_lengths_to_go[ $iend + 1 ] -
$summed_lengths_to_go[$ibeg];
# Include right weld lengths unless requested not to.
if ( $total_weld_count
&& !$ignore_right_weld
&& $type_sequence_to_go[$iend] )
{
my $wr = $self->[_rweld_len_right_at_K_]->{ $K_to_go[$iend] };
$length += $wr if defined($wr);
}
# return the excess
return $length - $maximum_line_length_at_level[ $levels_to_go[$ibeg] ];
}
sub get_spaces {
# return the number of leading spaces associated with an indentation
# variable $indentation is either a constant number of spaces or an object
# with a get_spaces method.
my $indentation = shift;
return ref($indentation) ? $indentation->get_spaces() : $indentation;
}
sub get_recoverable_spaces {
# return the number of spaces (+ means shift right, - means shift left)
# that we would like to shift a group of lines with the same indentation
# to get them to line up with their opening parens
my $indentation = shift;
return ref($indentation) ? $indentation->get_recoverable_spaces() : 0;
}
sub get_available_spaces_to_go {
my ( $self, $ii ) = @_;
my $item = $leading_spaces_to_go[$ii];
# return the number of available leading spaces associated with an
# indentation variable. $indentation is either a constant number of
# spaces or an object with a get_available_spaces method.
return ref($item) ? $item->get_available_spaces() : 0;
}
{ ## begin closure set_leading_whitespace (for -lp indentation)
# These routines are called batch-by-batch to handle the -lp indentation
# option. The coding is rather complex, but is only for -lp.
my $gnu_position_predictor;
my $gnu_sequence_number;
my $line_start_index_to_go;
my $max_gnu_item_index;
my $max_gnu_stack_index;
my %gnu_arrow_count;
my %gnu_comma_count;
my %last_gnu_equals;
my @gnu_item_list;
my @gnu_stack;
sub initialize_gnu_vars {
# initialize gnu variables for a new file;
# must be called once at the start of a new file.
# initialize the leading whitespace stack to negative levels
# so that we can never run off the end of the stack
$gnu_position_predictor =
0; # where the current token is predicted to be
$max_gnu_stack_index = 0;
$max_gnu_item_index = -1;
$gnu_stack[0] = new_lp_indentation_item( 0, -1, -1, 0, 0 );
@gnu_item_list = ();
return;
}
sub initialize_gnu_batch_vars {
# initialize gnu variables for a new batch;
# must be called before each new batch
$gnu_sequence_number++; # increment output batch counter
%last_gnu_equals = ();
%gnu_comma_count = ();
%gnu_arrow_count = ();
$line_start_index_to_go = 0;
$max_gnu_item_index = UNDEFINED_INDEX;
return;
}
sub new_lp_indentation_item {
# this is an interface to the IndentationItem class
my ( $spaces, $level, $ci_level, $available_spaces, $align_paren ) = @_;
# A negative level implies not to store the item in the item_list
my $index = 0;
if ( $level >= 0 ) { $index = ++$max_gnu_item_index; }
my $starting_index_K = 0;
if ( defined($line_start_index_to_go)
&& $line_start_index_to_go >= 0
&& $line_start_index_to_go <= $max_index_to_go )
{
$starting_index_K = $K_to_go[$line_start_index_to_go];
}
my $item = Perl::Tidy::IndentationItem->new(
spaces => $spaces,
level => $level,
ci_level => $ci_level,
available_spaces => $available_spaces,
index => $index,
gnu_sequence_number => $gnu_sequence_number,
align_paren => $align_paren,
stack_depth => $max_gnu_stack_index,
starting_index_K => $starting_index_K,
);
if ( $level >= 0 ) {
$gnu_item_list[$max_gnu_item_index] = $item;
}
return $item;
}
sub set_leading_whitespace {
# This routine defines leading whitespace for the case of -lp formatting
# given: the level and continuation_level of a token,
# define: space count of leading string which would apply if it
# were the first token of a new line.
my ( $self, $Kj, $K_last_nonblank, $K_last_last_nonblank,
$level_abs, $ci_level, $in_continued_quote )
= @_;
return unless ($rOpts_line_up_parentheses);
return unless ( defined($max_index_to_go) && $max_index_to_go >= 0 );
my $rbreak_container = $self->[_rbreak_container_];
my $rshort_nested = $self->[_rshort_nested_];
my $ris_excluded_lp_container = $self->[_ris_excluded_lp_container_];
my $rLL = $self->[_rLL_];
my $rbreak_before_container_by_seqno =
$self->[_rbreak_before_container_by_seqno_];
# find needed previous nonblank tokens
my $last_nonblank_token = '';
my $last_nonblank_type = '';
my $last_nonblank_block_type = '';
# and previous nonblank tokens, just in this batch:
my $last_nonblank_token_in_batch = '';
my $last_nonblank_type_in_batch = '';
my $last_last_nonblank_type_in_batch = '';
if ( defined($K_last_nonblank) ) {
$last_nonblank_token = $rLL->[$K_last_nonblank]->[_TOKEN_];
$last_nonblank_type = $rLL->[$K_last_nonblank]->[_TYPE_];
$last_nonblank_block_type =
$rLL->[$K_last_nonblank]->[_BLOCK_TYPE_];
if ( $K_last_nonblank >= $K_to_go[0] ) {
$last_nonblank_token_in_batch = $last_nonblank_token;
$last_nonblank_type_in_batch = $last_nonblank_type;
if ( defined($K_last_last_nonblank)
&& $K_last_last_nonblank > $K_to_go[0] )
{
$last_last_nonblank_type_in_batch =
$rLL->[$K_last_last_nonblank]->[_TYPE_];
}
}
}
################################################################
# Adjust levels if necessary to recycle whitespace:
my $level = $level_abs;
my $radjusted_levels = $self->[_radjusted_levels_];
my $nK = @{$rLL};
my $nws = @{$radjusted_levels};
if ( defined($radjusted_levels) && @{$radjusted_levels} == @{$rLL} ) {
$level = $radjusted_levels->[$Kj];
if ( $level < 0 ) { $level = 0 } # note: this should not happen
}
# The continued_quote flag means that this is the first token of a
# line, and it is the continuation of some kind of multi-line quote
# or pattern. It requires special treatment because it must have no
# added leading whitespace. So we create a special indentation item
# which is not in the stack.
if ($in_continued_quote) {
my $space_count = 0;
my $available_space = 0;
$level = -1; # flag to prevent storing in item_list
$leading_spaces_to_go[$max_index_to_go] =
$reduced_spaces_to_go[$max_index_to_go] =
new_lp_indentation_item( $space_count, $level, $ci_level,
$available_space, 0 );
return;
}
# get the top state from the stack
my $space_count = $gnu_stack[$max_gnu_stack_index]->get_spaces();
my $current_level = $gnu_stack[$max_gnu_stack_index]->get_level();
my $current_ci_level = $gnu_stack[$max_gnu_stack_index]->get_ci_level();
my $type = $types_to_go[$max_index_to_go];
my $token = $tokens_to_go[$max_index_to_go];
my $total_depth = $nesting_depth_to_go[$max_index_to_go];
if ( $type eq '{' || $type eq '(' ) {
$gnu_comma_count{ $total_depth + 1 } = 0;
$gnu_arrow_count{ $total_depth + 1 } = 0;
# If we come to an opening token after an '=' token of some type,
# see if it would be helpful to 'break' after the '=' to save space
my $last_equals = $last_gnu_equals{$total_depth};
if ( $last_equals && $last_equals > $line_start_index_to_go ) {
my $seqno = $type_sequence_to_go[$max_index_to_go];
# find the position if we break at the '='
my $i_test = $last_equals;
if ( $types_to_go[ $i_test + 1 ] eq 'b' ) { $i_test++ }
# TESTING
##my $too_close = ($i_test==$max_index_to_go-1);
my $test_position =
total_line_length( $i_test, $max_index_to_go );
my $mll =
$maximum_line_length_at_level[ $levels_to_go[$i_test] ];
my $bbc_flag = $break_before_container_types{$token};
if (
# the equals is not just before an open paren (testing)
##!$too_close &&
# if we are beyond the midpoint
$gnu_position_predictor >
$mll - $rOpts_maximum_line_length / 2
# if a -bbx flag WANTS a break before this opening token
|| ( $seqno && $rbreak_before_container_by_seqno->{$seqno} )
# or if we MIGHT want a break (fixes case b826 b909 b989)
|| ( $bbc_flag && $bbc_flag >= 2 )
# or we are beyond the 1/4 point and there was an old
# break at an assignment (not '=>') [fix for b1035]
|| (
$gnu_position_predictor >
$mll - $rOpts_maximum_line_length * 3 / 4
&& $types_to_go[$last_equals] ne '=>'
&& (
$old_breakpoint_to_go[$last_equals]
|| ( $last_equals > 0
&& $old_breakpoint_to_go[ $last_equals - 1 ] )
|| ( $last_equals > 1
&& $types_to_go[ $last_equals - 1 ] eq 'b'
&& $old_breakpoint_to_go[ $last_equals - 2 ] )
)
)
)
{
# then make the switch -- note that we do not set a real
# breakpoint here because we may not really need one; sub
# scan_list will do that if necessary
$line_start_index_to_go = $i_test + 1;
$gnu_position_predictor = $test_position;
}
}
}
my $halfway =
$maximum_line_length_at_level[$level] -
$rOpts_maximum_line_length / 2;
# Check for decreasing depth ..
# Note that one token may have both decreasing and then increasing
# depth. For example, (level, ci) can go from (1,1) to (2,0). So,
# in this example we would first go back to (1,0) then up to (2,0)
# in a single call.
if ( $level < $current_level || $ci_level < $current_ci_level ) {
# loop to find the first entry at or completely below this level
my ( $lev, $ci_lev );
while (1) {
if ($max_gnu_stack_index) {
# save index of token which closes this level
$gnu_stack[$max_gnu_stack_index]
->set_closed($max_index_to_go);
# Undo any extra indentation if we saw no commas
my $available_spaces =
$gnu_stack[$max_gnu_stack_index]->get_available_spaces();
my $comma_count = 0;
my $arrow_count = 0;
if ( $type eq '}' || $type eq ')' ) {
$comma_count = $gnu_comma_count{$total_depth};
$arrow_count = $gnu_arrow_count{$total_depth};
$comma_count = 0 unless $comma_count;
$arrow_count = 0 unless $arrow_count;
}
$gnu_stack[$max_gnu_stack_index]
->set_comma_count($comma_count);
$gnu_stack[$max_gnu_stack_index]
->set_arrow_count($arrow_count);
if ( $available_spaces > 0 ) {
if ( $comma_count <= 0 || $arrow_count > 0 ) {
my $i =
$gnu_stack[$max_gnu_stack_index]->get_index();
my $seqno =
$gnu_stack[$max_gnu_stack_index]
->get_sequence_number();
# Be sure this item was created in this batch. This
# should be true because we delete any available
# space from open items at the end of each batch.
if ( $gnu_sequence_number != $seqno
|| $i > $max_gnu_item_index )
{
warning(
"Program bug with -lp. seqno=$seqno should be $gnu_sequence_number and i=$i should be less than max=$max_gnu_item_index\n"
);
report_definite_bug();
}
else {
if ( $arrow_count == 0 ) {
$gnu_item_list[$i]
->permanently_decrease_available_spaces(
$available_spaces);
}
else {
$gnu_item_list[$i]
->tentatively_decrease_available_spaces(
$available_spaces);
}
foreach my $j ( $i + 1 .. $max_gnu_item_index )
{
$gnu_item_list[$j]
->decrease_SPACES($available_spaces);
}
}
}
}
# go down one level
--$max_gnu_stack_index;
$lev = $gnu_stack[$max_gnu_stack_index]->get_level();
$ci_lev = $gnu_stack[$max_gnu_stack_index]->get_ci_level();
# stop when we reach a level at or below the current level
if ( $lev <= $level && $ci_lev <= $ci_level ) {
$space_count =
$gnu_stack[$max_gnu_stack_index]->get_spaces();
$current_level = $lev;
$current_ci_level = $ci_lev;
last;
}
}
# reached bottom of stack .. should never happen because
# only negative levels can get here, and $level was forced
# to be positive above.
else {
warning(
"program bug with -lp: stack_error. level=$level; lev=$lev; ci_level=$ci_level; ci_lev=$ci_lev; rerun with -nlp\n"
);
report_definite_bug();
last;
}
}
}
# handle increasing depth
if ( $level > $current_level || $ci_level > $current_ci_level ) {
# Compute the standard incremental whitespace. This will be
# the minimum incremental whitespace that will be used. This
# choice results in a smooth transition between the gnu-style
# and the standard style.
my $standard_increment =
( $level - $current_level ) *
$rOpts_indent_columns +
( $ci_level - $current_ci_level ) *
$rOpts_continuation_indentation;
# Now we have to define how much extra incremental space
# ("$available_space") we want. This extra space will be
# reduced as necessary when long lines are encountered or when
# it becomes clear that we do not have a good list.
my $available_space = 0;
my $align_paren = 0;
my $excess = 0;
my $last_nonblank_seqno;
if ( defined($K_last_nonblank) ) {
$last_nonblank_seqno =
$rLL->[$K_last_nonblank]->[_TYPE_SEQUENCE_];
}
# initialization on empty stack..
if ( $max_gnu_stack_index == 0 ) {
$space_count = $level * $rOpts_indent_columns;
}
# if this is a BLOCK, add the standard increment
elsif ($last_nonblank_block_type) {
$space_count += $standard_increment;
}
# add the standard increment for containers excluded by user rules
# or which contain here-docs or multiline qw text
elsif ( defined($last_nonblank_seqno)
&& $ris_excluded_lp_container->{$last_nonblank_seqno} )
{
$space_count += $standard_increment;
}
# if last nonblank token was not structural indentation,
# just use standard increment
elsif ( $last_nonblank_type ne '{' ) {
$space_count += $standard_increment;
}
# otherwise use the space to the first non-blank level change token
else {
$space_count = $gnu_position_predictor;
my $min_gnu_indentation =
$gnu_stack[$max_gnu_stack_index]->get_spaces();
$available_space = $space_count - $min_gnu_indentation;
if ( $available_space >= $standard_increment ) {
$min_gnu_indentation += $standard_increment;
}
elsif ( $available_space > 1 ) {
$min_gnu_indentation += $available_space + 1;
}
elsif ( $last_nonblank_token =~ /^[\{\[\(]$/ ) {
if ( ( $tightness{$last_nonblank_token} < 2 ) ) {
$min_gnu_indentation += 2;
}
else {
$min_gnu_indentation += 1;
}
}
else {
$min_gnu_indentation += $standard_increment;
}
$available_space = $space_count - $min_gnu_indentation;
if ( $available_space < 0 ) {
$space_count = $min_gnu_indentation;
$available_space = 0;
}
$align_paren = 1;
}
# update state, but not on a blank token
if ( $types_to_go[$max_index_to_go] ne 'b' ) {
$gnu_stack[$max_gnu_stack_index]->set_have_child(1);
++$max_gnu_stack_index;
$gnu_stack[$max_gnu_stack_index] =
new_lp_indentation_item( $space_count, $level, $ci_level,
$available_space, $align_paren );
# If the opening paren is beyond the half-line length, then
# we will use the minimum (standard) indentation. This will
# help avoid problems associated with running out of space
# near the end of a line. As a result, in deeply nested
# lists, there will be some indentations which are limited
# to this minimum standard indentation. But the most deeply
# nested container will still probably be able to shift its
# parameters to the right for proper alignment, so in most
# cases this will not be noticeable.
if ( $available_space > 0 && $space_count > $halfway ) {
$gnu_stack[$max_gnu_stack_index]
->tentatively_decrease_available_spaces($available_space);
}
}
}
# Count commas and look for non-list characters. Once we see a
# non-list character, we give up and don't look for any more commas.
if ( $type eq '=>' ) {
$gnu_arrow_count{$total_depth}++;
# remember '=>' like '=' for estimating breaks (but see above note
# for b1035)
$last_gnu_equals{$total_depth} = $max_index_to_go;
}
elsif ( $type eq ',' ) {
$gnu_comma_count{$total_depth}++;
}
elsif ( $is_assignment{$type} ) {
$last_gnu_equals{$total_depth} = $max_index_to_go;
}
# this token might start a new line
# if this is a non-blank..
if ( $type ne 'b' ) {
# and if ..
if (
# this is the first nonblank token of the line
$max_index_to_go == 1 && $types_to_go[0] eq 'b'
# or previous character was one of these:
|| $last_nonblank_type_in_batch =~ /^([\:\?\,f])$/
# or previous character was opening and this does not close it
|| ( $last_nonblank_type_in_batch eq '{' && $type ne '}' )
|| ( $last_nonblank_type_in_batch eq '(' and $type ne ')' )
# or this token is one of these:
|| $type =~ /^([\.]|\|\||\&\&)$/
# or this is a closing structure
|| ( $last_nonblank_type_in_batch eq '}'
&& $last_nonblank_token_in_batch eq
$last_nonblank_type_in_batch )
# or previous token was keyword 'return'
|| (
$last_nonblank_type_in_batch eq 'k'
&& ( $last_nonblank_token_in_batch eq 'return'
&& $type ne '{' )
)
# or starting a new line at certain keywords is fine
|| ( $type eq 'k'
&& $is_if_unless_and_or_last_next_redo_return{$token} )
# or this is after an assignment after a closing structure
|| (
$is_assignment{$last_nonblank_type_in_batch}
&& (
$last_last_nonblank_type_in_batch =~ /^[\}\)\]]$/
# and it is significantly to the right
|| $gnu_position_predictor > $halfway
)
)
)
{
check_for_long_gnu_style_lines($max_index_to_go);
$line_start_index_to_go = $max_index_to_go;
# back up 1 token if we want to break before that type
# otherwise, we may strand tokens like '?' or ':' on a line
if ( $line_start_index_to_go > 0 ) {
if ( $last_nonblank_type_in_batch eq 'k' ) {
if ( $want_break_before{$last_nonblank_token_in_batch} )
{
$line_start_index_to_go--;
}
}
elsif ( $want_break_before{$last_nonblank_type_in_batch} ) {
$line_start_index_to_go--;
}
}
}
}
# remember the predicted position of this token on the output line
if ( $max_index_to_go > $line_start_index_to_go ) {
$gnu_position_predictor =
total_line_length( $line_start_index_to_go, $max_index_to_go );
}
else {
$gnu_position_predictor =
$space_count + $token_lengths_to_go[$max_index_to_go];
}
# store the indentation object for this token
# this allows us to manipulate the leading whitespace
# (in case we have to reduce indentation to fit a line) without
# having to change any token values
$leading_spaces_to_go[$max_index_to_go] =
$gnu_stack[$max_gnu_stack_index];
$reduced_spaces_to_go[$max_index_to_go] =
( $max_gnu_stack_index > 0 && $ci_level )
? $gnu_stack[ $max_gnu_stack_index - 1 ]
: $gnu_stack[$max_gnu_stack_index];
return;
}
sub check_for_long_gnu_style_lines {
# look at the current estimated maximum line length, and
# remove some whitespace if it exceeds the desired maximum
my ($mx_index_to_go) = @_;
# this is only for the '-lp' style
return unless ($rOpts_line_up_parentheses);
# nothing can be done if no stack items defined for this line
return if ( $max_gnu_item_index == UNDEFINED_INDEX );
# see if we have exceeded the maximum desired line length
# keep 2 extra free because they are needed in some cases
# (result of trial-and-error testing)
my $spaces_needed =
$gnu_position_predictor -
$maximum_line_length_at_level[ $levels_to_go[$mx_index_to_go] ] + 2;
return if ( $spaces_needed <= 0 );
# We are over the limit, so try to remove a requested number of
# spaces from leading whitespace. We are only allowed to remove
# from whitespace items created on this batch, since others have
# already been used and cannot be undone.
my @candidates = ();
my $i;
# loop over all whitespace items created for the current batch
for ( $i = 0 ; $i <= $max_gnu_item_index ; $i++ ) {
my $item = $gnu_item_list[$i];
# item must still be open to be a candidate (otherwise it
# cannot influence the current token)
next if ( $item->get_closed() >= 0 );
my $available_spaces = $item->get_available_spaces();
if ( $available_spaces > 0 ) {
push( @candidates, [ $i, $available_spaces ] );
}
}
return unless (@candidates);
# sort by available whitespace so that we can remove whitespace
# from the maximum available first
@candidates = sort { $b->[1] <=> $a->[1] } @candidates;
# keep removing whitespace until we are done or have no more
foreach my $candidate (@candidates) {
my ( $i, $available_spaces ) = @{$candidate};
my $deleted_spaces =
( $available_spaces > $spaces_needed )
? $spaces_needed
: $available_spaces;
# remove the incremental space from this item
$gnu_item_list[$i]->decrease_available_spaces($deleted_spaces);
my $i_debug = $i;
# update the leading whitespace of this item and all items
# that came after it
for ( ; $i <= $max_gnu_item_index ; $i++ ) {
my $old_spaces = $gnu_item_list[$i]->get_spaces();
if ( $old_spaces >= $deleted_spaces ) {
$gnu_item_list[$i]->decrease_SPACES($deleted_spaces);
}
# shouldn't happen except for code bug:
else {
my $level = $gnu_item_list[$i_debug]->get_level();
my $ci_level = $gnu_item_list[$i_debug]->get_ci_level();
my $old_level = $gnu_item_list[$i]->get_level();
my $old_ci_level = $gnu_item_list[$i]->get_ci_level();
warning(
"program bug with -lp: want to delete $deleted_spaces from item $i, but old=$old_spaces deleted: lev=$level ci=$ci_level deleted: level=$old_level ci=$ci_level\n"
);
report_definite_bug();
}
}
$gnu_position_predictor -= $deleted_spaces;
$spaces_needed -= $deleted_spaces;
last unless ( $spaces_needed > 0 );
}
return;
}
sub finish_lp_batch {
# This routine is called once after each output stream batch is
# finished to undo indentation for all incomplete -lp
# indentation levels. It is too risky to leave a level open,
# because then we can't backtrack in case of a long line to follow.
# This means that comments and blank lines will disrupt this
# indentation style. But the vertical aligner may be able to
# get the space back if there are side comments.
# this is only for the 'lp' style
return unless ($rOpts_line_up_parentheses);
# nothing can be done if no stack items defined for this line
return if ( $max_gnu_item_index == UNDEFINED_INDEX );
# loop over all whitespace items created for the current batch
foreach my $i ( 0 .. $max_gnu_item_index ) {
my $item = $gnu_item_list[$i];
# only look for open items
next if ( $item->get_closed() >= 0 );
# Tentatively remove all of the available space
# (The vertical aligner will try to get it back later)
my $available_spaces = $item->get_available_spaces();
if ( $available_spaces > 0 ) {
# delete incremental space for this item
$gnu_item_list[$i]
->tentatively_decrease_available_spaces($available_spaces);
# Reduce the total indentation space of any nodes that follow
# Note that any such nodes must necessarily be dependents
# of this node.
foreach ( $i + 1 .. $max_gnu_item_index ) {
$gnu_item_list[$_]->decrease_SPACES($available_spaces);
}
}
}
return;
}
} ## end closure set_leading_whitespace
sub reduce_lp_indentation {
# reduce the leading whitespace at token $i if possible by $spaces_needed
# (a large value of $spaces_needed will remove all excess space)
# NOTE: to be called from scan_list only for a sequence of tokens
# contained between opening and closing parens/braces/brackets
my ( $self, $i, $spaces_wanted ) = @_;
my $deleted_spaces = 0;
my $item = $leading_spaces_to_go[$i];
my $available_spaces = $item->get_available_spaces();
if (
$available_spaces > 0
&& ( ( $spaces_wanted <= $available_spaces )
|| !$item->get_have_child() )
)
{
# we'll remove these spaces, but mark them as recoverable
$deleted_spaces =
$item->tentatively_decrease_available_spaces($spaces_wanted);
}
return $deleted_spaces;
}
###########################################################
# CODE SECTION 13: Preparing batches for vertical alignment
###########################################################
sub send_lines_to_vertical_aligner {
my ($self) = @_;
# This routine receives a batch of code for which the final line breaks
# have been defined. Here we prepare the lines for passing to the vertical
# aligner. We do the following tasks:
# - mark certain vertical alignment tokens, such as '=', in each line
# - make minor indentation adjustments
# - do logical padding: insert extra blank spaces to help display certain
# logical constructions
my $this_batch = $self->[_this_batch_];
my $rlines_K = $this_batch->[_rlines_K_];
if ( !@{$rlines_K} ) {
# This can't happen because sub grind_batch_of_CODE always receives
# tokens which it turns into one or more lines. If we get here it means
# that a programming error has caused those lines to be lost.
Fault("Unexpected call with no lines");
return;
}
my $n_last_line = @{$rlines_K} - 1;
my $do_not_pad = $this_batch->[_do_not_pad_];
my $peak_batch_size = $this_batch->[_peak_batch_size_];
my $starting_in_quote = $this_batch->[_starting_in_quote_];
my $ending_in_quote = $this_batch->[_ending_in_quote_];
my $is_static_block_comment = $this_batch->[_is_static_block_comment_];
my $ibeg0 = $this_batch->[_ibeg0_];
my $rK_to_go = $this_batch->[_rK_to_go_];
my $batch_count = $this_batch->[_batch_count_];
my $rix_seqno_controlling_ci = $this_batch->[_rix_seqno_controlling_ci_];
my $rLL = $self->[_rLL_];
my $Klimit = $self->[_Klimit_];
my ( $Kbeg_next, $Kend_next ) = @{ $rlines_K->[0] };
my $type_beg_next = $rLL->[$Kbeg_next]->[_TYPE_];
my $token_beg_next = $rLL->[$Kbeg_next]->[_TOKEN_];
my $type_end_next = $rLL->[$Kend_next]->[_TYPE_];
# Construct indexes to the global_to_go arrays so that called routines can
# still access those arrays. This might eventually be removed
# when all called routines have been converted to access token values
# in the rLL array instead.
my $Kbeg0 = $Kbeg_next;
my ( $ri_first, $ri_last );
foreach my $rline ( @{$rlines_K} ) {
my ( $Kbeg, $Kend ) = @{$rline};
my $ibeg = $ibeg0 + $Kbeg - $Kbeg0;
my $iend = $ibeg0 + $Kend - $Kbeg0;
push @{$ri_first}, $ibeg;
push @{$ri_last}, $iend;
}
my ( $cscw_block_comment, $closing_side_comment );
if ( $rOpts->{'closing-side-comments'} ) {
( $closing_side_comment, $cscw_block_comment ) =
$self->add_closing_side_comment();
}
my $rindentation_list = [0]; # ref to indentations for each line
# define the array @{$ralignment_type_to_go} for the output tokens
# which will be non-blank for each special token (such as =>)
# for which alignment is required.
my $ralignment_type_to_go =
$self->set_vertical_alignment_markers( $ri_first, $ri_last );
# flush before a long if statement to avoid unwanted alignment
if ( $n_last_line > 0
&& $type_beg_next eq 'k'
&& $token_beg_next =~ /^(if|unless)$/ )
{
$self->flush_vertical_aligner();
}
$self->undo_ci( $ri_first, $ri_last, $rix_seqno_controlling_ci );
$self->set_logical_padding( $ri_first, $ri_last, $peak_batch_size,
$starting_in_quote )
if ( $rOpts->{'logical-padding'} );
# Resum lengths. We need accurate lengths for making alignment patterns,
# and we may have unmasked a semicolon which was not included at the start.
for ( 0 .. $max_index_to_go ) {
$summed_lengths_to_go[ $_ + 1 ] =
$summed_lengths_to_go[$_] + $token_lengths_to_go[$_];
}
# loop to prepare each line for shipment
my ( $Kbeg, $type_beg, $token_beg );
my ( $Kend, $type_end );
for my $n ( 0 .. $n_last_line ) {
my $ibeg = $ri_first->[$n];
my $iend = $ri_last->[$n];
my $rline = $rlines_K->[$n];
my $forced_breakpoint = $rline->[2];
# we may need to look at variables on three consecutive lines ...
# Some vars on line [n-1], if any:
my $Kbeg_last = $Kbeg;
my $type_beg_last = $type_beg;
my $token_beg_last = $token_beg;
my $Kend_last = $Kend;
my $type_end_last = $type_end;
# Some vars on line [n]:
$Kbeg = $Kbeg_next;
$type_beg = $type_beg_next;
$token_beg = $token_beg_next;
$Kend = $Kend_next;
$type_end = $type_end_next;
# Only forward ending K values of non-comments down the pipeline.
# This is equivalent to checking that the last CODE_type is blank or
# equal to 'VER'. See also sub resync_lines_and_tokens for related
# coding. Note that '$batch_CODE_type' is the code type of the line
# to which the ending token belongs.
my $batch_CODE_type = $this_batch->[_batch_CODE_type_];
my $Kend_code =
$batch_CODE_type && $batch_CODE_type ne 'VER' ? undef : $Kend;
# We use two slightly different definitions of level jump at the end
# of line:
# $ljump is the level jump needed by 'sub set_adjusted_indentation'
# $level_jump is the level jump needed by the vertical aligner.
my $ljump = 0; # level jump at end of line
# Get some vars on line [n+1], if any:
if ( $n < $n_last_line ) {
( $Kbeg_next, $Kend_next ) =
@{ $rlines_K->[ $n + 1 ] };
$type_beg_next = $rLL->[$Kbeg_next]->[_TYPE_];
$token_beg_next = $rLL->[$Kbeg_next]->[_TOKEN_];
$type_end_next = $rLL->[$Kend_next]->[_TYPE_];
$ljump = $rLL->[$Kbeg_next]->[_LEVEL_] - $rLL->[$Kend]->[_LEVEL_];
}
else {
# Patch for git #51, a bare closing qw paren was not outdented
# if the flag '-nodelete-old-newlines is set
my $Kbeg_next = $self->K_next_code($Kend);
if ( defined($Kbeg_next) ) {
$ljump =
$rLL->[$Kbeg_next]->[_LEVEL_] - $rLL->[$Kend]->[_LEVEL_];
}
}
# level jump at end of line for the vertical aligner:
my $level_jump =
$Kend >= $Klimit
? 0
: $rLL->[ $Kend + 1 ]->[_SLEVEL_] - $rLL->[$Kbeg]->[_SLEVEL_];
$self->delete_needless_alignments( $ibeg, $iend,
$ralignment_type_to_go );
my ( $rtokens, $rfields, $rpatterns, $rfield_lengths ) =
$self->make_alignment_patterns( $ibeg, $iend,
$ralignment_type_to_go );
my ( $indentation, $lev, $level_end, $terminal_type,
$terminal_block_type, $is_semicolon_terminated, $is_outdented_line )
= $self->set_adjusted_indentation( $ibeg, $iend, $rfields,
$rpatterns, $ri_first, $ri_last,
$rindentation_list, $ljump, $starting_in_quote,
$is_static_block_comment, );
# we will allow outdenting of long lines..
my $outdent_long_lines = (
# which are long quotes, if allowed
( $type_beg eq 'Q' && $rOpts->{'outdent-long-quotes'} )
# which are long block comments, if allowed
|| (
$type_beg eq '#'
&& $rOpts->{'outdent-long-comments'}
# but not if this is a static block comment
&& !$is_static_block_comment
)
);
my $break_alignment_before = $is_outdented_line || $do_not_pad;
my $break_alignment_after = $is_outdented_line;
# flush at an 'if' which follows a line with (1) terminal semicolon
# or (2) terminal block_type which is not an 'if'. This prevents
# unwanted alignment between the lines.
if ( $type_beg eq 'k' && $token_beg eq 'if' ) {
my $Km = $self->K_previous_code($Kbeg);
my $type_m = 'b';
my $block_type_m = 'b';
if ( defined($Km) ) {
$type_m = $rLL->[$Km]->[_TYPE_];
$block_type_m = $rLL->[$Km]->[_BLOCK_TYPE_];
}
# break after anything that is not if-like
$break_alignment_before ||= $type_m eq ';'
|| ( $type_m eq '}'
&& $block_type_m ne 'if'
&& $block_type_m ne 'unless'
&& $block_type_m ne 'elsif'
&& $block_type_m ne 'else' );
}
my $rvertical_tightness_flags =
$self->set_vertical_tightness_flags( $n, $n_last_line, $ibeg, $iend,
$ri_first, $ri_last, $ending_in_quote, $closing_side_comment );
# Set a flag at the final ':' of a ternary chain to request
# vertical alignment of the final term. Here is a
# slightly complex example:
#
# $self->{_text} = (
# !$section ? ''
# : $type eq 'item' ? "the $section entry"
# : "the section on $section"
# )
# . (
# $page
# ? ( $section ? ' in ' : '' ) . "the $page$page_ext manpage"
# : ' elsewhere in this document'
# );
#
my $is_terminal_ternary = 0;
if ( $type_beg eq ':' || $n > 0 && $type_end_last eq ':' ) {
my $last_leading_type = $n > 0 ? $type_beg_last : ':';
if ( $terminal_type ne ';'
&& $n_last_line > $n
&& $level_end == $lev )
{
$level_end = $rLL->[$Kbeg_next]->[_LEVEL_];
$terminal_type = $rLL->[$Kbeg_next]->[_TYPE_];
}
if (
$last_leading_type eq ':'
&& ( ( $terminal_type eq ';' && $level_end <= $lev )
|| ( $terminal_type ne ':' && $level_end < $lev ) )
)
{
# the terminal term must not contain any ternary terms, as in
# my $ECHO = (
# $Is_MSWin32 ? ".\\echo$$"
# : $Is_MacOS ? ":echo$$"
# : ( $Is_NetWare ? "echo$$" : "./echo$$" )
# );
$is_terminal_ternary = 1;
my $KP = $rLL->[$Kbeg]->[_KNEXT_SEQ_ITEM_];
while ( defined($KP) && $KP <= $Kend ) {
my $type_KP = $rLL->[$KP]->[_TYPE_];
if ( $type_KP eq '?' || $type_KP eq ':' ) {
$is_terminal_ternary = 0;
last;
}
$KP = $rLL->[$KP]->[_KNEXT_SEQ_ITEM_];
}
}
}
my $level_adj = $lev;
my $radjusted_levels = $self->[_radjusted_levels_];
if ( defined($radjusted_levels) && @{$radjusted_levels} == @{$rLL} ) {
$level_adj = $radjusted_levels->[$Kbeg];
if ( $level_adj < 0 ) { $level_adj = 0 }
}
# add any new closing side comment to the last line
if ( $closing_side_comment && $n == $n_last_line && @{$rfields} ) {
$rfields->[-1] .= " $closing_side_comment";
# NOTE: Patch for csc. We can just use 1 for the length of the csc
# because its length should not be a limiting factor from here on.
$rfield_lengths->[-1] += 2;
}
# Programming check: (shouldn't happen)
# The number of tokens which separate the fields must always be
# one less than the number of fields. If this is not true then
# an error has been introduced in sub make_alignment_patterns.
if ( @{$rfields} && ( @{$rtokens} != ( @{$rfields} - 1 ) ) ) {
my $nt = @{$rtokens};
my $nf = @{$rfields};
my $msg = <is_list_by_K($Kbeg);
# send this new line down the pipe
my $rvalign_hash = {};
$rvalign_hash->{level} = $lev;
$rvalign_hash->{level_end} = $level_end;
$rvalign_hash->{level_adj} = $level_adj;
$rvalign_hash->{indentation} = $indentation;
$rvalign_hash->{list_seqno} = $list_seqno;
$rvalign_hash->{outdent_long_lines} = $outdent_long_lines;
$rvalign_hash->{is_terminal_ternary} = $is_terminal_ternary;
$rvalign_hash->{rvertical_tightness_flags} = $rvertical_tightness_flags;
$rvalign_hash->{level_jump} = $level_jump;
$rvalign_hash->{rfields} = $rfields;
$rvalign_hash->{rpatterns} = $rpatterns;
$rvalign_hash->{rtokens} = $rtokens;
$rvalign_hash->{rfield_lengths} = $rfield_lengths;
$rvalign_hash->{terminal_block_type} = $terminal_block_type;
$rvalign_hash->{batch_count} = $batch_count;
$rvalign_hash->{break_alignment_before} = $break_alignment_before;
$rvalign_hash->{break_alignment_after} = $break_alignment_after;
$rvalign_hash->{Kend} = $Kend_code;
$rvalign_hash->{ci_level} = $ci_levels_to_go[$ibeg];
my $vao = $self->[_vertical_aligner_object_];
$vao->valign_input($rvalign_hash);
$do_not_pad = 0;
# Set flag indicating if this line ends in an opening
# token and is very short, so that a blank line is not
# needed if the subsequent line is a comment.
# Examples of what we are looking for:
# {
# && (
# BEGIN {
# default {
# sub {
$self->[_last_output_short_opening_token_]
# line ends in opening token
# /^[\{\(\[L]$/
= $is_opening_type{$type_end}
# and either
&& (
# line has either single opening token
$Kend == $Kbeg
# or is a single token followed by opening token.
# Note that sub identifiers have blanks like 'sub doit'
# $token_beg !~ /\s+/
|| ( $Kend - $Kbeg <= 2 && index( $token_beg, ' ' ) < 0 )
)
# and limit total to 10 character widths
&& token_sequence_length( $ibeg, $iend ) <= 10;
} # end of loop to output each line
# remember indentation of lines containing opening containers for
# later use by sub set_adjusted_indentation
$self->save_opening_indentation( $ri_first, $ri_last, $rindentation_list );
# output any new -cscw block comment
if ($cscw_block_comment) {
$self->flush_vertical_aligner();
my $file_writer_object = $self->[_file_writer_object_];
$file_writer_object->write_code_line( $cscw_block_comment . "\n" );
}
return;
}
{ ## begin closure set_vertical_alignment_markers
my %is_vertical_alignment_type;
my %is_not_vertical_alignment_token;
my %is_vertical_alignment_keyword;
my %is_terminal_alignment_type;
my %is_low_level_alignment_token;
BEGIN {
my @q;
# Replaced =~ and // in the list. // had been removed in RT 119588
@q = qw#
= **= += *= &= <<= &&= -= /= |= >>= ||= //= .= %= ^= x=
{ ? : => && || ~~ !~~ =~ !~ // <=> ->
#;
@is_vertical_alignment_type{@q} = (1) x scalar(@q);
# These 'tokens' are not aligned. We need this to remove [
# from the above list because it has type ='{'
@q = qw([);
@is_not_vertical_alignment_token{@q} = (1) x scalar(@q);
# these are the only types aligned at a line end
@q = qw(&& || =>);
@is_terminal_alignment_type{@q} = (1) x scalar(@q);
# these tokens only align at line level
@q = ( '{', '(' );
@is_low_level_alignment_token{@q} = (1) x scalar(@q);
# eq and ne were removed from this list to improve alignment chances
@q = qw(if unless and or err for foreach while until);
@is_vertical_alignment_keyword{@q} = (1) x scalar(@q);
}
sub set_vertical_alignment_markers {
# This routine takes the first step toward vertical alignment of the
# lines of output text. It looks for certain tokens which can serve as
# vertical alignment markers (such as an '=').
#
# Method: We look at each token $i in this output batch and set
# $ralignment_type_to_go->[$i] equal to those tokens at which we would
# accept vertical alignment.
my ( $self, $ri_first, $ri_last ) = @_;
my $rspecial_side_comment_type = $self->[_rspecial_side_comment_type_];
my $ralignment_type_to_go;
# Initialize the alignment array. Note that closing side comments can
# insert up to 2 additional tokens beyond the original
# $max_index_to_go, so we need to check ri_last for the last index.
my $max_line = @{$ri_first} - 1;
my $iend = $ri_last->[$max_line];
if ( $iend < $max_index_to_go ) { $iend = $max_index_to_go }
# nothing to do if we aren't allowed to change whitespace
# or there is only 1 token
if ( $iend == 0 || !$rOpts_add_whitespace ) {
for my $i ( 0 .. $iend ) {
$ralignment_type_to_go->[$i] = '';
}
return $ralignment_type_to_go;
}
# remember the index of last nonblank token before any sidecomment
my $i_terminal = $max_index_to_go;
if ( $types_to_go[$i_terminal] eq '#' ) {
if ( $i_terminal > 0 && $types_to_go[ --$i_terminal ] eq 'b' ) {
if ( $i_terminal > 0 ) { --$i_terminal }
}
}
# look at each line of this batch..
my $last_vertical_alignment_before_index;
my $vert_last_nonblank_type;
my $vert_last_nonblank_token;
my $vert_last_nonblank_block_type;
foreach my $line ( 0 .. $max_line ) {
my $ibeg = $ri_first->[$line];
my $iend = $ri_last->[$line];
$last_vertical_alignment_before_index = -1;
$vert_last_nonblank_type = '';
$vert_last_nonblank_token = '';
$vert_last_nonblank_block_type = '';
# look at each token in this output line..
my $level_beg = $levels_to_go[$ibeg];
foreach my $i ( $ibeg .. $iend ) {
my $alignment_type = '';
my $type = $types_to_go[$i];
my $block_type = $block_type_to_go[$i];
my $token = $tokens_to_go[$i];
# do not align tokens at lower level then start of line
# except for side comments
if ( $levels_to_go[$i] < $levels_to_go[$ibeg]
&& $type ne '#' )
{
$ralignment_type_to_go->[$i] = '';
next;
}
#--------------------------------------------------------
# First see if we want to align BEFORE this token
#--------------------------------------------------------
# The first possible token that we can align before
# is index 2 because: 1) it doesn't normally make sense to
# align before the first token and 2) the second
# token must be a blank if we are to align before
# the third
if ( $i < $ibeg + 2 ) { }
# must follow a blank token
elsif ( $types_to_go[ $i - 1 ] ne 'b' ) { }
# align a side comment --
elsif ( $type eq '#' ) {
my $KK = $K_to_go[$i];
my $sc_type = $rspecial_side_comment_type->{$KK};
unless (
# it is any specially marked side comment
$sc_type
# or it is a static side comment
|| ( $rOpts->{'static-side-comments'}
&& $token =~ /$static_side_comment_pattern/ )
# or a closing side comment
|| ( $vert_last_nonblank_block_type
&& $token =~
/$closing_side_comment_prefix_pattern/ )
)
{
$alignment_type = $type;
} ## Example of a static side comment
}
# otherwise, do not align two in a row to create a
# blank field
elsif ( $last_vertical_alignment_before_index == $i - 2 ) { }
# align before one of these keywords
# (within a line, since $i>1)
elsif ( $type eq 'k' ) {
# /^(if|unless|and|or|eq|ne)$/
if ( $is_vertical_alignment_keyword{$token} ) {
$alignment_type = $token;
}
}
# align before one of these types..
# Note: add '.' after new vertical aligner is operational
elsif ( $is_vertical_alignment_type{$type}
&& !$is_not_vertical_alignment_token{$token} )
{
$alignment_type = $token;
# Do not align a terminal token. Although it might
# occasionally look ok to do this, this has been found to be
# a good general rule. The main problems are:
# (1) that the terminal token (such as an = or :) might get
# moved far to the right where it is hard to see because
# nothing follows it, and
# (2) doing so may prevent other good alignments.
# Current exceptions are && and || and =>
if ( $i == $iend || $i >= $i_terminal ) {
$alignment_type = ""
unless ( $is_terminal_alignment_type{$type} );
}
# Do not align leading ': (' or '. ('. This would prevent
# alignment in something like the following:
# $extra_space .=
# ( $input_line_number < 10 ) ? " "
# : ( $input_line_number < 100 ) ? " "
# : "";
# or
# $code =
# ( $case_matters ? $accessor : " lc($accessor) " )
# . ( $yesno ? " eq " : " ne " )
# Also, do not align a ( following a leading ? so we can
# align something like this:
# $converter{$_}->{ushortok} =
# $PDL::IO::Pic::biggrays
# ? ( m/GIF/ ? 0 : 1 )
# : ( m/GIF|RAST|IFF/ ? 0 : 1 );
if (
$i == $ibeg + 2
&& $types_to_go[ $i - 1 ] eq 'b'
&& ( $types_to_go[$ibeg] eq '.'
|| $types_to_go[$ibeg] eq ':'
|| $types_to_go[$ibeg] eq '?' )
)
{
$alignment_type = "";
}
# Certain tokens only align at the same level as the
# initial line level
if ( $is_low_level_alignment_token{$token}
&& $levels_to_go[$i] != $level_beg )
{
$alignment_type = "";
}
# For a paren after keyword, only align something like this:
# if ( $a ) { &a }
# elsif ( $b ) { &b }
if ( $token eq '(' ) {
if ( $vert_last_nonblank_type eq 'k' ) {
$alignment_type = ""
unless $vert_last_nonblank_token =~
/^(if|unless|elsif)$/;
}
# Do not align a spaced-function-paren if requested.
# Issue git #53. Note that $i-1 is a blank token if we
# get here.
if ( !$rOpts_function_paren_vertical_alignment
&& $i > $ibeg + 1 )
{
my $type_m = $types_to_go[ $i - 2 ];
my $token_m = $tokens_to_go[ $i - 2 ];
# this is the same test as 'space-function-paren'
if ( $type_m =~ /^[wUG]$/
|| $type_m eq '->'
|| $type_m =~ /^[wi]$/
&& $token_m =~ /^(\&|->)/ )
{
$alignment_type = "";
}
}
}
# be sure the alignment tokens are unique
# This didn't work well: reason not determined
# if ($token ne $type) {$alignment_type .= $type}
}
# NOTE: This is deactivated because it causes the previous
# if/elsif alignment to fail
#elsif ( $type eq '}' && $token eq '}' && $block_type_to_go[$i])
#{ $alignment_type = $type; }
if ($alignment_type) {
$last_vertical_alignment_before_index = $i;
}
#--------------------------------------------------------
# Next see if we want to align AFTER the previous nonblank
#--------------------------------------------------------
# We want to line up ',' and interior ';' tokens, with the added
# space AFTER these tokens. (Note: interior ';' is included
# because it may occur in short blocks).
if (
# we haven't already set it
!$alignment_type
# and its not the first token of the line
&& ( $i > $ibeg )
# and it follows a blank
&& $types_to_go[ $i - 1 ] eq 'b'
# and previous token IS one of these:
&& ( $vert_last_nonblank_type eq ','
|| $vert_last_nonblank_type eq ';' )
# and it's NOT one of these
&& ( $type ne 'b'
&& $type ne '#'
&& !$is_closing_token{$type} )
# then go ahead and align
)
{
$alignment_type = $vert_last_nonblank_type;
}
#--------------------------------------------------------
# Undo alignment in special cases
#--------------------------------------------------------
if ($alignment_type) {
# do not align the opening brace of an anonymous sub
if ( $token eq '{' && $block_type =~ /$ASUB_PATTERN/ ) {
$alignment_type = "";
}
}
#--------------------------------------------------------
# then store the value
#--------------------------------------------------------
$ralignment_type_to_go->[$i] = $alignment_type;
if ( $type ne 'b' ) {
$vert_last_nonblank_type = $type;
$vert_last_nonblank_token = $token;
$vert_last_nonblank_block_type = $block_type;
}
}
}
return $ralignment_type_to_go;
}
} ## end closure set_vertical_alignment_markers
sub get_seqno {
# get opening and closing sequence numbers of a token for the vertical
# aligner. Assign qw quotes a value to allow qw opening and closing tokens
# to be treated somewhat like opening and closing tokens for stacking
# tokens by the vertical aligner.
my ( $self, $ii, $ending_in_quote ) = @_;
my $rLL = $self->[_rLL_];
my $this_batch = $self->[_this_batch_];
my $rK_to_go = $this_batch->[_rK_to_go_];
my $KK = $rK_to_go->[$ii];
my $seqno = $rLL->[$KK]->[_TYPE_SEQUENCE_];
if ( $rLL->[$KK]->[_TYPE_] eq 'q' ) {
my $SEQ_QW = -1;
my $token = $rLL->[$KK]->[_TOKEN_];
if ( $ii > 0 ) {
$seqno = $SEQ_QW if ( $token =~ /^qw\s*[\(\{\[]/ );
}
else {
if ( !$ending_in_quote ) {
$seqno = $SEQ_QW if ( $token =~ /[\)\}\]]$/ );
}
}
}
return ($seqno);
}
{
my %undo_extended_ci;
sub initialize_undo_ci {
%undo_extended_ci = ();
return;
}
sub undo_ci {
# Undo continuation indentation in certain sequences
my ( $self, $ri_first, $ri_last, $rix_seqno_controlling_ci ) = @_;
my ( $line_1, $line_2, $lev_last );
my $this_line_is_semicolon_terminated;
my $max_line = @{$ri_first} - 1;
my $rseqno_controlling_my_ci = $self->[_rseqno_controlling_my_ci_];
# Prepare a list of controlling indexes for each line if required.
# This is used for efficient processing below. Note: this is
# critical for speed. In the initial implementation I just looped
# through the @$rix_seqno_controlling_ci list below. Using NYT_prof, I
# found that this routine was causing a huge run time in large lists.
# On a very large list test case, this new coding dropped the run time
# of this routine from 30 seconds to 169 milliseconds.
my @i_controlling_ci;
if ( @{$rix_seqno_controlling_ci} ) {
my @tmp = reverse @{$rix_seqno_controlling_ci};
my $ix_next = pop @tmp;
foreach my $line ( 0 .. $max_line ) {
my $iend = $ri_last->[$line];
while ( defined($ix_next) && $ix_next <= $iend ) {
push @{ $i_controlling_ci[$line] }, $ix_next;
$ix_next = pop @tmp;
}
}
}
# Loop over all lines of the batch ...
# Workaround for problem c007, in which the combination -lp -xci
# can produce a "Program bug" message in unusual circumstances.
my $skip_SECTION_1 = $rOpts_line_up_parentheses
&& $rOpts->{'extended-continuation-indentation'};
foreach my $line ( 0 .. $max_line ) {
my $ibeg = $ri_first->[$line];
my $iend = $ri_last->[$line];
my $lev = $levels_to_go[$ibeg];
####################################
# SECTION 1: Undo needless common CI
####################################
# We are looking at leading tokens and looking for a sequence all
# at the same level and all at a higher level than enclosing lines.
# For example, we can undo continuation indentation in sort/map/grep
# chains
# my $dat1 = pack( "n*",
# map { $_, $lookup->{$_} }
# sort { $a <=> $b }
# grep { $lookup->{$_} ne $default } keys %$lookup );
# to become
# my $dat1 = pack( "n*",
# map { $_, $lookup->{$_} }
# sort { $a <=> $b }
# grep { $lookup->{$_} ne $default } keys %$lookup );
if ( $line > 0 && !$skip_SECTION_1 ) {
# if we have started a chain..
if ($line_1) {
# see if it continues..
if ( $lev == $lev_last ) {
if ( $types_to_go[$ibeg] eq 'k'
&& $is_sort_map_grep{ $tokens_to_go[$ibeg] } )
{
# chain continues...
# check for chain ending at end of a statement
if ( $line == $max_line ) {
# see of this line ends a statement
$this_line_is_semicolon_terminated =
$types_to_go[$iend] eq ';'
# with possible side comment
|| ( $types_to_go[$iend] eq '#'
&& $iend - $ibeg >= 2
&& $types_to_go[ $iend - 2 ] eq ';'
&& $types_to_go[ $iend - 1 ] eq 'b' );
}
$line_2 = $line
if ($this_line_is_semicolon_terminated);
}
else {
# kill chain
$line_1 = undef;
}
}
elsif ( $lev < $lev_last ) {
# chain ends with previous line
$line_2 = $line - 1;
}
elsif ( $lev > $lev_last ) {
# kill chain
$line_1 = undef;
}
# undo the continuation indentation if a chain ends
if ( defined($line_2) && defined($line_1) ) {
my $continuation_line_count = $line_2 - $line_1 + 1;
@ci_levels_to_go[ @{$ri_first}[ $line_1 .. $line_2 ] ]
= (0) x ($continuation_line_count)
if ( $continuation_line_count >= 0 );
@leading_spaces_to_go[ @{$ri_first}
[ $line_1 .. $line_2 ] ] =
@reduced_spaces_to_go[ @{$ri_first}
[ $line_1 .. $line_2 ] ];
$line_1 = undef;
}
}
# not in a chain yet..
else {
# look for start of a new sort/map/grep chain
if ( $lev > $lev_last ) {
if ( $types_to_go[$ibeg] eq 'k'
&& $is_sort_map_grep{ $tokens_to_go[$ibeg] } )
{
$line_1 = $line;
}
}
}
}
######################################
# SECTION 2: Undo ci at cuddled blocks
######################################
# Note that sub set_adjusted_indentation will be called later to
# actually do this, but for now we will tentatively mark cuddled
# lines with ci=0 so that the the -xci loop which follows will be
# correct at cuddles.
if (
$types_to_go[$ibeg] eq '}'
&& ( $nesting_depth_to_go[$iend] + 1 ==
$nesting_depth_to_go[$ibeg] )
)
{
my $terminal_type = $types_to_go[$iend];
if ( $terminal_type eq '#' && $iend > $ibeg ) {
$terminal_type = $types_to_go[ $iend - 1 ];
if ( $terminal_type eq '#' && $iend - 1 > $ibeg ) {
$terminal_type = $types_to_go[ $iend - 2 ];
}
}
if ( $terminal_type eq '{' ) {
my $Kbeg = $K_to_go[$ibeg];
$ci_levels_to_go[$ibeg] = 0;
}
}
#########################################################
# SECTION 3: Undo ci set by sub extended_ci if not needed
#########################################################
# Undo the ci of the leading token if its controlling token
# went out on a previous line without ci
if ( $ci_levels_to_go[$ibeg] ) {
my $Kbeg = $K_to_go[$ibeg];
my $seqno = $rseqno_controlling_my_ci->{$Kbeg};
if ( $seqno && $undo_extended_ci{$seqno} ) {
# but do not undo ci set by the -lp flag
if ( !ref( $reduced_spaces_to_go[$ibeg] ) ) {
$ci_levels_to_go[$ibeg] = 0;
$leading_spaces_to_go[$ibeg] =
$reduced_spaces_to_go[$ibeg];
}
}
}
# Flag any controlling opening tokens in lines without ci. This
# will be used later in the above if statement to undo the ci which
# they added. The array i_controlling_ci[$line] was prepared at
# the top of this routine.
if ( !$ci_levels_to_go[$ibeg]
&& defined( $i_controlling_ci[$line] ) )
{
foreach my $i ( @{ $i_controlling_ci[$line] } ) {
my $seqno = $type_sequence_to_go[$i];
$undo_extended_ci{$seqno} = 1;
}
}
$lev_last = $lev;
}
return;
}
}
{ ## begin closure set_logical_padding
my %is_math_op;
BEGIN {
my @q = qw( + - * / );
@is_math_op{@q} = (1) x scalar(@q);
}
sub set_logical_padding {
# Look at a batch of lines and see if extra padding can improve the
# alignment when there are certain leading operators. Here is an
# example, in which some extra space is introduced before
# '( $year' to make it line up with the subsequent lines:
#
# if ( ( $Year < 1601 )
# || ( $Year > 2899 )
# || ( $EndYear < 1601 )
# || ( $EndYear > 2899 ) )
# {
# &Error_OutOfRange;
# }
#
my ( $self, $ri_first, $ri_last, $peak_batch_size, $starting_in_quote )
= @_;
my $max_line = @{$ri_first} - 1;
my ( $ibeg, $ibeg_next, $ibegm, $iend, $iendm, $ipad, $pad_spaces,
$tok_next, $type_next, $has_leading_op_next, $has_leading_op );
# Patch to produce padding in the first line of short code blocks.
# This is part of an update to fix cases b562 .. b983.
# This is needed to compensate for a change which was made in 'sub
# starting_one_line_block' to prevent blinkers. Previously, that sub
# would not look at the total block size and rely on sub
# set_continuation_breaks to break up long blocks. Consequently, the
# first line of those batches would end in the opening block brace of a
# sort/map/grep/eval block. When this was changed to immediately check
# for blocks which were too long, the opening block brace would go out
# in a single batch, and the block contents would go out as the next
# batch. This caused the logic in this routine which decides if the
# first line should be padded to be incorrect. To fix this, we set a
# flag if the previous batch ended in an opening sort/map/grep/eval
# block brace, and use it to adjust the logic to compensate.
# For example, the following would have previously been a single batch
# but now is two batches. We want to pad the line starting in '$dir':
# my (@indices) = # batch n-1 (prev batch n)
# sort { # batch n-1 (prev batch n)
# $dir eq 'left' # batch n
# ? $cells[$a] <=> $cells[$b] # batch n
# : $cells[$b] <=> $cells[$a]; # batch n
# } ( 0 .. $#cells ); # batch n
my $rLL = $self->[_rLL_];
my $K0 = $K_to_go[0];
my $Kprev = $self->K_previous_code($K0);
my $is_short_block;
if ( defined($Kprev)
&& $rLL->[$Kprev]->[_BLOCK_TYPE_] )
{
my $block_type = $rLL->[$Kprev]->[_BLOCK_TYPE_];
$is_short_block = $is_sort_map_grep_eval{$block_type};
$is_short_block ||= $want_one_line_block{$block_type};
}
# looking at each line of this batch..
foreach my $line ( 0 .. $max_line - 1 ) {
# see if the next line begins with a logical operator
$ibeg = $ri_first->[$line];
$iend = $ri_last->[$line];
$ibeg_next = $ri_first->[ $line + 1 ];
$tok_next = $tokens_to_go[$ibeg_next];
$type_next = $types_to_go[$ibeg_next];
$has_leading_op_next = ( $tok_next =~ /^\w/ )
? $is_chain_operator{$tok_next} # + - * / : ? && ||
: $is_chain_operator{$type_next}; # and, or
next unless ($has_leading_op_next);
# next line must not be at lesser depth
next
if ( $nesting_depth_to_go[$ibeg] >
$nesting_depth_to_go[$ibeg_next] );
# identify the token in this line to be padded on the left
$ipad = undef;
# handle lines at same depth...
if ( $nesting_depth_to_go[$ibeg] ==
$nesting_depth_to_go[$ibeg_next] )
{
# if this is not first line of the batch ...
if ( $line > 0 ) {
# and we have leading operator..
next if $has_leading_op;
# Introduce padding if..
# 1. the previous line is at lesser depth, or
# 2. the previous line ends in an assignment
# 3. the previous line ends in a 'return'
# 4. the previous line ends in a comma
# Example 1: previous line at lesser depth
# if ( ( $Year < 1601 ) # <- we are here but
# || ( $Year > 2899 ) # list has not yet
# || ( $EndYear < 1601 ) # collapsed vertically
# || ( $EndYear > 2899 ) )
# {
#
# Example 2: previous line ending in assignment:
# $leapyear =
# $year % 4 ? 0 # <- We are here
# : $year % 100 ? 1
# : $year % 400 ? 0
# : 1;
#
# Example 3: previous line ending in comma:
# push @expr,
# /test/ ? undef
# : eval($_) ? 1
# : eval($_) ? 1
# : 0;
# be sure levels agree (do not indent after an indented 'if')
next
if ( $levels_to_go[$ibeg] ne $levels_to_go[$ibeg_next] );
# allow padding on first line after a comma but only if:
# (1) this is line 2 and
# (2) there are at more than three lines and
# (3) lines 3 and 4 have the same leading operator
# These rules try to prevent padding within a long
# comma-separated list.
my $ok_comma;
if ( $types_to_go[$iendm] eq ','
&& $line == 1
&& $max_line > 2 )
{
my $ibeg_next_next = $ri_first->[ $line + 2 ];
my $tok_next_next = $tokens_to_go[$ibeg_next_next];
$ok_comma = $tok_next_next eq $tok_next;
}
next
unless (
$is_assignment{ $types_to_go[$iendm] }
|| $ok_comma
|| ( $nesting_depth_to_go[$ibegm] <
$nesting_depth_to_go[$ibeg] )
|| ( $types_to_go[$iendm] eq 'k'
&& $tokens_to_go[$iendm] eq 'return' )
);
# we will add padding before the first token
$ipad = $ibeg;
}
# for first line of the batch..
else {
# WARNING: Never indent if first line is starting in a
# continued quote, which would change the quote.
next if $starting_in_quote;
# if this is text after closing '}'
# then look for an interior token to pad
if ( $types_to_go[$ibeg] eq '}' ) {
}
# otherwise, we might pad if it looks really good
elsif ($is_short_block) {
$ipad = $ibeg;
}
else {
# we might pad token $ibeg, so be sure that it
# is at the same depth as the next line.
next
if ( $nesting_depth_to_go[$ibeg] !=
$nesting_depth_to_go[$ibeg_next] );
# We can pad on line 1 of a statement if at least 3
# lines will be aligned. Otherwise, it
# can look very confusing.
# We have to be careful not to pad if there are too few
# lines. The current rule is:
# (1) in general we require at least 3 consecutive lines
# with the same leading chain operator token,
# (2) but an exception is that we only require two lines
# with leading colons if there are no more lines. For example,
# the first $i in the following snippet would get padding
# by the second rule:
#
# $i == 1 ? ( "First", "Color" )
# : $i == 2 ? ( "Then", "Rarity" )
# : ( "Then", "Name" );
if ( $max_line > 1 ) {
my $leading_token = $tokens_to_go[$ibeg_next];
my $tokens_differ;
# never indent line 1 of a '.' series because
# previous line is most likely at same level.
# TODO: we should also look at the leading_spaces
# of the last output line and skip if it is same
# as this line.
next if ( $leading_token eq '.' );
my $count = 1;
foreach my $l ( 2 .. 3 ) {
last if ( $line + $l > $max_line );
my $ibeg_next_next = $ri_first->[ $line + $l ];
if ( $tokens_to_go[$ibeg_next_next] ne
$leading_token )
{
$tokens_differ = 1;
last;
}
$count++;
}
next if ($tokens_differ);
next if ( $count < 3 && $leading_token ne ':' );
$ipad = $ibeg;
}
else {
next;
}
}
}
}
# find interior token to pad if necessary
if ( !defined($ipad) ) {
for ( my $i = $ibeg ; ( $i < $iend ) && !$ipad ; $i++ ) {
# find any unclosed container
next
unless ( $type_sequence_to_go[$i]
&& $mate_index_to_go[$i] > $iend );
# find next nonblank token to pad
$ipad = $inext_to_go[$i];
last if ( $ipad > $iend );
}
last unless $ipad;
}
# We cannot pad the first leading token of a file because
# it could cause a bug in which the starting indentation
# level is guessed incorrectly each time the code is run
# though perltidy, thus causing the code to march off to
# the right. For example, the following snippet would have
# this problem:
## ov_method mycan( $package, '(""' ), $package
## or ov_method mycan( $package, '(0+' ), $package
## or ov_method mycan( $package, '(bool' ), $package
## or ov_method mycan( $package, '(nomethod' ), $package;
# If this snippet is within a block this won't happen
# unless the user just processes the snippet alone within
# an editor. In that case either the user will see and
# fix the problem or it will be corrected next time the
# entire file is processed with perltidy.
next if ( $ipad == 0 && $peak_batch_size <= 1 );
## THIS PATCH REMOVES THE FOLLOWING POOR PADDING (math.t) with -pbp, BUT
## IT DID MORE HARM THAN GOOD
## ceil(
## $font->{'loca'}->{'glyphs'}[$x]->read->{'xMin'} * 1000
## / $upem
## ),
##? # do not put leading padding for just 2 lines of math
##? if ( $ipad == $ibeg
##? && $line > 0
##? && $levels_to_go[$ipad] > $levels_to_go[ $ipad - 1 ]
##? && $is_math_op{$type_next}
##? && $line + 2 <= $max_line )
##? {
##? my $ibeg_next_next = $ri_first->[ $line + 2 ];
##? my $type_next_next = $types_to_go[$ibeg_next_next];
##? next if !$is_math_op{$type_next_next};
##? }
# next line must not be at greater depth
my $iend_next = $ri_last->[ $line + 1 ];
next
if ( $nesting_depth_to_go[ $iend_next + 1 ] >
$nesting_depth_to_go[$ipad] );
# lines must be somewhat similar to be padded..
my $inext_next = $inext_to_go[$ibeg_next];
my $type = $types_to_go[$ipad];
my $type_next = $types_to_go[ $ipad + 1 ];
# see if there are multiple continuation lines
my $logical_continuation_lines = 1;
if ( $line + 2 <= $max_line ) {
my $leading_token = $tokens_to_go[$ibeg_next];
my $ibeg_next_next = $ri_first->[ $line + 2 ];
if ( $tokens_to_go[$ibeg_next_next] eq $leading_token
&& $nesting_depth_to_go[$ibeg_next] eq
$nesting_depth_to_go[$ibeg_next_next] )
{
$logical_continuation_lines++;
}
}
# see if leading types match
my $types_match = $types_to_go[$inext_next] eq $type;
my $matches_without_bang;
# if first line has leading ! then compare the following token
if ( !$types_match && $type eq '!' ) {
$types_match = $matches_without_bang =
$types_to_go[$inext_next] eq $types_to_go[ $ipad + 1 ];
}
if (
# either we have multiple continuation lines to follow
# and we are not padding the first token
(
$logical_continuation_lines > 1
&& ( $ipad > 0 || $is_short_block )
)
# or..
|| (
# types must match
$types_match
# and keywords must match if keyword
&& !(
$type eq 'k'
&& $tokens_to_go[$ipad] ne $tokens_to_go[$inext_next]
)
)
)
{
#----------------------begin special checks--------------
#
# SPECIAL CHECK 1:
# A check is needed before we can make the pad.
# If we are in a list with some long items, we want each
# item to stand out. So in the following example, the
# first line beginning with '$casefold->' would look good
# padded to align with the next line, but then it
# would be indented more than the last line, so we
# won't do it.
#
# ok(
# $casefold->{code} eq '0041'
# && $casefold->{status} eq 'C'
# && $casefold->{mapping} eq '0061',
# 'casefold 0x41'
# );
#
# Note:
# It would be faster, and almost as good, to use a comma
# count, and not pad if comma_count > 1 and the previous
# line did not end with a comma.
#
my $ok_to_pad = 1;
my $ibg = $ri_first->[ $line + 1 ];
my $depth = $nesting_depth_to_go[ $ibg + 1 ];
# just use simplified formula for leading spaces to avoid
# needless sub calls
my $lsp = $levels_to_go[$ibg] + $ci_levels_to_go[$ibg];
# look at each line beyond the next ..
my $l = $line + 1;
foreach my $ltest ( $line + 2 .. $max_line ) {
$l = $ltest;
my $ibg = $ri_first->[$l];
# quit looking at the end of this container
last
if ( $nesting_depth_to_go[ $ibg + 1 ] < $depth )
|| ( $nesting_depth_to_go[$ibg] < $depth );
# cannot do the pad if a later line would be
# outdented more
if ( $levels_to_go[$ibg] + $ci_levels_to_go[$ibg] < $lsp ) {
$ok_to_pad = 0;
last;
}
}
# don't pad if we end in a broken list
if ( $l == $max_line ) {
my $i2 = $ri_last->[$l];
if ( $types_to_go[$i2] eq '#' ) {
my $i1 = $ri_first->[$l];
next if terminal_type_i( $i1, $i2 ) eq ',';
}
}
# SPECIAL CHECK 2:
# a minus may introduce a quoted variable, and we will
# add the pad only if this line begins with a bare word,
# such as for the word 'Button' here:
# [
# Button => "Print letter \"~$_\"",
# -command => [ sub { print "$_[0]\n" }, $_ ],
# -accelerator => "Meta+$_"
# ];
#
# On the other hand, if 'Button' is quoted, it looks best
# not to pad:
# [
# 'Button' => "Print letter \"~$_\"",
# -command => [ sub { print "$_[0]\n" }, $_ ],
# -accelerator => "Meta+$_"
# ];
if ( $types_to_go[$ibeg_next] eq 'm' ) {
$ok_to_pad = 0 if $types_to_go[$ibeg] eq 'Q';
}
next unless $ok_to_pad;
#----------------------end special check---------------
my $length_1 = total_line_length( $ibeg, $ipad - 1 );
my $length_2 = total_line_length( $ibeg_next, $inext_next - 1 );
$pad_spaces = $length_2 - $length_1;
# If the first line has a leading ! and the second does
# not, then remove one space to try to align the next
# leading characters, which are often the same. For example:
# if ( !$ts
# || $ts == $self->Holder
# || $self->Holder->Type eq "Arena" )
#
# This usually helps readability, but if there are subsequent
# ! operators things will still get messed up. For example:
#
# if ( !exists $Net::DNS::typesbyname{$qtype}
# && exists $Net::DNS::classesbyname{$qtype}
# && !exists $Net::DNS::classesbyname{$qclass}
# && exists $Net::DNS::typesbyname{$qclass} )
# We can't fix that.
if ($matches_without_bang) { $pad_spaces-- }
# make sure this won't change if -lp is used
my $indentation_1 = $leading_spaces_to_go[$ibeg];
if ( ref($indentation_1) ) {
if ( $indentation_1->get_recoverable_spaces() == 0 ) {
my $indentation_2 = $leading_spaces_to_go[$ibeg_next];
unless ( $indentation_2->get_recoverable_spaces() == 0 )
{
$pad_spaces = 0;
}
}
}
# we might be able to handle a pad of -1 by removing a blank
# token
if ( $pad_spaces < 0 ) {
# Deactivated for -kpit due to conflict. This block deletes
# a space in an attempt to improve alignment in some cases,
# but it may conflict with user spacing requests. For now
# it is just deactivated if the -kpit option is used.
if ( $pad_spaces == -1 ) {
if ( $ipad > $ibeg
&& $types_to_go[ $ipad - 1 ] eq 'b'
&& !%keyword_paren_inner_tightness )
{
$self->pad_token( $ipad - 1, $pad_spaces );
}
}
$pad_spaces = 0;
}
# now apply any padding for alignment
if ( $ipad >= 0 && $pad_spaces ) {
my $length_t = total_line_length( $ibeg, $iend );
if ( $pad_spaces + $length_t <=
$maximum_line_length_at_level[ $levels_to_go[$ibeg] ] )
{
$self->pad_token( $ipad, $pad_spaces );
}
}
}
}
continue {
$iendm = $iend;
$ibegm = $ibeg;
$has_leading_op = $has_leading_op_next;
} # end of loop over lines
return;
}
} ## end closure set_logical_padding
sub pad_token {
# insert $pad_spaces before token number $ipad
my ( $self, $ipad, $pad_spaces ) = @_;
my $rLL = $self->[_rLL_];
my $KK = $K_to_go[$ipad];
my $tok = $rLL->[$KK]->[_TOKEN_];
my $tok_len = $rLL->[$KK]->[_TOKEN_LENGTH_];
if ( $pad_spaces > 0 ) {
$tok = ' ' x $pad_spaces . $tok;
$tok_len += $pad_spaces;
}
elsif ( $pad_spaces == -1 && $tokens_to_go[$ipad] eq ' ' ) {
$tok = "";
$tok_len = 0;
}
else {
# shouldn't happen
return;
}
$tok = $rLL->[$KK]->[_TOKEN_] = $tok;
$tok_len = $rLL->[$KK]->[_TOKEN_LENGTH_] = $tok_len;
$token_lengths_to_go[$ipad] += $pad_spaces;
$tokens_to_go[$ipad] = $tok;
foreach my $i ( $ipad .. $max_index_to_go ) {
$summed_lengths_to_go[ $i + 1 ] += $pad_spaces;
}
return;
}
{ ## begin closure make_alignment_patterns
my %block_type_map;
my %keyword_map;
my %operator_map;
my %is_w_n_C;
BEGIN {
# map related block names into a common name to
# allow alignment
%block_type_map = (
'unless' => 'if',
'else' => 'if',
'elsif' => 'if',
'when' => 'if',
'default' => 'if',
'case' => 'if',
'sort' => 'map',
'grep' => 'map',
);
# map certain keywords to the same 'if' class to align
# long if/elsif sequences. [elsif.pl]
%keyword_map = (
'unless' => 'if',
'else' => 'if',
'elsif' => 'if',
'when' => 'given',
'default' => 'given',
'case' => 'switch',
# treat an 'undef' similar to numbers and quotes
'undef' => 'Q',
);
# map certain operators to the same class for pattern matching
%operator_map = (
'!~' => '=~',
'+=' => '+=',
'-=' => '+=',
'*=' => '+=',
'/=' => '+=',
);
%is_w_n_C = (
'w' => 1,
'n' => 1,
'C' => 1,
);
}
sub delete_needless_alignments {
my ( $self, $ibeg, $iend, $ralignment_type_to_go ) = @_;
# Remove unwanted alignments. This routine is a place to remove
# alignments which might cause problems at later stages. There are
# currently two types of fixes:
# 1. Remove excess parens
# 2. Remove alignments within 'elsif' conditions
# Patch #1: Excess alignment of parens can prevent other good
# alignments. For example, note the parens in the first two rows of
# the following snippet. They would normally get marked for alignment
# and aligned as follows:
# my $w = $columns * $cell_w + ( $columns + 1 ) * $border;
# my $h = $rows * $cell_h + ( $rows + 1 ) * $border;
# my $img = new Gimp::Image( $w, $h, RGB );
# This causes unnecessary paren alignment and prevents the third equals
# from aligning. If we remove the unwanted alignments we get:
# my $w = $columns * $cell_w + ( $columns + 1 ) * $border;
# my $h = $rows * $cell_h + ( $rows + 1 ) * $border;
# my $img = new Gimp::Image( $w, $h, RGB );
# A rule for doing this which works well is to remove alignment of
# parens whose containers do not contain other aligning tokens, with
# the exception that we always keep alignment of the first opening
# paren on a line (for things like 'if' and 'elsif' statements).
# Setup needed constants
my $i_good_paren = -1;
my $imin_match = $iend + 1;
my $i_elsif_close = $ibeg - 1;
my $i_elsif_open = $iend + 1;
if ( $iend > $ibeg ) {
if ( $types_to_go[$ibeg] eq 'k' ) {
# Paren patch: mark a location of a paren we should keep, such
# as one following something like a leading 'if', 'elsif',..
$i_good_paren = $ibeg + 1;
if ( $types_to_go[$i_good_paren] eq 'b' ) {
$i_good_paren++;
}
# 'elsif' patch: remember the range of the parens of an elsif,
# and do not make alignments within them because this can cause
# loss of padding and overall brace alignment in the vertical
# aligner.
if ( $tokens_to_go[$ibeg] eq 'elsif'
&& $i_good_paren < $iend
&& $tokens_to_go[$i_good_paren] eq '(' )
{
$i_elsif_open = $i_good_paren;
$i_elsif_close = $mate_index_to_go[$i_good_paren];
}
}
}
# Loop to make the fixes on this line
my @imatch_list;
for my $i ( $ibeg .. $iend ) {
if ( $ralignment_type_to_go->[$i] ) {
# Patch #2: undo alignment within elsif parens
if ( $i > $i_elsif_open && $i < $i_elsif_close ) {
$ralignment_type_to_go->[$i] = '';
next;
}
push @imatch_list, $i;
}
if ( $tokens_to_go[$i] eq ')' ) {
# Patch #1: undo the corresponding opening paren if:
# - it is at the top of the stack
# - and not the first overall opening paren
# - does not follow a leading keyword on this line
my $imate = $mate_index_to_go[$i];
if ( @imatch_list
&& $imatch_list[-1] eq $imate
&& ( $ibeg > 1 || @imatch_list > 1 )
&& $imate > $i_good_paren )
{
$ralignment_type_to_go->[$imate] = '';
pop @imatch_list;
}
}
}
return;
}
sub make_alignment_patterns {
# Here we do some important preliminary work for the
# vertical aligner. We create three arrays for one
# output line. These arrays contain strings that can
# be tested by the vertical aligner to see if
# consecutive lines can be aligned vertically.
#
# The three arrays are indexed on the vertical
# alignment fields and are:
# @tokens - a list of any vertical alignment tokens for this line.
# These are tokens, such as '=' '&&' '#' etc which
# we want to might align vertically. These are
# decorated with various information such as
# nesting depth to prevent unwanted vertical
# alignment matches.
# @fields - the actual text of the line between the vertical alignment
# tokens.
# @patterns - a modified list of token types, one for each alignment
# field. These should normally each match before alignment is
# allowed, even when the alignment tokens match.
my ( $self, $ibeg, $iend, $ralignment_type_to_go ) = @_;
my @tokens = ();
my @fields = ();
my @patterns = ();
my @field_lengths = ();
my $i_start = $ibeg;
# For a 'use' statement, use the module name as container name.
# Fixes issue rt136416.
my $cname = "";
if ( $types_to_go[$ibeg] eq 'k' && $tokens_to_go[$ibeg] eq 'use' ) {
my $inext = $inext_to_go[$ibeg];
if ( $inext <= $iend ) { $cname = $tokens_to_go[$inext] }
}
my $depth = 0;
my %container_name = ( 0 => "$cname" );
my $j = 0; # field index
$patterns[0] = "";
my %token_count;
for my $i ( $ibeg .. $iend ) {
# Keep track of containers balanced on this line only.
# These are used below to prevent unwanted cross-line alignments.
# Unbalanced containers already avoid aligning across
# container boundaries.
my $type = $types_to_go[$i];
my $token = $tokens_to_go[$i];
my $depth_last = $depth;
if ( $type_sequence_to_go[$i] ) {
if ( $is_opening_type{$token} ) {
# if container is balanced on this line...
my $i_mate = $mate_index_to_go[$i];
if ( $i_mate > $i && $i_mate <= $iend ) {
$depth++;
# Append the previous token name to make the container name
# more unique. This name will also be given to any commas
# within this container, and it helps avoid undesirable
# alignments of different types of containers.
# Containers beginning with { and [ are given those names
# for uniqueness. That way commas in different containers
# will not match. Here is an example of what this prevents:
# a => [ 1, 2, 3 ],
# b => { b1 => 4, b2 => 5 },
# Here is another example of what we avoid by labeling the
# commas properly:
# is_d( [ $a, $a ], [ $b, $c ] );
# is_d( { foo => $a, bar => $a }, { foo => $b, bar => $c } );
# is_d( [ \$a, \$a ], [ \$b, \$c ] );
my $name = $token;
if ( $token eq '(' ) {
$name = $self->make_paren_name($i);
}
$container_name{$depth} = "+" . $name;
# Make the container name even more unique if necessary.
# If we are not vertically aligning this opening paren,
# append a character count to avoid bad alignment because
# it usually looks bad to align commas within containers
# for which the opening parens do not align. Here
# is an example very BAD alignment of commas (because
# the atan2 functions are not all aligned):
# $XY =
# $X * $RTYSQP1 * atan2( $X, $RTYSQP1 ) +
# $Y * $RTXSQP1 * atan2( $Y, $RTXSQP1 ) -
# $X * atan2( $X, 1 ) -
# $Y * atan2( $Y, 1 );
#
# On the other hand, it is usually okay to align commas
# if opening parens align, such as:
# glVertex3d( $cx + $s * $xs, $cy, $z );
# glVertex3d( $cx, $cy + $s * $ys, $z );
# glVertex3d( $cx - $s * $xs, $cy, $z );
# glVertex3d( $cx, $cy - $s * $ys, $z );
#
# To distinguish between these situations, we will append
# the length of the line from the previous matching
# token, or beginning of line, to the function name.
# This will allow the vertical aligner to reject
# undesirable matches.
# if we are not aligning on this paren...
if ( !$ralignment_type_to_go->[$i] ) {
# Sum length from previous alignment
my $len = token_sequence_length( $i_start, $i - 1 );
# Minor patch: do not include the length of any '!'.
# Otherwise, commas in the following line will not
# match
# ok( 20, tapprox( ( pdl 2, 3 ), ( pdl 2, 3 ) ) );
# ok( 21, !tapprox( ( pdl 2, 3 ), ( pdl 2, 4 ) ) );
if ( grep { $_ eq '!' }
@types_to_go[ $i_start .. $i - 1 ] )
{
$len -= 1;
}
if ( $i_start == $ibeg ) {
# For first token, use distance from start of line
# but subtract off the indentation due to level.
# Otherwise, results could vary with indentation.
$len +=
leading_spaces_to_go($ibeg) -
$levels_to_go[$i_start] *
$rOpts_indent_columns;
if ( $len < 0 ) { $len = 0 }
}
# tack this length onto the container name to try
# to make a unique token name
$container_name{$depth} .= "-" . $len;
}
}
}
elsif ( $is_closing_type{$token} ) {
$depth-- if $depth > 0;
}
}
# if we find a new synchronization token, we are done with
# a field
if ( $i > $i_start && $ralignment_type_to_go->[$i] ) {
my $tok = my $raw_tok = $ralignment_type_to_go->[$i];
# map similar items
my $tok_map = $operator_map{$tok};
$tok = $tok_map if ($tok_map);
# make separators in different nesting depths unique
# by appending the nesting depth digit.
if ( $raw_tok ne '#' ) {
$tok .= "$nesting_depth_to_go[$i]";
}
# also decorate commas with any container name to avoid
# unwanted cross-line alignments.
if ( $raw_tok eq ',' || $raw_tok eq '=>' ) {
# If we are at an opening token which increased depth, we have
# to use the name from the previous depth.
my $depth_p =
( $depth_last < $depth ? $depth_last : $depth );
if ( $container_name{$depth_p} ) {
$tok .= $container_name{$depth_p};
}
}
# Patch to avoid aligning leading and trailing if, unless.
# Mark trailing if, unless statements with container names.
# This makes them different from leading if, unless which
# are not so marked at present. If we ever need to name
# them too, we could use ci to distinguish them.
# Example problem to avoid:
# return ( 2, "DBERROR" )
# if ( $retval == 2 );
# if ( scalar @_ ) {
# my ( $a, $b, $c, $d, $e, $f ) = @_;
# }
if ( $raw_tok eq '(' ) {
if ( $ci_levels_to_go[$ibeg]
&& $container_name{$depth} =~ /^\+(if|unless)/ )
{
$tok .= $container_name{$depth};
}
}
# Decorate block braces with block types to avoid
# unwanted alignments such as the following:
# foreach ( @{$routput_array} ) { $fh->print($_) }
# eval { $fh->close() };
if ( $raw_tok eq '{' && $block_type_to_go[$i] ) {
my $block_type = $block_type_to_go[$i];
# map certain related block types to allow
# else blocks to align
$block_type = $block_type_map{$block_type}
if ( defined( $block_type_map{$block_type} ) );
# remove sub names to allow one-line sub braces to align
# regardless of name
if ( $block_type =~ /$SUB_PATTERN/ ) { $block_type = 'sub' }
# allow all control-type blocks to align
if ( $block_type =~ /^[A-Z]+$/ ) { $block_type = 'BEGIN' }
$tok .= $block_type;
}
# Mark multiple copies of certain tokens with the copy number
# This will allow the aligner to decide if they are matched.
# For now, only do this for equals. For example, the two
# equals on the next line will be labeled '=0' and '=0.2'.
# Later, the '=0.2' will be ignored in alignment because it
# has no match.
# $| = $debug = 1 if $opt_d;
# $full_index = 1 if $opt_i;
if ( $raw_tok eq '=' || $raw_tok eq '=>' ) {
$token_count{$tok}++;
if ( $token_count{$tok} > 1 ) {
$tok .= '.' . $token_count{$tok};
}
}
# concatenate the text of the consecutive tokens to form
# the field
push( @fields,
join( '', @tokens_to_go[ $i_start .. $i - 1 ] ) );
push @field_lengths,
$summed_lengths_to_go[$i] - $summed_lengths_to_go[$i_start];
# store the alignment token for this field
push( @tokens, $tok );
# get ready for the next batch
$i_start = $i;
$j++;
$patterns[$j] = "";
}
# continue accumulating tokens
# for keywords we have to use the actual text
if ( $type eq 'k' ) {
my $tok_fix = $tokens_to_go[$i];
# but map certain keywords to a common string to allow
# alignment.
$tok_fix = $keyword_map{$tok_fix}
if ( defined( $keyword_map{$tok_fix} ) );
$patterns[$j] .= $tok_fix;
}
elsif ( $type eq 'b' ) {
$patterns[$j] .= $type;
}
# handle non-keywords..
else {
my $type_fix = $type;
# Mark most things before arrows as a quote to
# get them to line up. Testfile: mixed.pl.
# $type =~ /^[wnC]$/
if ( $i < $iend - 1 && $is_w_n_C{$type} ) {
my $next_type = $types_to_go[ $i + 1 ];
my $i_next_nonblank =
( ( $next_type eq 'b' ) ? $i + 2 : $i + 1 );
if ( $types_to_go[$i_next_nonblank] eq '=>' ) {
$type_fix = 'Q';
# Patch to ignore leading minus before words,
# by changing pattern 'mQ' into just 'Q',
# so that we can align things like this:
# Button => "Print letter \"~$_\"",
# -command => [ sub { print "$_[0]\n" }, $_ ],
if ( $patterns[$j] eq 'm' ) { $patterns[$j] = "" }
}
}
# Convert a bareword within braces into a quote for matching.
# This will allow alignment of expressions like this:
# local ( $SIG{'INT'} ) = IGNORE;
# local ( $SIG{ALRM} ) = 'POSTMAN';
if ( $type eq 'w'
&& $i > $ibeg
&& $i < $iend
&& $types_to_go[ $i - 1 ] eq 'L'
&& $types_to_go[ $i + 1 ] eq 'R' )
{
$type_fix = 'Q';
}
# patch to make numbers and quotes align
if ( $type eq 'n' ) { $type_fix = 'Q' }
# patch to ignore any ! in patterns
if ( $type eq '!' ) { $type_fix = '' }
$patterns[$j] .= $type_fix;
# remove any zero-level name at first fat comma
if ( $depth == 0 && $type eq '=>' ) {
$container_name{$depth} = "";
}
}
}
# done with this line .. join text of tokens to make the last field
push( @fields, join( '', @tokens_to_go[ $i_start .. $iend ] ) );
push @field_lengths,
$summed_lengths_to_go[ $iend + 1 ] - $summed_lengths_to_go[$i_start];
return ( \@tokens, \@fields, \@patterns, \@field_lengths );
}
} ## end closure make_alignment_patterns
sub make_paren_name {
my ( $self, $i ) = @_;
# The token at index $i is a '('.
# Create an alignment name for it to avoid incorrect alignments.
# Start with the name of the previous nonblank token...
my $name = "";
my $im = $i - 1;
return "" if ( $im < 0 );
if ( $types_to_go[$im] eq 'b' ) { $im--; }
return "" if ( $im < 0 );
$name = $tokens_to_go[$im];
# Prepend any sub name to an isolated -> to avoid unwanted alignments
# [test case is test8/penco.pl]
if ( $name eq '->' ) {
$im--;
if ( $im >= 0 && $types_to_go[$im] ne 'b' ) {
$name = $tokens_to_go[$im] . $name;
}
}
# Finally, remove any leading arrows
if ( substr( $name, 0, 2 ) eq '->' ) {
$name = substr( $name, 2 );
}
return $name;
}
{ ## begin closure set_adjusted_indentation
my ( $last_indentation_written, $last_unadjusted_indentation,
$last_leading_token );
sub initialize_adjusted_indentation {
$last_indentation_written = 0;
$last_unadjusted_indentation = 0;
$last_leading_token = "";
return;
}
sub set_adjusted_indentation {
# This routine has the final say regarding the actual indentation of
# a line. It starts with the basic indentation which has been
# defined for the leading token, and then takes into account any
# options that the user has set regarding special indenting and
# outdenting.
# This routine has to resolve a number of complex interacting issues,
# including:
# 1. The various -cti=n type flags, which contain the desired change in
# indentation for lines ending in commas and semicolons, should be
# followed,
# 2. qw quotes require special processing and do not fit perfectly
# with normal containers,
# 3. formatting with -wn can complicate things, especially with qw
# quotes,
# 4. formatting with the -lp option is complicated, and does not
# work well with qw quotes and with -wn formatting.
# 5. a number of special situations, such as 'cuddled' formatting.
# 6. This routine is mainly concerned with outdenting closing tokens
# but note that there is some overlap with the functions of sub
# undo_ci, which was processed earlier, so care has to be taken to
# keep them coordinated.
my (
$self, $ibeg,
$iend, $rfields,
$rpatterns, $ri_first,
$ri_last, $rindentation_list,
$level_jump, $starting_in_quote,
$is_static_block_comment,
) = @_;
my $rLL = $self->[_rLL_];
my $ris_bli_container = $self->[_ris_bli_container_];
my $rseqno_controlling_my_ci = $self->[_rseqno_controlling_my_ci_];
my $rwant_reduced_ci = $self->[_rwant_reduced_ci_];
my $rK_weld_left = $self->[_rK_weld_left_];
# we need to know the last token of this line
my ( $terminal_type, $i_terminal ) = terminal_type_i( $ibeg, $iend );
my $terminal_block_type = $block_type_to_go[$i_terminal];
my $is_outdented_line = 0;
my $terminal_is_in_list = $self->is_in_list_by_i($i_terminal);
my $type_beg = $types_to_go[$ibeg];
my $token_beg = $tokens_to_go[$ibeg];
my $K_beg = $K_to_go[$ibeg];
my $ibeg_weld_fix = $ibeg;
my $seqno_beg = $type_sequence_to_go[$ibeg];
my $is_bli_beg = $seqno_beg ? $ris_bli_container->{$seqno_beg} : 0;
# QW INDENTATION PATCH 3:
my $seqno_qw_closing;
if ( $type_beg eq 'q' && $ibeg == 0 ) {
my $KK = $K_to_go[$ibeg];
$seqno_qw_closing =
$self->[_rending_multiline_qw_seqno_by_K_]->{$KK};
}
my $is_semicolon_terminated = $terminal_type eq ';'
&& ( $nesting_depth_to_go[$iend] < $nesting_depth_to_go[$ibeg]
|| $seqno_qw_closing );
# NOTE: A future improvement would be to make it semicolon terminated
# even if it does not have a semicolon but is followed by a closing
# block brace. This would undo ci even for something like the
# following, in which the final paren does not have a semicolon because
# it is a possible weld location:
# if ($BOLD_MATH) {
# (
# $labels, $comment,
# join( '', '', &make_math( $mode, '', '', $_ ), '' )
# )
# }
#
# MOJO: Set a flag if this lines begins with ')->'
my $leading_paren_arrow = (
$types_to_go[$ibeg] eq '}'
&& $tokens_to_go[$ibeg] eq ')'
&& (
( $ibeg < $i_terminal && $types_to_go[ $ibeg + 1 ] eq '->' )
|| ( $ibeg < $i_terminal - 1
&& $types_to_go[ $ibeg + 1 ] eq 'b'
&& $types_to_go[ $ibeg + 2 ] eq '->' )
)
);
##########################################################
# Section 1: set a flag and a default indentation
#
# Most lines are indented according to the initial token.
# But it is common to outdent to the level just after the
# terminal token in certain cases...
# adjust_indentation flag:
# 0 - do not adjust
# 1 - outdent
# 2 - vertically align with opening token
# 3 - indent
##########################################################
my $adjust_indentation = 0;
my $default_adjust_indentation = $adjust_indentation;
my (
$opening_indentation, $opening_offset,
$is_leading, $opening_exists
);
# Honor any flag to reduce -ci set by the -bbxi=n option
if ( $seqno_beg && $rwant_reduced_ci->{$seqno_beg} ) {
# if this is an opening, it must be alone on the line ...
if ( $is_closing_type{$type_beg} || $ibeg == $i_terminal ) {
$adjust_indentation = 1;
}
# ... or a single welded unit (fix for b1173)
elsif ($total_weld_count) {
my $Kterm = $K_to_go[$i_terminal];
my $Kterm_test = $rK_weld_left->{$Kterm};
if ( defined($Kterm_test) && $Kterm_test >= $K_beg ) {
$Kterm = $Kterm_test;
}
if ( $Kterm == $K_beg ) { $adjust_indentation = 1 }
}
}
# Update the $is_bli flag as we go. It is initially 1.
# We note seeing a leading opening brace by setting it to 2.
# If we get to the closing brace without seeing the opening then we
# turn it off. This occurs if the opening brace did not get output
# at the start of a line, so we will then indent the closing brace
# in the default way.
if ( $is_bli_beg && $is_bli_beg == 1 ) {
my $K_opening_container = $self->[_K_opening_container_];
my $K_opening = $K_opening_container->{$seqno_beg};
if ( $K_beg eq $K_opening ) {
$ris_bli_container->{$seqno_beg} = $is_bli_beg = 2;
}
else { $is_bli_beg = 0 }
}
# QW PATCH for the combination -lp -wn
# For -lp formatting use $ibeg_weld_fix to get around the problem
# that with -lp type formatting the opening and closing tokens to not
# have sequence numbers.
if ( $seqno_qw_closing && $total_weld_count ) {
my $K_next_nonblank = $self->K_next_code($K_beg);
if ( defined($K_next_nonblank)
&& defined( $rK_weld_left->{$K_next_nonblank} ) )
{
my $itest = $ibeg + ( $K_next_nonblank - $K_beg );
if ( $itest <= $max_index_to_go ) {
$ibeg_weld_fix = $itest;
}
}
}
# if we are at a closing token of some type..
if ( $is_closing_type{$type_beg} || $seqno_qw_closing ) {
# get the indentation of the line containing the corresponding
# opening token
(
$opening_indentation, $opening_offset,
$is_leading, $opening_exists
)
= $self->get_opening_indentation( $ibeg_weld_fix, $ri_first,
$ri_last, $rindentation_list, $seqno_qw_closing );
# First set the default behavior:
if (
# default behavior is to outdent closing lines
# of the form: "); }; ]; )->xxx;"
$is_semicolon_terminated
# and 'cuddled parens' of the form: ")->pack("
# Bug fix for RT #123749]: the types here were
# incorrectly '(' and ')'. Corrected to be '{' and '}'
|| (
$terminal_type eq '{'
&& $type_beg eq '}'
&& ( $nesting_depth_to_go[$iend] + 1 ==
$nesting_depth_to_go[$ibeg] )
)
# remove continuation indentation for any line like
# } ... {
# or without ending '{' and unbalanced, such as
# such as '}->{$operator}'
|| (
$type_beg eq '}'
&& ( $types_to_go[$iend] eq '{'
|| $levels_to_go[$iend] < $levels_to_go[$ibeg] )
)
# and when the next line is at a lower indentation level...
# PATCH #1: and only if the style allows undoing continuation
# for all closing token types. We should really wait until
# the indentation of the next line is known and then make
# a decision, but that would require another pass.
# PATCH #2: and not if this token is under -xci control
|| ( $level_jump < 0
&& !$some_closing_token_indentation
&& !$rseqno_controlling_my_ci->{$K_beg} )
# Patch for -wn=2, multiple welded closing tokens
|| ( $i_terminal > $ibeg
&& $is_closing_type{ $types_to_go[$iend] } )
# Alternate Patch for git #51, isolated closing qw token not
# outdented if no-delete-old-newlines is set. This works, but
# a more general patch elsewhere fixes the real problem: ljump.
# || ( $seqno_qw_closing && $ibeg == $i_terminal )
)
{
$adjust_indentation = 1;
}
# outdent something like '),'
if (
$terminal_type eq ','
# Removed this constraint for -wn
# OLD: allow just one character before the comma
# && $i_terminal == $ibeg + 1
# require LIST environment; otherwise, we may outdent too much -
# this can happen in calls without parentheses (overload.t);
&& $terminal_is_in_list
)
{
$adjust_indentation = 1;
}
# undo continuation indentation of a terminal closing token if
# it is the last token before a level decrease. This will allow
# a closing token to line up with its opening counterpart, and
# avoids an indentation jump larger than 1 level.
if ( $types_to_go[$i_terminal] =~ /^[\}\]\)R]$/
&& $i_terminal == $ibeg
&& defined($K_beg) )
{
my $K_next_nonblank = $self->K_next_code($K_beg);
if ( !$is_bli_beg && defined($K_next_nonblank) ) {
my $lev = $rLL->[$K_beg]->[_LEVEL_];
my $level_next = $rLL->[$K_next_nonblank]->[_LEVEL_];
# and do not undo ci if it was set by the -xci option
$adjust_indentation = 1
if ( $level_next < $lev
&& !$rseqno_controlling_my_ci->{$K_beg} );
}
# Patch for RT #96101, in which closing brace of anonymous subs
# was not outdented. We should look ahead and see if there is
# a level decrease at the next token (i.e., a closing token),
# but right now we do not have that information. For now
# we see if we are in a list, and this works well.
# See test files 'sub*.t' for good test cases.
if ( $block_type_to_go[$ibeg] =~ /$ASUB_PATTERN/
&& $terminal_is_in_list
&& !$rOpts->{'indent-closing-brace'} )
{
(
$opening_indentation, $opening_offset,
$is_leading, $opening_exists
)
= $self->get_opening_indentation( $ibeg, $ri_first,
$ri_last, $rindentation_list );
my $indentation = $leading_spaces_to_go[$ibeg];
if ( defined($opening_indentation)
&& get_spaces($indentation) >
get_spaces($opening_indentation) )
{
$adjust_indentation = 1;
}
}
}
# YVES patch 1 of 2:
# Undo ci of line with leading closing eval brace,
# but not beyond the indention of the line with
# the opening brace.
if ( $block_type_to_go[$ibeg] eq 'eval'
&& !$rOpts->{'line-up-parentheses'}
&& !$rOpts->{'indent-closing-brace'} )
{
(
$opening_indentation, $opening_offset,
$is_leading, $opening_exists
)
= $self->get_opening_indentation( $ibeg, $ri_first, $ri_last,
$rindentation_list );
my $indentation = $leading_spaces_to_go[$ibeg];
if ( defined($opening_indentation)
&& get_spaces($indentation) >
get_spaces($opening_indentation) )
{
$adjust_indentation = 1;
}
}
# patch for issue git #40: -bli setting has priority
$adjust_indentation = 0 if ($is_bli_beg);
$default_adjust_indentation = $adjust_indentation;
# Now modify default behavior according to user request:
# handle option to indent non-blocks of the form ); }; ];
# But don't do special indentation to something like ')->pack('
if ( !$block_type_to_go[$ibeg] ) {
# Note that logical padding has already been applied, so we may
# need to remove some spaces to get a valid hash key.
my $tok = $tokens_to_go[$ibeg];
my $cti = $closing_token_indentation{$tok};
# Fix the value of 'cti' for an isloated non-welded closing qw
# delimiter.
if ( $seqno_qw_closing && $ibeg_weld_fix == $ibeg ) {
# A quote delimiter which is not a container will not have
# a cti value defined. In this case use the style of a
# paren. For example
# my @fars = (
# qw<
# far
# farfar
# farfars-far
# >,
# );
if ( !defined($cti) && length($tok) == 1 ) {
# something other than ')', '}', ']' ; use flag for ')'
$cti = $closing_token_indentation{')'};
# But for now, do not outdent non-container qw
# delimiters because it would would change existing
# formatting.
if ( $tok ne '>' ) { $cti = 3 }
}
# A non-welded closing qw cannot currently use -cti=1
# because that option requires a sequence number to find
# the opening indentation, and qw quote delimiters are not
# sequenced items.
if ( defined($cti) && $cti == 1 ) { $cti = 0 }
}
if ( !defined($cti) ) {
# $cti may not be defined for several reasons.
# -padding may have been applied so the character
# has a length > 1
# - we may have welded to a closing quote token.
# Here is an example (perltidy -wn):
# __PACKAGE__->load_components( qw(
# > Core
# >
# > ) );
$adjust_indentation = 0;
}
elsif ( $cti == 1 ) {
if ( $i_terminal <= $ibeg + 1
|| $is_semicolon_terminated )
{
$adjust_indentation = 2;
}
else {
$adjust_indentation = 0;
}
}
elsif ( $cti == 2 ) {
if ($is_semicolon_terminated) {
$adjust_indentation = 3;
}
else {
$adjust_indentation = 0;
}
}
elsif ( $cti == 3 ) {
$adjust_indentation = 3;
}
}
# handle option to indent blocks
else {
if (
$rOpts->{'indent-closing-brace'}
&& (
$i_terminal == $ibeg # isolated terminal '}'
|| $is_semicolon_terminated
)
) # } xxxx ;
{
$adjust_indentation = 3;
}
}
}
# if at ');', '};', '>;', and '];' of a terminal qw quote
elsif ($rpatterns->[0] =~ /^qb*;$/
&& $rfields->[0] =~ /^([\)\}\]\>]);$/ )
{
if ( $closing_token_indentation{$1} == 0 ) {
$adjust_indentation = 1;
}
else {
$adjust_indentation = 3;
}
}
# if line begins with a ':', align it with any
# previous line leading with corresponding ?
elsif ( $types_to_go[$ibeg] eq ':' ) {
(
$opening_indentation, $opening_offset,
$is_leading, $opening_exists
)
= $self->get_opening_indentation( $ibeg, $ri_first, $ri_last,
$rindentation_list );
if ($is_leading) { $adjust_indentation = 2; }
}
##########################################################
# Section 2: set indentation according to flag set above
#
# Select the indentation object to define leading
# whitespace. If we are outdenting something like '} } );'
# then we want to use one level below the last token
# ($i_terminal) in order to get it to fully outdent through
# all levels.
##########################################################
my $indentation;
my $lev;
my $level_end = $levels_to_go[$iend];
if ( $adjust_indentation == 0 ) {
$indentation = $leading_spaces_to_go[$ibeg];
$lev = $levels_to_go[$ibeg];
}
elsif ( $adjust_indentation == 1 ) {
# Change the indentation to be that of a different token on the line
# Previously, the indentation of the terminal token was used:
# OLD CODING:
# $indentation = $reduced_spaces_to_go[$i_terminal];
# $lev = $levels_to_go[$i_terminal];
# Generalization for MOJO:
# Use the lowest level indentation of the tokens on the line.
# For example, here we can use the indentation of the ending ';':
# } until ($selection > 0 and $selection < 10); # ok to use ';'
# But this will not outdent if we use the terminal indentation:
# )->then( sub { # use indentation of the ->, not the {
# Warning: reduced_spaces_to_go[] may be a reference, do not
# do numerical checks with it
my $i_ind = $ibeg;
$indentation = $reduced_spaces_to_go[$i_ind];
$lev = $levels_to_go[$i_ind];
while ( $i_ind < $i_terminal ) {
$i_ind++;
if ( $levels_to_go[$i_ind] < $lev ) {
$indentation = $reduced_spaces_to_go[$i_ind];
$lev = $levels_to_go[$i_ind];
}
}
}
# handle indented closing token which aligns with opening token
elsif ( $adjust_indentation == 2 ) {
# handle option to align closing token with opening token
$lev = $levels_to_go[$ibeg];
# calculate spaces needed to align with opening token
my $space_count =
get_spaces($opening_indentation) + $opening_offset;
# Indent less than the previous line.
#
# Problem: For -lp we don't exactly know what it was if there
# were recoverable spaces sent to the aligner. A good solution
# would be to force a flush of the vertical alignment buffer, so
# that we would know. For now, this rule is used for -lp:
#
# When the last line did not start with a closing token we will
# be optimistic that the aligner will recover everything wanted.
#
# This rule will prevent us from breaking a hierarchy of closing
# tokens, and in a worst case will leave a closing paren too far
# indented, but this is better than frequently leaving it not
# indented enough.
my $last_spaces = get_spaces($last_indentation_written);
if ( !$is_closing_token{$last_leading_token} ) {
$last_spaces +=
get_recoverable_spaces($last_indentation_written);
}
# reset the indentation to the new space count if it works
# only options are all or none: nothing in-between looks good
$lev = $levels_to_go[$ibeg];
if ( $space_count < $last_spaces ) {
if ($rOpts_line_up_parentheses) {
my $lev = $levels_to_go[$ibeg];
$indentation =
new_lp_indentation_item( $space_count, $lev, 0, 0, 0 );
}
else {
$indentation = $space_count;
}
}
# revert to default if it doesn't work
else {
$space_count = leading_spaces_to_go($ibeg);
if ( $default_adjust_indentation == 0 ) {
$indentation = $leading_spaces_to_go[$ibeg];
}
elsif ( $default_adjust_indentation == 1 ) {
$indentation = $reduced_spaces_to_go[$i_terminal];
$lev = $levels_to_go[$i_terminal];
}
}
}
# Full indentaion of closing tokens (-icb and -icp or -cti=2)
else {
# handle -icb (indented closing code block braces)
# Updated method for indented block braces: indent one full level if
# there is no continuation indentation. This will occur for major
# structures such as sub, if, else, but not for things like map
# blocks.
#
# Note: only code blocks without continuation indentation are
# handled here (if, else, unless, ..). In the following snippet,
# the terminal brace of the sort block will have continuation
# indentation as shown so it will not be handled by the coding
# here. We would have to undo the continuation indentation to do
# this, but it probably looks ok as is. This is a possible future
# update for semicolon terminated lines.
#
# if ($sortby eq 'date' or $sortby eq 'size') {
# @files = sort {
# $file_data{$a}{$sortby} <=> $file_data{$b}{$sortby}
# or $a cmp $b
# } @files;
# }
#
if ( $block_type_to_go[$ibeg]
&& $ci_levels_to_go[$i_terminal] == 0 )
{
my $spaces = get_spaces( $leading_spaces_to_go[$i_terminal] );
$indentation = $spaces + $rOpts_indent_columns;
# NOTE: for -lp we could create a new indentation object, but
# there is probably no need to do it
}
# handle -icp and any -icb block braces which fall through above
# test such as the 'sort' block mentioned above.
else {
# There are currently two ways to handle -icp...
# One way is to use the indentation of the previous line:
# $indentation = $last_indentation_written;
# The other way is to use the indentation that the previous line
# would have had if it hadn't been adjusted:
$indentation = $last_unadjusted_indentation;
# Current method: use the minimum of the two. This avoids
# inconsistent indentation.
if ( get_spaces($last_indentation_written) <
get_spaces($indentation) )
{
$indentation = $last_indentation_written;
}
}
# use previous indentation but use own level
# to cause list to be flushed properly
$lev = $levels_to_go[$ibeg];
}
# remember indentation except for multi-line quotes, which get
# no indentation
unless ( $ibeg == 0 && $starting_in_quote ) {
$last_indentation_written = $indentation;
$last_unadjusted_indentation = $leading_spaces_to_go[$ibeg];
$last_leading_token = $tokens_to_go[$ibeg];
# Patch to make a line which is the end of a qw quote work with the
# -lp option. Make $token_beg look like a closing token as some
# type even if it is not. This veriable will become
# $last_leading_token at the end of this loop. Then, if the -lp
# style is selected, and the next line is also a
# closing token, it will not get more indentation than this line.
# We need to do this because qw quotes (at present) only get
# continuation indentation, not one level of indentation, so we
# need to turn off the -lp indentation.
# ... a picture is worth a thousand words:
# perltidy -wn -gnu (Without this patch):
# ok(defined(
# $seqio = $gb->get_Stream_by_batch([qw(J00522 AF303112
# 2981014)])
# ));
# perltidy -wn -gnu (With this patch):
# ok(defined(
# $seqio = $gb->get_Stream_by_batch([qw(J00522 AF303112
# 2981014)])
# ));
## if ($seqno_qw_closing) { $last_leading_token = ')' }
if ( $seqno_qw_closing
&& ( length($token_beg) > 1 || $token_beg eq '>' ) )
{
$last_leading_token = ')';
}
}
# be sure lines with leading closing tokens are not outdented more
# than the line which contained the corresponding opening token.
#############################################################
# updated per bug report in alex_bug.pl: we must not
# mess with the indentation of closing logical braces so
# we must treat something like '} else {' as if it were
# an isolated brace
#############################################################
my $is_isolated_block_brace = $block_type_to_go[$ibeg]
&& (
$i_terminal == $ibeg
|| $is_if_elsif_else_unless_while_until_for_foreach{
$block_type_to_go[$ibeg]
}
);
# only do this for a ':; which is aligned with its leading '?'
my $is_unaligned_colon = $types_to_go[$ibeg] eq ':' && !$is_leading;
if (
defined($opening_indentation)
&& !$leading_paren_arrow # MOJO
&& !$is_isolated_block_brace
&& !$is_unaligned_colon
)
{
if ( get_spaces($opening_indentation) > get_spaces($indentation) ) {
$indentation = $opening_indentation;
}
}
# remember the indentation of each line of this batch
push @{$rindentation_list}, $indentation;
# outdent lines with certain leading tokens...
if (
# must be first word of this batch
$ibeg == 0
# and ...
&& (
# certain leading keywords if requested
(
$rOpts->{'outdent-keywords'}
&& $types_to_go[$ibeg] eq 'k'
&& $outdent_keyword{ $tokens_to_go[$ibeg] }
)
# or labels if requested
|| ( $rOpts->{'outdent-labels'} && $types_to_go[$ibeg] eq 'J' )
# or static block comments if requested
|| ( $types_to_go[$ibeg] eq '#'
&& $rOpts->{'outdent-static-block-comments'}
&& $is_static_block_comment )
)
)
{
my $space_count = leading_spaces_to_go($ibeg);
if ( $space_count > 0 ) {
$space_count -= $rOpts_continuation_indentation;
$is_outdented_line = 1;
if ( $space_count < 0 ) { $space_count = 0 }
# do not promote a spaced static block comment to non-spaced;
# this is not normally necessary but could be for some
# unusual user inputs (such as -ci = -i)
if ( $types_to_go[$ibeg] eq '#' && $space_count == 0 ) {
$space_count = 1;
}
if ($rOpts_line_up_parentheses) {
$indentation =
new_lp_indentation_item( $space_count, $lev, 0, 0, 0 );
}
else {
$indentation = $space_count;
}
}
}
return ( $indentation, $lev, $level_end, $terminal_type,
$terminal_block_type, $is_semicolon_terminated,
$is_outdented_line );
}
} ## end closure set_adjusted_indentation
sub get_opening_indentation {
# get the indentation of the line which output the opening token
# corresponding to a given closing token in the current output batch.
#
# given:
# $i_closing - index in this line of a closing token ')' '}' or ']'
#
# $ri_first - reference to list of the first index $i for each output
# line in this batch
# $ri_last - reference to list of the last index $i for each output line
# in this batch
# $rindentation_list - reference to a list containing the indentation
# used for each line.
# $qw_seqno - optional sequence number to use if normal seqno not defined
# (TODO: would be more general to just look this up from index i)
#
# return:
# -the indentation of the line which contained the opening token
# which matches the token at index $i_opening
# -and its offset (number of columns) from the start of the line
#
my ( $self, $i_closing, $ri_first, $ri_last, $rindentation_list, $qw_seqno )
= @_;
# first, see if the opening token is in the current batch
my $i_opening = $mate_index_to_go[$i_closing];
my ( $indent, $offset, $is_leading, $exists );
$exists = 1;
if ( defined($i_opening) && $i_opening >= 0 ) {
# it is..look up the indentation
( $indent, $offset, $is_leading ) =
lookup_opening_indentation( $i_opening, $ri_first, $ri_last,
$rindentation_list );
}
# if not, it should have been stored in the hash by a previous batch
else {
my $seqno = $type_sequence_to_go[$i_closing];
$seqno = $qw_seqno unless ($seqno);
( $indent, $offset, $is_leading, $exists ) =
get_saved_opening_indentation($seqno);
}
return ( $indent, $offset, $is_leading, $exists );
}
sub set_vertical_tightness_flags {
my ( $self, $n, $n_last_line, $ibeg, $iend, $ri_first, $ri_last,
$ending_in_quote, $closing_side_comment )
= @_;
# Define vertical tightness controls for the nth line of a batch.
# We create an array of parameters which tell the vertical aligner
# if we should combine this line with the next line to achieve the
# desired vertical tightness. The array of parameters contains:
#
# [0] type: 1=opening non-block 2=closing non-block
# 3=opening block brace 4=closing block brace
#
# [1] flag: if opening: 1=no multiple steps, 2=multiple steps ok
# if closing: spaces of padding to use
# [2] sequence number of container
# [3] valid flag: do not append if this flag is false. Will be
# true if appropriate -vt flag is set. Otherwise, Will be
# made true only for 2 line container in parens with -lp
#
# These flags are used by sub set_leading_whitespace in
# the vertical aligner
my $rvertical_tightness_flags = [ 0, 0, 0, 0, 0, 0 ];
# The vertical tightness mechanism can add whitespace, so whitespace can
# continually increase if we allowed it when the -fws flag is set.
# See case b499 for an example.
return $rvertical_tightness_flags if ($rOpts_freeze_whitespace);
# Uses these parameters:
# $rOpts_block_brace_tightness
# $rOpts_block_brace_vertical_tightness
# $rOpts_stack_closing_block_brace
# %opening_vertical_tightness
# %closing_vertical_tightness
# %opening_token_right
# %stack_closing_token
# %stack_opening_token
#--------------------------------------------------------------
# Vertical Tightness Flags Section 1:
# Handle Lines 1 .. n-1 but not the last line
# For non-BLOCK tokens, we will need to examine the next line
# too, so we won't consider the last line.
#--------------------------------------------------------------
if ( $n < $n_last_line ) {
#--------------------------------------------------------------
# Vertical Tightness Flags Section 1a:
# Look for Type 1, last token of this line is a non-block opening token
#--------------------------------------------------------------
my $ibeg_next = $ri_first->[ $n + 1 ];
my $token_end = $tokens_to_go[$iend];
my $iend_next = $ri_last->[ $n + 1 ];
if (
$type_sequence_to_go[$iend]
&& !$block_type_to_go[$iend]
&& $is_opening_token{$token_end}
&& (
$opening_vertical_tightness{$token_end} > 0
# allow 2-line method call to be closed up
|| ( $rOpts_line_up_parentheses
&& $token_end eq '('
&& $iend > $ibeg
&& $types_to_go[ $iend - 1 ] ne 'b' )
)
)
{
# avoid multiple jumps in nesting depth in one line if
# requested
my $ovt = $opening_vertical_tightness{$token_end};
my $iend_next = $ri_last->[ $n + 1 ];
unless (
$ovt < 2
&& ( $nesting_depth_to_go[ $iend_next + 1 ] !=
$nesting_depth_to_go[$ibeg_next] )
)
{
# If -vt flag has not been set, mark this as invalid
# and aligner will validate it if it sees the closing paren
# within 2 lines.
my $valid_flag = $ovt;
@{$rvertical_tightness_flags} =
( 1, $ovt, $type_sequence_to_go[$iend], $valid_flag );
}
}
#--------------------------------------------------------------
# Vertical Tightness Flags Section 1b:
# Look for Type 2, first token of next line is a non-block closing
# token .. and be sure this line does not have a side comment
#--------------------------------------------------------------
my $token_next = $tokens_to_go[$ibeg_next];
if ( $type_sequence_to_go[$ibeg_next]
&& !$block_type_to_go[$ibeg_next]
&& $is_closing_token{$token_next}
&& $types_to_go[$iend] ne '#' ) # for safety, shouldn't happen!
{
my $ovt = $opening_vertical_tightness{$token_next};
my $cvt = $closing_vertical_tightness{$token_next};
# Implement cvt=3: like cvt=0 for assigned structures, like cvt=1
# otherwise. Added for rt136417.
if ( $cvt == 3 ) {
my $seqno = $type_sequence_to_go[$ibeg_next];
$cvt = $self->[_ris_assigned_structure_]->{$seqno} ? 0 : 1;
}
if (
# Never append a trailing line like ')->pack(' because it
# will throw off later alignment. So this line must start at a
# deeper level than the next line (fix1 for welding, git #45).
(
$nesting_depth_to_go[$ibeg_next] >=
$nesting_depth_to_go[ $iend_next + 1 ] + 1
)
&& (
$cvt == 2
|| (
!$self->is_in_list_by_i($ibeg_next)
&& (
$cvt == 1
# allow closing up 2-line method calls
|| ( $rOpts_line_up_parentheses
&& $token_next eq ')' )
)
)
)
)
{
# decide which trailing closing tokens to append..
my $ok = 0;
if ( $cvt == 2 || $iend_next == $ibeg_next ) { $ok = 1 }
else {
my $str = join( '',
@types_to_go[ $ibeg_next + 1 .. $ibeg_next + 2 ] );
# append closing token if followed by comment or ';'
# or another closing token (fix2 for welding, git #45)
if ( $str =~ /^b?[\)\]\}R#;]/ ) { $ok = 1 }
}
if ($ok) {
my $valid_flag = $cvt;
@{$rvertical_tightness_flags} = (
2,
$tightness{$token_next} == 2 ? 0 : 1,
$type_sequence_to_go[$ibeg_next], $valid_flag,
);
}
}
}
#--------------------------------------------------------------
# Vertical Tightness Flags Section 1c:
# Implement the Opening Token Right flag (Type 2)..
# If requested, move an isolated trailing opening token to the end of
# the previous line which ended in a comma. We could do this
# in sub recombine_breakpoints but that would cause problems
# with -lp formatting. The problem is that indentation will
# quickly move far to the right in nested expressions. By
# doing it after indentation has been set, we avoid changes
# to the indentation. Actual movement of the token takes place
# in sub valign_output_step_B.
# Note added 4 May 2021: the man page suggests that the -otr flags
# are mainly for opening tokens following commas. But this seems
# to have been generalized long ago to include other situations.
# I checked the coding back to 2012 and it is essentially the same
# as here, so it is best to leave this unchanged for now.
#--------------------------------------------------------------
if (
$opening_token_right{ $tokens_to_go[$ibeg_next] }
# previous line is not opening
# (use -sot to combine with it)
&& !$is_opening_token{$token_end}
# previous line ended in one of these
# (add other cases if necessary; '=>' and '.' are not necessary
&& !$block_type_to_go[$ibeg_next]
# this is a line with just an opening token
&& ( $iend_next == $ibeg_next
|| $iend_next == $ibeg_next + 2
&& $types_to_go[$iend_next] eq '#' )
# Fix for case b1060 when both -baoo and -otr are set:
# to avoid blinking, honor the -baoo flag over the -otr flag.
&& $token_end ne '||' && $token_end ne '&&'
# Keep break after '=' if -lp. Fixes b964 b1040 b1062 b1083 b1089.
&& !( $token_end eq '=' && $rOpts_line_up_parentheses )
# looks bad if we align vertically with the wrong container
&& $tokens_to_go[$ibeg] ne $tokens_to_go[$ibeg_next]
)
{
my $valid_flag = 1;
my $spaces = ( $types_to_go[ $ibeg_next - 1 ] eq 'b' ) ? 1 : 0;
@{$rvertical_tightness_flags} =
( 2, $spaces, $type_sequence_to_go[$ibeg_next], $valid_flag, );
}
#--------------------------------------------------------------
# Vertical Tightness Flags Section 1d:
# Stacking of opening and closing tokens (Type 2)
#--------------------------------------------------------------
my $stackable;
my $token_beg_next = $tokens_to_go[$ibeg_next];
# patch to make something like 'qw(' behave like an opening paren
# (aran.t)
if ( $types_to_go[$ibeg_next] eq 'q' ) {
if ( $token_beg_next =~ /^qw\s*([\[\(\{])$/ ) {
$token_beg_next = $1;
}
}
if ( $is_closing_token{$token_end}
&& $is_closing_token{$token_beg_next} )
{
$stackable = $stack_closing_token{$token_beg_next}
unless ( $block_type_to_go[$ibeg_next] )
; # shouldn't happen; just checking
}
elsif ($is_opening_token{$token_end}
&& $is_opening_token{$token_beg_next} )
{
$stackable = $stack_opening_token{$token_beg_next}
unless ( $block_type_to_go[$ibeg_next] )
; # shouldn't happen; just checking
}
if ($stackable) {
my $is_semicolon_terminated;
if ( $n + 1 == $n_last_line ) {
my ( $terminal_type, $i_terminal ) =
terminal_type_i( $ibeg_next, $iend_next );
$is_semicolon_terminated = $terminal_type eq ';'
&& $nesting_depth_to_go[$iend_next] <
$nesting_depth_to_go[$ibeg_next];
}
# this must be a line with just an opening token
# or end in a semicolon
if (
$is_semicolon_terminated
|| ( $iend_next == $ibeg_next
|| $iend_next == $ibeg_next + 2
&& $types_to_go[$iend_next] eq '#' )
)
{
my $valid_flag = 1;
my $spaces = ( $types_to_go[ $ibeg_next - 1 ] eq 'b' ) ? 1 : 0;
@{$rvertical_tightness_flags} = (
2, $spaces, $type_sequence_to_go[$ibeg_next], $valid_flag,
);
}
}
}
#--------------------------------------------------------------
# Vertical Tightness Flags Section 2:
# Handle type 3, opening block braces on last line of the batch
# Check for a last line with isolated opening BLOCK curly
#--------------------------------------------------------------
elsif ($rOpts_block_brace_vertical_tightness
&& $ibeg eq $iend
&& $types_to_go[$iend] eq '{'
&& $block_type_to_go[$iend] =~
/$block_brace_vertical_tightness_pattern/ )
{
@{$rvertical_tightness_flags} =
( 3, $rOpts_block_brace_vertical_tightness, 0, 1 );
}
#--------------------------------------------------------------
# Vertical Tightness Flags Section 3:
# Handle type 4, a closing block brace on the last line of the batch Check
# for a last line with isolated closing BLOCK curly
# Patch: added a check for any new closing side comment which the
# -csc option may generate. If it exists, there will be a side comment
# so we cannot combine with a brace on the next line. This issue
# occurs for the combination -scbb and -csc is used.
#--------------------------------------------------------------
elsif ($rOpts_stack_closing_block_brace
&& $ibeg eq $iend
&& $block_type_to_go[$iend]
&& $types_to_go[$iend] eq '}'
&& ( !$closing_side_comment || $n < $n_last_line ) )
{
my $spaces = $rOpts_block_brace_tightness == 2 ? 0 : 1;
@{$rvertical_tightness_flags} =
( 4, $spaces, $type_sequence_to_go[$iend], 1 );
}
# pack in the sequence numbers of the ends of this line
my $seqno_beg = $type_sequence_to_go[$ibeg];
if ( !$seqno_beg && $types_to_go[$ibeg] eq 'q' ) {
$seqno_beg = $self->get_seqno( $ibeg, $ending_in_quote );
}
my $seqno_end = $type_sequence_to_go[$iend];
if ( !$seqno_end && $types_to_go[$iend] eq 'q' ) {
$seqno_end = $self->get_seqno( $iend, $ending_in_quote );
}
$rvertical_tightness_flags->[4] = $seqno_beg;
$rvertical_tightness_flags->[5] = $seqno_end;
return $rvertical_tightness_flags;
}
##########################################################
# CODE SECTION 14: Code for creating closing side comments
##########################################################
{ ## begin closure accumulate_csc_text
# These routines are called once per batch when the --closing-side-comments flag
# has been set.
my %block_leading_text;
my %block_opening_line_number;
my $csc_new_statement_ok;
my $csc_last_label;
my %csc_block_label;
my $accumulating_text_for_block;
my $leading_block_text;
my $rleading_block_if_elsif_text;
my $leading_block_text_level;
my $leading_block_text_length_exceeded;
my $leading_block_text_line_length;
my $leading_block_text_line_number;
sub initialize_csc_vars {
%block_leading_text = ();
%block_opening_line_number = ();
$csc_new_statement_ok = 1;
$csc_last_label = "";
%csc_block_label = ();
$rleading_block_if_elsif_text = [];
$accumulating_text_for_block = "";
reset_block_text_accumulator();
return;
}
sub reset_block_text_accumulator {
# save text after 'if' and 'elsif' to append after 'else'
if ($accumulating_text_for_block) {
if ( $accumulating_text_for_block =~ /^(if|elsif)$/ ) {
push @{$rleading_block_if_elsif_text}, $leading_block_text;
}
}
$accumulating_text_for_block = "";
$leading_block_text = "";
$leading_block_text_level = 0;
$leading_block_text_length_exceeded = 0;
$leading_block_text_line_number = 0;
$leading_block_text_line_length = 0;
return;
}
sub set_block_text_accumulator {
my ( $self, $i ) = @_;
$accumulating_text_for_block = $tokens_to_go[$i];
if ( $accumulating_text_for_block !~ /^els/ ) {
$rleading_block_if_elsif_text = [];
}
$leading_block_text = "";
$leading_block_text_level = $levels_to_go[$i];
$leading_block_text_line_number = $self->get_output_line_number();
$leading_block_text_length_exceeded = 0;
# this will contain the column number of the last character
# of the closing side comment
$leading_block_text_line_length =
length($csc_last_label) +
length($accumulating_text_for_block) +
length( $rOpts->{'closing-side-comment-prefix'} ) +
$leading_block_text_level * $rOpts_indent_columns + 3;
return;
}
sub accumulate_block_text {
my ( $self, $i ) = @_;
# accumulate leading text for -csc, ignoring any side comments
if ( $accumulating_text_for_block
&& !$leading_block_text_length_exceeded
&& $types_to_go[$i] ne '#' )
{
my $added_length = $token_lengths_to_go[$i];
$added_length += 1 if $i == 0;
my $new_line_length =
$leading_block_text_line_length + $added_length;
# we can add this text if we don't exceed some limits..
if (
# we must not have already exceeded the text length limit
length($leading_block_text) <
$rOpts_closing_side_comment_maximum_text
# and either:
# the new total line length must be below the line length limit
# or the new length must be below the text length limit
# (ie, we may allow one token to exceed the text length limit)
&& (
$new_line_length <
$maximum_line_length_at_level[$leading_block_text_level]
|| length($leading_block_text) + $added_length <
$rOpts_closing_side_comment_maximum_text
)
# UNLESS: we are adding a closing paren before the brace we seek.
# This is an attempt to avoid situations where the ... to be
# added are longer than the omitted right paren, as in:
# foreach my $item (@a_rather_long_variable_name_here) {
# &whatever;
# } ## end foreach my $item (@a_rather_long_variable_name_here...
|| (
$tokens_to_go[$i] eq ')'
&& (
(
$i + 1 <= $max_index_to_go
&& $block_type_to_go[ $i + 1 ] eq
$accumulating_text_for_block
)
|| ( $i + 2 <= $max_index_to_go
&& $block_type_to_go[ $i + 2 ] eq
$accumulating_text_for_block )
)
)
)
{
# add an extra space at each newline
if ( $i == 0 && $types_to_go[$i] ne 'b' ) {
$leading_block_text .= ' ';
}
# add the token text
$leading_block_text .= $tokens_to_go[$i];
$leading_block_text_line_length = $new_line_length;
}
# show that text was truncated if necessary
elsif ( $types_to_go[$i] ne 'b' ) {
$leading_block_text_length_exceeded = 1;
$leading_block_text .= '...';
}
}
return;
}
sub accumulate_csc_text {
my ($self) = @_;
# called once per output buffer when -csc is used. Accumulates
# the text placed after certain closing block braces.
# Defines and returns the following for this buffer:
my $block_leading_text = ""; # the leading text of the last '}'
my $rblock_leading_if_elsif_text;
my $i_block_leading_text =
-1; # index of token owning block_leading_text
my $block_line_count = 100; # how many lines the block spans
my $terminal_type = 'b'; # type of last nonblank token
my $i_terminal = 0; # index of last nonblank token
my $terminal_block_type = "";
# update most recent statement label
$csc_last_label = "" unless ($csc_last_label);
if ( $types_to_go[0] eq 'J' ) { $csc_last_label = $tokens_to_go[0] }
my $block_label = $csc_last_label;
# Loop over all tokens of this batch
for my $i ( 0 .. $max_index_to_go ) {
my $type = $types_to_go[$i];
my $block_type = $block_type_to_go[$i];
my $token = $tokens_to_go[$i];
# remember last nonblank token type
if ( $type ne '#' && $type ne 'b' ) {
$terminal_type = $type;
$terminal_block_type = $block_type;
$i_terminal = $i;
}
my $type_sequence = $type_sequence_to_go[$i];
if ( $block_type && $type_sequence ) {
if ( $token eq '}' ) {
# restore any leading text saved when we entered this block
if ( defined( $block_leading_text{$type_sequence} ) ) {
( $block_leading_text, $rblock_leading_if_elsif_text )
= @{ $block_leading_text{$type_sequence} };
$i_block_leading_text = $i;
delete $block_leading_text{$type_sequence};
$rleading_block_if_elsif_text =
$rblock_leading_if_elsif_text;
}
if ( defined( $csc_block_label{$type_sequence} ) ) {
$block_label = $csc_block_label{$type_sequence};
delete $csc_block_label{$type_sequence};
}
# if we run into a '}' then we probably started accumulating
# at something like a trailing 'if' clause..no harm done.
if ( $accumulating_text_for_block
&& $levels_to_go[$i] <= $leading_block_text_level )
{
my $lev = $levels_to_go[$i];
reset_block_text_accumulator();
}
if ( defined( $block_opening_line_number{$type_sequence} ) )
{
my $output_line_number =
$self->get_output_line_number();
$block_line_count =
$output_line_number -
$block_opening_line_number{$type_sequence} + 1;
delete $block_opening_line_number{$type_sequence};
}
else {
# Error: block opening line undefined for this line..
# This shouldn't be possible, but it is not a
# significant problem.
}
}
elsif ( $token eq '{' ) {
my $line_number = $self->get_output_line_number();
$block_opening_line_number{$type_sequence} = $line_number;
# set a label for this block, except for
# a bare block which already has the label
# A label can only be used on the next {
if ( $block_type =~ /:$/ ) { $csc_last_label = "" }
$csc_block_label{$type_sequence} = $csc_last_label;
$csc_last_label = "";
if ( $accumulating_text_for_block
&& $levels_to_go[$i] == $leading_block_text_level )
{
if ( $accumulating_text_for_block eq $block_type ) {
# save any leading text before we enter this block
$block_leading_text{$type_sequence} = [
$leading_block_text,
$rleading_block_if_elsif_text
];
$block_opening_line_number{$type_sequence} =
$leading_block_text_line_number;
reset_block_text_accumulator();
}
else {
# shouldn't happen, but not a serious error.
# We were accumulating -csc text for block type
# $accumulating_text_for_block and unexpectedly
# encountered a '{' for block type $block_type.
}
}
}
}
if ( $type eq 'k'
&& $csc_new_statement_ok
&& $is_if_elsif_else_unless_while_until_for_foreach{$token}
&& $token =~ /$closing_side_comment_list_pattern/ )
{
$self->set_block_text_accumulator($i);
}
else {
# note: ignoring type 'q' because of tricks being played
# with 'q' for hanging side comments
if ( $type ne 'b' && $type ne '#' && $type ne 'q' ) {
$csc_new_statement_ok =
( $block_type || $type eq 'J' || $type eq ';' );
}
if ( $type eq ';'
&& $accumulating_text_for_block
&& $levels_to_go[$i] == $leading_block_text_level )
{
reset_block_text_accumulator();
}
else {
$self->accumulate_block_text($i);
}
}
}
# Treat an 'else' block specially by adding preceding 'if' and
# 'elsif' text. Otherwise, the 'end else' is not helpful,
# especially for cuddled-else formatting.
if ( $terminal_block_type =~ /^els/ && $rblock_leading_if_elsif_text ) {
$block_leading_text =
$self->make_else_csc_text( $i_terminal, $terminal_block_type,
$block_leading_text, $rblock_leading_if_elsif_text );
}
# if this line ends in a label then remember it for the next pass
$csc_last_label = "";
if ( $terminal_type eq 'J' ) {
$csc_last_label = $tokens_to_go[$i_terminal];
}
return ( $terminal_type, $i_terminal, $i_block_leading_text,
$block_leading_text, $block_line_count, $block_label );
}
sub make_else_csc_text {
# create additional -csc text for an 'else' and optionally 'elsif',
# depending on the value of switch
#
# = 0 add 'if' text to trailing else
# = 1 same as 0 plus:
# add 'if' to 'elsif's if can fit in line length
# add last 'elsif' to trailing else if can fit in one line
# = 2 same as 1 but do not check if exceed line length
#
# $rif_elsif_text = a reference to a list of all previous closing
# side comments created for this if block
#
my ( $self, $i_terminal, $block_type, $block_leading_text,
$rif_elsif_text )
= @_;
my $csc_text = $block_leading_text;
if ( $block_type eq 'elsif'
&& $rOpts_closing_side_comment_else_flag == 0 )
{
return $csc_text;
}
my $count = @{$rif_elsif_text};
return $csc_text unless ($count);
my $if_text = '[ if' . $rif_elsif_text->[0];
# always show the leading 'if' text on 'else'
if ( $block_type eq 'else' ) {
$csc_text .= $if_text;
}
# see if that's all
if ( $rOpts_closing_side_comment_else_flag == 0 ) {
return $csc_text;
}
my $last_elsif_text = "";
if ( $count > 1 ) {
$last_elsif_text = ' [elsif' . $rif_elsif_text->[ $count - 1 ];
if ( $count > 2 ) { $last_elsif_text = ' [...' . $last_elsif_text; }
}
# tentatively append one more item
my $saved_text = $csc_text;
if ( $block_type eq 'else' ) {
$csc_text .= $last_elsif_text;
}
else {
$csc_text .= ' ' . $if_text;
}
# all done if no length checks requested
if ( $rOpts_closing_side_comment_else_flag == 2 ) {
return $csc_text;
}
# undo it if line length exceeded
my $length =
length($csc_text) +
length($block_type) +
length( $rOpts->{'closing-side-comment-prefix'} ) +
$levels_to_go[$i_terminal] * $rOpts_indent_columns + 3;
if (
$length > $maximum_line_length_at_level[$leading_block_text_level] )
{
$csc_text = $saved_text;
}
return $csc_text;
}
} ## end closure accumulate_csc_text
{ ## begin closure balance_csc_text
# Some additional routines for handling the --closing-side-comments option
my %matching_char;
BEGIN {
%matching_char = (
'{' => '}',
'(' => ')',
'[' => ']',
'}' => '{',
')' => '(',
']' => '[',
);
}
sub balance_csc_text {
# Append characters to balance a closing side comment so that editors
# such as vim can correctly jump through code.
# Simple Example:
# input = ## end foreach my $foo ( sort { $b ...
# output = ## end foreach my $foo ( sort { $b ...})
# NOTE: This routine does not currently filter out structures within
# quoted text because the bounce algorithms in text editors do not
# necessarily do this either (a version of vim was checked and
# did not do this).
# Some complex examples which will cause trouble for some editors:
# while ( $mask_string =~ /\{[^{]*?\}/g ) {
# if ( $mask_str =~ /\}\s*els[^\{\}]+\{$/ ) {
# if ( $1 eq '{' ) {
# test file test1/braces.pl has many such examples.
my ($csc) = @_;
# loop to examine characters one-by-one, RIGHT to LEFT and
# build a balancing ending, LEFT to RIGHT.
for ( my $pos = length($csc) - 1 ; $pos >= 0 ; $pos-- ) {
my $char = substr( $csc, $pos, 1 );
# ignore everything except structural characters
next unless ( $matching_char{$char} );
# pop most recently appended character
my $top = chop($csc);
# push it back plus the mate to the newest character
# unless they balance each other.
$csc = $csc . $top . $matching_char{$char} unless $top eq $char;
}
# return the balanced string
return $csc;
}
} ## end closure balance_csc_text
sub add_closing_side_comment {
my $self = shift;
my $rLL = $self->[_rLL_];
# add closing side comments after closing block braces if -csc used
my ( $closing_side_comment, $cscw_block_comment );
#---------------------------------------------------------------
# Step 1: loop through all tokens of this line to accumulate
# the text needed to create the closing side comments. Also see
# how the line ends.
#---------------------------------------------------------------
my ( $terminal_type, $i_terminal, $i_block_leading_text,
$block_leading_text, $block_line_count, $block_label )
= $self->accumulate_csc_text();
#---------------------------------------------------------------
# Step 2: make the closing side comment if this ends a block
#---------------------------------------------------------------
my $have_side_comment = $types_to_go[$max_index_to_go] eq '#';
# if this line might end in a block closure..
if (
$terminal_type eq '}'
# ..and either
&& (
# the block is long enough
( $block_line_count >= $rOpts->{'closing-side-comment-interval'} )
# or there is an existing comment to check
|| ( $have_side_comment
&& $rOpts->{'closing-side-comment-warnings'} )
)
# .. and if this is one of the types of interest
&& $block_type_to_go[$i_terminal] =~
/$closing_side_comment_list_pattern/
# .. but not an anonymous sub
# These are not normally of interest, and their closing braces are
# often followed by commas or semicolons anyway. This also avoids
# possible erratic output due to line numbering inconsistencies
# in the cases where their closing braces terminate a line.
&& $block_type_to_go[$i_terminal] ne 'sub'
# ..and the corresponding opening brace must is not in this batch
# (because we do not need to tag one-line blocks, although this
# should also be caught with a positive -csci value)
&& $mate_index_to_go[$i_terminal] < 0
# ..and either
&& (
# this is the last token (line doesn't have a side comment)
!$have_side_comment
# or the old side comment is a closing side comment
|| $tokens_to_go[$max_index_to_go] =~
/$closing_side_comment_prefix_pattern/
)
)
{
# then make the closing side comment text
if ($block_label) { $block_label .= " " }
my $token =
"$rOpts->{'closing-side-comment-prefix'} $block_label$block_type_to_go[$i_terminal]";
# append any extra descriptive text collected above
if ( $i_block_leading_text == $i_terminal ) {
$token .= $block_leading_text;
}
$token = balance_csc_text($token)
if $rOpts->{'closing-side-comments-balanced'};
$token =~ s/\s*$//; # trim any trailing whitespace
# handle case of existing closing side comment
if ($have_side_comment) {
# warn if requested and tokens differ significantly
if ( $rOpts->{'closing-side-comment-warnings'} ) {
my $old_csc = $tokens_to_go[$max_index_to_go];
my $new_csc = $token;
$new_csc =~ s/\s+//g; # trim all whitespace
$old_csc =~ s/\s+//g; # trim all whitespace
$new_csc =~ s/[\]\)\}\s]*$//; # trim trailing structures
$old_csc =~ s/[\]\)\}\s]*$//; # trim trailing structures
$new_csc =~ s/(\.\.\.)$//; # trim trailing '...'
my $new_trailing_dots = $1;
$old_csc =~ s/(\.\.\.)\s*$//; # trim trailing '...'
# Patch to handle multiple closing side comments at
# else and elsif's. These have become too complicated
# to check, so if we see an indication of
# '[ if' or '[ # elsif', then assume they were made
# by perltidy.
if ( $block_type_to_go[$i_terminal] eq 'else' ) {
if ( $old_csc =~ /\[\s*elsif/ ) { $old_csc = $new_csc }
}
elsif ( $block_type_to_go[$i_terminal] eq 'elsif' ) {
if ( $old_csc =~ /\[\s*if/ ) { $old_csc = $new_csc }
}
# if old comment is contained in new comment,
# only compare the common part.
if ( length($new_csc) > length($old_csc) ) {
$new_csc = substr( $new_csc, 0, length($old_csc) );
}
# if the new comment is shorter and has been limited,
# only compare the common part.
if ( length($new_csc) < length($old_csc)
&& $new_trailing_dots )
{
$old_csc = substr( $old_csc, 0, length($new_csc) );
}
# any remaining difference?
if ( $new_csc ne $old_csc ) {
# just leave the old comment if we are below the threshold
# for creating side comments
if ( $block_line_count <
$rOpts->{'closing-side-comment-interval'} )
{
$token = undef;
}
# otherwise we'll make a note of it
else {
warning(
"perltidy -cscw replaced: $tokens_to_go[$max_index_to_go]\n"
);
# save the old side comment in a new trailing block
# comment
my $timestamp = "";
if ( $rOpts->{'timestamp'} ) {
my ( $day, $month, $year ) = (localtime)[ 3, 4, 5 ];
$year += 1900;
$month += 1;
$timestamp = "$year-$month-$day";
}
$cscw_block_comment =
"## perltidy -cscw $timestamp: $tokens_to_go[$max_index_to_go]";
## "## perltidy -cscw $year-$month-$day: $tokens_to_go[$max_index_to_go]";
}
}
else {
# No differences.. we can safely delete old comment if we
# are below the threshold
if ( $block_line_count <
$rOpts->{'closing-side-comment-interval'} )
{
$token = undef;
$self->unstore_token_to_go()
if ( $types_to_go[$max_index_to_go] eq '#' );
$self->unstore_token_to_go()
if ( $types_to_go[$max_index_to_go] eq 'b' );
}
}
}
# switch to the new csc (unless we deleted it!)
if ($token) {
$tokens_to_go[$max_index_to_go] = $token;
my $K = $K_to_go[$max_index_to_go];
$rLL->[$K]->[_TOKEN_] = $token;
$rLL->[$K]->[_TOKEN_LENGTH_] =
length($token); # NOTE: length no longer important
}
}
# handle case of NO existing closing side comment
else {
# To avoid inserting a new token in the token arrays, we
# will just return the new side comment so that it can be
# inserted just before it is needed in the call to the
# vertical aligner.
$closing_side_comment = $token;
}
}
return ( $closing_side_comment, $cscw_block_comment );
}
############################
# CODE SECTION 15: Summarize
############################
sub wrapup {
# This is the last routine called when a file is formatted.
# Flush buffer and write any informative messages
my $self = shift;
$self->flush();
my $file_writer_object = $self->[_file_writer_object_];
$file_writer_object->decrement_output_line_number()
; # fix up line number since it was incremented
we_are_at_the_last_line();
my $added_semicolon_count = $self->[_added_semicolon_count_];
my $first_added_semicolon_at = $self->[_first_added_semicolon_at_];
my $last_added_semicolon_at = $self->[_last_added_semicolon_at_];
if ( $added_semicolon_count > 0 ) {
my $first = ( $added_semicolon_count > 1 ) ? "First" : "";
my $what =
( $added_semicolon_count > 1 ) ? "semicolons were" : "semicolon was";
write_logfile_entry("$added_semicolon_count $what added:\n");
write_logfile_entry(
" $first at input line $first_added_semicolon_at\n");
if ( $added_semicolon_count > 1 ) {
write_logfile_entry(
" Last at input line $last_added_semicolon_at\n");
}
write_logfile_entry(" (Use -nasc to prevent semicolon addition)\n");
write_logfile_entry("\n");
}
my $deleted_semicolon_count = $self->[_deleted_semicolon_count_];
my $first_deleted_semicolon_at = $self->[_first_deleted_semicolon_at_];
my $last_deleted_semicolon_at = $self->[_last_deleted_semicolon_at_];
if ( $deleted_semicolon_count > 0 ) {
my $first = ( $deleted_semicolon_count > 1 ) ? "First" : "";
my $what =
( $deleted_semicolon_count > 1 )
? "semicolons were"
: "semicolon was";
write_logfile_entry(
"$deleted_semicolon_count unnecessary $what deleted:\n");
write_logfile_entry(
" $first at input line $first_deleted_semicolon_at\n");
if ( $deleted_semicolon_count > 1 ) {
write_logfile_entry(
" Last at input line $last_deleted_semicolon_at\n");
}
write_logfile_entry(" (Use -ndsm to prevent semicolon deletion)\n");
write_logfile_entry("\n");
}
my $embedded_tab_count = $self->[_embedded_tab_count_];
my $first_embedded_tab_at = $self->[_first_embedded_tab_at_];
my $last_embedded_tab_at = $self->[_last_embedded_tab_at_];
if ( $embedded_tab_count > 0 ) {
my $first = ( $embedded_tab_count > 1 ) ? "First" : "";
my $what =
( $embedded_tab_count > 1 )
? "quotes or patterns"
: "quote or pattern";
write_logfile_entry("$embedded_tab_count $what had embedded tabs:\n");
write_logfile_entry(
"This means the display of this script could vary with device or software\n"
);
write_logfile_entry(" $first at input line $first_embedded_tab_at\n");
if ( $embedded_tab_count > 1 ) {
write_logfile_entry(
" Last at input line $last_embedded_tab_at\n");
}
write_logfile_entry("\n");
}
my $first_tabbing_disagreement = $self->[_first_tabbing_disagreement_];
my $last_tabbing_disagreement = $self->[_last_tabbing_disagreement_];
my $tabbing_disagreement_count = $self->[_tabbing_disagreement_count_];
my $in_tabbing_disagreement = $self->[_in_tabbing_disagreement_];
if ($first_tabbing_disagreement) {
write_logfile_entry(
"First indentation disagreement seen at input line $first_tabbing_disagreement\n"
);
}
my $first_btd = $self->[_first_brace_tabbing_disagreement_];
if ($first_btd) {
my $msg =
"First closing brace indentation disagreement started at input line $first_btd\n";
write_logfile_entry($msg);
# leave a hint in the .ERR file if there was a brace error
if ( get_saw_brace_error() ) { warning("NOTE: $msg") }
}
my $in_btd = $self->[_in_brace_tabbing_disagreement_];
if ($in_btd) {
my $msg =
"Ending with brace indentation disagreement which started at input line $in_btd\n";
write_logfile_entry($msg);
# leave a hint in the .ERR file if there was a brace error
if ( get_saw_brace_error() ) { warning("NOTE: $msg") }
}
if ($in_tabbing_disagreement) {
my $msg =
"Ending with indentation disagreement which started at input line $in_tabbing_disagreement\n";
write_logfile_entry($msg);
}
else {
if ($last_tabbing_disagreement) {
write_logfile_entry(
"Last indentation disagreement seen at input line $last_tabbing_disagreement\n"
);
}
else {
write_logfile_entry("No indentation disagreement seen\n");
}
}
if ($first_tabbing_disagreement) {
write_logfile_entry(
"Note: Indentation disagreement detection is not accurate for outdenting and -lp.\n"
);
}
write_logfile_entry("\n");
my $vao = $self->[_vertical_aligner_object_];
$vao->report_anything_unusual();
$file_writer_object->report_line_length_errors();
$self->[_converged_] = $file_writer_object->get_convergence_check()
|| $rOpts->{'indent-only'};
return;
}
} ## end package Perl::Tidy::Formatter
1;
Perl-Tidy-20210717/lib/Perl/Tidy/IOScalar.pm 0000644 0001750 0001750 00000006660 14073571547 017227 0 ustar steve steve #####################################################################
#
# This is a stripped down version of IO::Scalar
# Given a reference to a scalar, it supplies either:
# a getline method which reads lines (mode='r'), or
# a print method which reads lines (mode='w')
#
#####################################################################
package Perl::Tidy::IOScalar;
use strict;
use warnings;
use Carp;
our $VERSION = '20210717';
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 <[1];
if ( $mode ne 'r' ) {
confess <[2]++;
return $self->[0]->[$i];
}
sub print {
my ( $self, $msg ) = @_;
my $mode = $self->[1];
if ( $mode ne 'w' ) {
confess <[0] } .= $msg;
return;
}
sub close { return }
1;
Perl-Tidy-20210717/lib/Perl/Tidy.pm 0000644 0001750 0001750 00000523704 14073571525 015571 0 ustar steve steve #
###########################################################
#
# perltidy - a perl script indenter and formatter
#
# Copyright (c) 2000-2021 by Steve Hancock
# Distributed under the GPL license agreement; see file COPYING
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
#
# This program 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.
#
# You should have received a copy of the GNU General Public License along
# with this program; if not, write to the Free Software Foundation, Inc.,
# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
#
# For brief instructions, try 'perltidy -h'.
# For more complete documentation, try 'man perltidy'
# or visit http://perltidy.sourceforge.net
#
# This script is an example of the default style. It was formatted with:
#
# perltidy Tidy.pm
#
# Code Contributions: See ChangeLog.html for a complete history.
# Michael Cartmell supplied code for adaptation to VMS and helped with
# v-strings.
# Hugh S. Myers supplied sub streamhandle and the supporting code to
# create a Perl::Tidy module which can operate on strings, arrays, etc.
# Yves Orton supplied coding to help detect Windows versions.
# Axel Rose supplied a patch for MacPerl.
# Sebastien Aperghis-Tramoni supplied a patch for the defined or operator.
# Dan Tyrell contributed a patch for binary I/O.
# Ueli Hugenschmidt contributed a patch for -fpsc
# Sam Kington supplied a patch to identify the initial indentation of
# entabbed code.
# jonathan swartz supplied patches for:
# * .../ pattern, which looks upwards from directory
# * --notidy, to be used in directories where we want to avoid
# accidentally tidying
# * prefilter and postfilter
# * iterations option
#
# Many others have supplied key ideas, suggestions, and bug reports;
# see the CHANGES file.
#
############################################################
package Perl::Tidy;
# perlver reports minimum version needed is 5.8.0
# 5.004 needed for IO::File
# 5.008 needed for wide characters
use 5.008;
use warnings;
use strict;
use Exporter;
use Carp;
use Digest::MD5 qw(md5_hex);
use Perl::Tidy::Debugger;
use Perl::Tidy::DevNull;
use Perl::Tidy::Diagnostics;
use Perl::Tidy::FileWriter;
use Perl::Tidy::Formatter;
use Perl::Tidy::HtmlWriter;
use Perl::Tidy::IOScalar;
use Perl::Tidy::IOScalarArray;
use Perl::Tidy::IndentationItem;
use Perl::Tidy::LineSink;
use Perl::Tidy::LineSource;
use Perl::Tidy::Logger;
use Perl::Tidy::Tokenizer;
use Perl::Tidy::VerticalAligner;
local $| = 1;
# this can be turned on for extra checking during development
use constant DEVEL_MODE => 0;
use vars qw{
$VERSION
@ISA
@EXPORT
};
@ISA = qw( Exporter );
@EXPORT = qw( &perltidy );
use Cwd;
use Encode ();
use Encode::Guess;
use IO::File;
use File::Basename;
use File::Copy;
use File::Temp qw(tempfile);
BEGIN {
# Release version is the approximate YYMMDD of the release.
# Development version is (Last Release).(Development Number)
# To make the number continually increasing, the Development Number is a 2
# digit number starting at 01 after a release is continually bumped along
# at significant points during development. If it ever reaches 99 then the
# Release version must be bumped, and it is probably past time for a
# release anyway.
$VERSION = '20210717';
}
sub DESTROY {
# required to avoid call to AUTOLOAD in some versions of perl
}
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();
print STDERR <new( $filename, $mode ) };
}
elsif ( $ref eq 'SCALAR' ) {
$New = sub { Perl::Tidy::IOScalar->new( $filename, $mode ) };
}
else {
# Accept an object with a getline method for reading. Note:
# IO::File is built-in and does not respond to the defined
# operator. If this causes trouble, the check can be
# skipped and we can just let it crash if there is no
# getline.
if ( $mode =~ /[rR]/ ) {
# RT#97159; part 1 of 2: updated to use 'can'
##if ( $ref eq 'IO::File' || defined &{ $ref . "::getline" } ) {
if ( $ref->can('getline') ) {
$New = sub { $filename };
}
else {
$New = sub { undef };
confess <can('print') ) {
$New = sub { $filename };
}
else {
$New = sub { undef };
confess <new( $filename, $mode ) };
}
}
$fh = $New->( $filename, $mode );
if ( !$fh ) {
Warn("Couldn't open file:$filename in mode:$mode : $!\n");
}
else {
# Case 1: handle encoded data
if ($is_encoded_data) {
if ( ref($fh) eq 'IO::File' ) {
## binmode object call not available in older perl versions
## $fh->binmode(":raw:encoding(UTF-8)");
binmode $fh, ":raw:encoding(UTF-8)";
}
elsif ( $filename eq '-' ) {
binmode STDOUT, ":raw:encoding(UTF-8)";
}
}
# Case 2: handle unencoded data
else {
if ( ref($fh) eq 'IO::File' ) { binmode $fh }
elsif ( $filename eq '-' ) { binmode STDOUT }
}
}
return $fh, ( $ref or $filename );
}
sub find_input_line_ending {
# Peek at a file and return first line ending character.
# Return undefined value in case of any trouble.
my ($input_file) = @_;
my $ending;
# silently ignore input from object or stdin
if ( ref($input_file) || $input_file eq '-' ) {
return $ending;
}
my $fh;
open( $fh, '<', $input_file ) || return $ending;
binmode $fh;
my $buf;
read( $fh, $buf, 1024 );
close $fh;
if ( $buf && $buf =~ /([\012\015]+)/ ) {
my $test = $1;
# dos
if ( $test =~ /^(\015\012)+$/ ) { $ending = "\015\012" }
# mac
elsif ( $test =~ /^\015+$/ ) { $ending = "\015" }
# unix
elsif ( $test =~ /^\012+$/ ) { $ending = "\012" }
# unknown
else { }
}
# no ending seen
else { }
return $ending;
}
{ ## begin closure for sub catfile
my $missing_file_spec;
BEGIN {
eval { require File::Spec };
$missing_file_spec = $@;
}
sub catfile {
# concatenate a path and file basename
# returns undef in case of error
my @parts = @_;
# use File::Spec if we can
unless ($missing_file_spec) {
return File::Spec->catfile(@parts);
}
# Perl 5.004 systems may not have File::Spec so we'll make
# a simple try. We assume File::Basename is available.
# return if not successful.
my $name = pop @parts;
my $path = join '/', @parts;
my $test_file = $path . $name;
my ( $test_name, $test_path ) = fileparse($test_file);
return $test_file if ( $test_name eq $name );
return if ( $^O eq 'VMS' );
# this should work at least for Windows and Unix:
$test_file = $path . '/' . $name;
( $test_name, $test_path ) = fileparse($test_file);
return $test_file if ( $test_name eq $name );
return;
}
} ## end closure for sub catfile
# Here is a map of the flow of data from the input source to the output
# line sink:
#
# LineSource-->Tokenizer-->Formatter-->VerticalAligner-->FileWriter-->
# input groups output
# lines tokens lines of lines lines
# lines
#
# The names correspond to the package names responsible for the unit processes.
#
# The overall process is controlled by the "main" package.
#
# LineSource is the stream of input lines
#
# Tokenizer analyzes a line and breaks it into tokens, peeking ahead
# if necessary. A token is any section of the input line which should be
# manipulated as a single entity during formatting. For example, a single
# ',' character is a token, and so is an entire side comment. It handles
# the complexities of Perl syntax, such as distinguishing between '<<' as
# a shift operator and as a here-document, or distinguishing between '/'
# as a divide symbol and as a pattern delimiter.
#
# Formatter inserts and deletes whitespace between tokens, and breaks
# sequences of tokens at appropriate points as output lines. It bases its
# decisions on the default rules as modified by any command-line options.
#
# VerticalAligner collects groups of lines together and tries to line up
# certain tokens, such as '=>', '#', and '=' by adding whitespace.
#
# FileWriter simply writes lines to the output stream.
#
# The Logger package, not shown, records significant events and warning
# messages. It writes a .LOG file, which may be saved with a
# '-log' or a '-g' flag.
{ #<<<
my $Warn_count;
my $fh_stderr;
# Bump Warn_count only: it is essential to bump the count on all warnings, even
# if no message goes out, so that the correct exit status is set.
sub Warn_count_bump { $Warn_count++; return }
# Output Warn message only
sub Warn_msg { my $msg = shift; $fh_stderr->print($msg); return }
# Output Warn message and bump Warn count
sub Warn { my $msg = shift; $fh_stderr->print($msg); $Warn_count++; return }
sub perltidy {
my %input_hash = @_;
my %defaults = (
argv => undef,
destination => undef,
formatter => undef,
logfile => undef,
errorfile => undef,
teefile => undef,
debugfile => undef,
perltidyrc => undef,
source => undef,
stderr => undef,
dump_options => undef,
dump_options_type => undef,
dump_getopt_flags => undef,
dump_options_category => undef,
dump_options_range => undef,
dump_abbreviations => undef,
prefilter => undef,
postfilter => undef,
);
# Fix for issue git #57
$Warn_count = 0;
# don't overwrite callers ARGV
local @ARGV = @ARGV;
local *STDERR = *STDERR;
if ( my @bad_keys = grep { !exists $defaults{$_} } keys %input_hash ) {
local $" = ')(';
my @good_keys = sort keys %defaults;
@bad_keys = sort @bad_keys;
confess <('dump_options');
my $dump_getopt_flags = $get_hash_ref->('dump_getopt_flags');
my $dump_options_category = $get_hash_ref->('dump_options_category');
my $dump_abbreviations = $get_hash_ref->('dump_abbreviations');
my $dump_options_range = $get_hash_ref->('dump_options_range');
# validate dump_options_type
if ( defined($dump_options) ) {
unless ( defined($dump_options_type) ) {
$dump_options_type = 'perltidyrc';
}
unless ( $dump_options_type =~ /^(perltidyrc|full)$/ ) {
croak <new();
}
# see if ARGV is overridden
if ( defined($argv) ) {
my $rargv = ref $argv;
if ( $rargv eq 'SCALAR' ) { $argv = ${$argv}; $rargv = undef }
# ref to ARRAY
if ($rargv) {
if ( $rargv eq 'ARRAY' ) {
@ARGV = @{$argv};
}
else {
croak <{$opt} = $flag;
}
}
if ( defined($dump_options_category) ) {
$quit_now = 1;
%{$dump_options_category} = %{$roption_category};
}
if ( defined($dump_options_range) ) {
$quit_now = 1;
%{$dump_options_range} = %{$roption_range};
}
if ( defined($dump_abbreviations) ) {
$quit_now = 1;
%{$dump_abbreviations} = %{$rexpansion};
}
if ( defined($dump_options) ) {
$quit_now = 1;
%{$dump_options} = %{$rOpts};
}
Exit(0) if ($quit_now);
# make printable string of options for this run as possible diagnostic
my $readable_options = readable_options( $rOpts, $roption_string );
# dump from command line
if ( $rOpts->{'dump-options'} ) {
print STDOUT $readable_options;
Exit(0);
}
#---------------------------------------------------------------
# check parameters and their interactions
#---------------------------------------------------------------
my $tabsize =
check_options( $rOpts, $is_Windows, $Windows_type, $rpending_complaint );
if ($user_formatter) {
$rOpts->{'format'} = 'user';
}
# there must be one entry here for every possible format
my %default_file_extension = (
tidy => 'tdy',
html => 'html',
user => '',
);
# be sure we have a valid output format
unless ( exists $default_file_extension{ $rOpts->{'format'} } ) {
my $formats = join ' ',
sort map { "'" . $_ . "'" } keys %default_file_extension;
my $fmt = $rOpts->{'format'};
Die("-format='$fmt' but must be one of: $formats\n");
}
my $output_extension = make_extension( $rOpts->{'output-file-extension'},
$default_file_extension{ $rOpts->{'format'} }, $dot );
# If the backup extension contains a / character then the backup should
# be deleted when the -b option is used. On older versions of
# perltidy this will generate an error message due to an illegal
# file name.
#
# A backup file will still be generated but will be deleted
# at the end. If -bext='/' then this extension will be
# the default 'bak'. Otherwise it will be whatever characters
# remains after all '/' characters are removed. For example:
# -bext extension slashes
# '/' bak 1
# '/delete' delete 1
# 'delete/' delete 1
# '/dev/null' devnull 2 (Currently not allowed)
my $bext = $rOpts->{'backup-file-extension'};
my $delete_backup = ( $rOpts->{'backup-file-extension'} =~ s/\///g );
# At present only one forward slash is allowed. In the future multiple
# slashes may be allowed to allow for other options
if ( $delete_backup > 1 ) {
Die("-bext=$bext contains more than one '/'\n");
}
my $backup_extension =
make_extension( $rOpts->{'backup-file-extension'}, 'bak', $dot );
my $html_toc_extension =
make_extension( $rOpts->{'html-toc-extension'}, 'toc', $dot );
my $html_src_extension =
make_extension( $rOpts->{'html-src-extension'}, 'src', $dot );
# check for -b option;
# silently ignore unless beautify mode
my $in_place_modify = $rOpts->{'backup-and-modify-in-place'}
&& $rOpts->{'format'} eq 'tidy';
# Turn off -b with warnings in case of conflicts with other options.
# NOTE: Do this silently, without warnings, if there is a source or
# 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. See email discussion with Merijn Brand 26 Feb 2014.
if ($in_place_modify) {
if ( $rOpts->{'standard-output'}
|| $destination_stream
|| ref $source_stream
|| $rOpts->{'outfile'}
|| defined( $rOpts->{'output-path'} ) )
{
$in_place_modify = 0;
}
}
# Turn off assert-tidy and assert-untidy unless we are tidying files
if ( $rOpts->{'format'} ne 'tidy' ) {
if ( $rOpts->{'assert-tidy'} ) {
$rOpts->{'assert-tidy'} = 0;
Warn("ignoring --assert-tidy, --format is not 'tidy'\n");
}
if ( $rOpts->{'assert-untidy'} ) {
$rOpts->{'assert-untidy'} = 0;
Warn("ignoring --assert-untidy, --format is not 'tidy'\n");
}
}
Perl::Tidy::Formatter::check_options($rOpts);
Perl::Tidy::Tokenizer::check_options($rOpts);
if ( $rOpts->{'format'} eq 'html' ) {
Perl::Tidy::HtmlWriter->check_options($rOpts);
}
# make the pattern of file extensions that we shouldn't touch
my $forbidden_file_extensions = "(($dot_pattern)(LOG|DEBUG|ERR|TEE)";
if ($output_extension) {
my $ext = quotemeta($output_extension);
$forbidden_file_extensions .= "|$ext";
}
if ( $in_place_modify && $backup_extension ) {
my $ext = quotemeta($backup_extension);
$forbidden_file_extensions .= "|$ext";
}
$forbidden_file_extensions .= ')$';
# Create a diagnostics object if requested;
# This is only useful for code development
my $diagnostics_object = undef;
if ( $rOpts->{'DIAGNOSTICS'} ) {
$diagnostics_object = Perl::Tidy::Diagnostics->new();
}
# no filenames should be given if input is from an array
if ($source_stream) {
if ( @ARGV > 0 ) {
Die(
"You may not specify any filenames when a source array is given\n"
);
}
# we'll stuff the source array into ARGV
unshift( @ARGV, $source_stream );
# No special treatment for source stream which is a filename.
# This will enable checks for binary files and other bad stuff.
$source_stream = undef unless ref($source_stream);
}
# use stdin by default if no source array and no args
else {
unshift( @ARGV, '-' ) unless @ARGV;
}
# Flag for loading module Unicode::GCString for evaluating text width:
# undef = ok to use but not yet loaded
# 0 = do not use; failed to load or not wanted
# 1 = successfully loaded and ok to use
# The module is not actually loaded unless/until it is needed
my $loaded_unicode_gcstring;
if ( !$rOpts->{'use-unicode-gcstring'} ) {
$loaded_unicode_gcstring = 0;
}
#---------------------------------------------------------------
# Ready to go...
# main loop to process all files in argument list
#---------------------------------------------------------------
my $formatter = undef;
my $tokenizer = undef;
# Remove duplicate filenames. Otherwise, for example if the user entered
# perltidy -b myfile.pl myfile.pl
# the backup version of the original would be lost.
if ( @ARGV > 1 ) {
my %seen = ();
@ARGV = grep { !$seen{$_}++ } @ARGV;
}
# If requested, process in order of increasing file size
# This can significantly reduce perl's virtual memory usage during testing.
if ( @ARGV > 1 && $rOpts->{'file-size-order'} ) {
@ARGV =
map { $_->[0] }
sort { $a->[1] <=> $b->[1] }
map { [ $_, -e $_ ? -s $_ : 0 ] } @ARGV;
}
my $number_of_files = @ARGV;
while ( my $input_file = shift @ARGV ) {
my $fileroot;
my @input_file_stat;
my $display_name;
#---------------------------------------------------------------
# prepare this input stream
#---------------------------------------------------------------
if ($source_stream) {
$fileroot = "perltidy";
$display_name = "";
# If the source is from an array or string, then .LOG output
# is only possible if a logfile stream is specified. This prevents
# unexpected perltidy.LOG files.
if ( !defined($logfile_stream) ) {
$logfile_stream = Perl::Tidy::DevNull->new();
# Likewise for .TEE and .DEBUG output
}
if ( !defined($teefile_stream) ) {
$teefile_stream = Perl::Tidy::DevNull->new();
}
if ( !defined($debugfile_stream) ) {
$debugfile_stream = Perl::Tidy::DevNull->new();
}
}
elsif ( $input_file eq '-' ) { # '-' indicates input from STDIN
$fileroot = "perltidy"; # root name to use for .ERR, .LOG, etc
$display_name = "";
$in_place_modify = 0;
}
else {
$fileroot = $input_file;
$display_name = $input_file;
unless ( -e $input_file ) {
# file doesn't exist - check for a file glob
if ( $input_file =~ /([\?\*\[\{])/ ) {
# Windows shell may not remove quotes, so do it
my $input_file = $input_file;
if ( $input_file =~ /^\'(.+)\'$/ ) { $input_file = $1 }
if ( $input_file =~ /^\"(.+)\"$/ ) { $input_file = $1 }
my $pattern = fileglob_to_re($input_file);
my $dh;
if ( opendir( $dh, './' ) ) {
my @files =
grep { /$pattern/ && !-d $_ } readdir($dh);
closedir($dh);
if (@files) {
unshift @ARGV, @files;
next;
}
}
}
Warn("skipping file: '$input_file': no matches found\n");
next;
}
unless ( -f $input_file ) {
Warn("skipping file: $input_file: not a regular file\n");
next;
}
# As a safety precaution, skip zero length files.
# If for example a source file got clobbered somehow,
# the old .tdy or .bak files might still exist so we
# shouldn't overwrite them with zero length files.
unless ( -s $input_file ) {
Warn("skipping file: $input_file: Zero size\n");
next;
}
# And avoid formatting extremely large files. Since perltidy reads
# files into memory, trying to process an extremely large file
# could cause system problems.
my $size_in_mb = ( -s $input_file ) / ( 1024 * 1024 );
if ( $size_in_mb > $rOpts->{'maximum-file-size-mb'} ) {
$size_in_mb = sprintf( "%0.1f", $size_in_mb );
Warn(
"skipping file: $input_file: size $size_in_mb MB exceeds limit $rOpts->{'maximum-file-size-mb'}; use -mfs=i to change\n"
);
next;
}
unless ( ( -T $input_file ) || $rOpts->{'force-read-binary'} ) {
Warn(
"skipping file: $input_file: Non-text (override with -f)\n"
);
next;
}
# we should have a valid filename now
$fileroot = $input_file;
@input_file_stat = stat($input_file);
if ( $^O eq 'VMS' ) {
( $fileroot, $dot ) = check_vms_filename($fileroot);
}
# add option to change path here
if ( defined( $rOpts->{'output-path'} ) ) {
my ( $base, $old_path ) = fileparse($fileroot);
my $new_path = $rOpts->{'output-path'};
unless ( -d $new_path ) {
unless ( mkdir $new_path, 0777 ) {
Die("unable to create directory $new_path: $!\n");
}
}
my $path = $new_path;
$fileroot = catfile( $path, $base );
unless ($fileroot) {
Die(<new(
input_file => $input_file,
rOpts => $rOpts,
rpending_logfile_message => $rpending_logfile_message,
);
next unless ($source_object);
my $max_iterations = $rOpts->{'iterations'};
my $do_convergence_test = $max_iterations > 1;
my $convergence_log_message;
my %saw_md5;
my $digest_input = 0;
my $buf = '';
while ( my $line = $source_object->get_line() ) {
$buf .= $line;
}
my $remove_terminal_newline =
!$rOpts->{'add-terminal-newline'} && substr( $buf, -1, 1 ) !~ /\n/;
# Decode the input stream if necessary requested
my $encoding_in = "";
my $rOpts_character_encoding = $rOpts->{'character-encoding'};
my $encoding_log_message;
# Case 1. See if we already have an encoded string. In that
# case, we have to ignore any encoding flag.
if ( utf8::is_utf8($buf) ) {
$encoding_in = "utf8";
}
# Case 2. No input stream encoding requested. This is appropriate
# for single-byte encodings like ascii, latin-1, etc
elsif ( !$rOpts_character_encoding
|| $rOpts_character_encoding eq 'none' )
{
# nothing to do
}
# Case 3. guess input stream encoding if requested
elsif ( $rOpts_character_encoding =~ /^guess$/i ) {
# The guessing strategy is simple: use Encode::Guess to guess
# an encoding. If and only if the guess is utf8, try decoding and
# use it if successful. Otherwise, we proceed assuming the
# characters are encoded as single bytes (same as if 'none' had
# been specified as the encoding).
# In testing I have found that including additional guess 'suspect'
# encodings sometimes works but can sometimes lead to disaster by
# using an incorrect decoding. The user can always specify a
# specific input encoding.
my $buf_in = $buf;
my $decoder = guess_encoding( $buf_in, 'utf8' );
if ( ref($decoder) ) {
$encoding_in = $decoder->name;
if ( $encoding_in !~ /^(UTF-8|utf8)$/ ) {
$encoding_in = "";
$buf = $buf_in;
$encoding_log_message .= <decode($buf_in); };
if ($@) {
$encoding_log_message .= <{'use-unicode-gcstring'} ) {
Warn(<new( $_[0] )->columns;
};
}
}
# MD5 sum of input file is evaluated before any prefilter
my $saved_input_buf;
if ( $rOpts->{'assert-tidy'} || $rOpts->{'assert-untidy'} ) {
$digest_input = $md5_hex->($buf);
$saved_input_buf = $buf;
}
# 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.
$buf = $prefilter->($buf) if $prefilter;
# starting MD5 sum for convergence test is evaluated after any prefilter
if ($do_convergence_test) {
my $digest = $md5_hex->($buf);
$saw_md5{$digest} = 0;
}
$source_object = Perl::Tidy::LineSource->new(
input_file => \$buf,
rOpts => $rOpts,
rpending_logfile_message => $rpending_logfile_message,
);
# register this file name with the Diagnostics package
$diagnostics_object->set_input_file($input_file)
if $diagnostics_object;
#---------------------------------------------------------------
# prepare the output stream
#---------------------------------------------------------------
my $output_file = undef;
my $actual_output_extension;
if ( $rOpts->{'outfile'} ) {
if ( $number_of_files <= 1 ) {
if ( $rOpts->{'standard-output'} ) {
my $msg = "You may not use -o and -st together";
$msg .= " (-pbp contains -st; see manual)" if ($saw_pbp);
Die("$msg\n");
}
elsif ($destination_stream) {
Die(
"You may not specify a destination array and -o together\n"
);
}
elsif ( defined( $rOpts->{'output-path'} ) ) {
Die("You may not specify -o and -opath together\n");
}
elsif ( defined( $rOpts->{'output-file-extension'} ) ) {
Die("You may not specify -o and -oext together\n");
}
$output_file = $rOpts->{outfile};
# make sure user gives a file name after -o
if ( $output_file =~ /^-/ ) {
Die("You must specify a valid filename after -o\n");
}
# do not overwrite input file with -o
if ( @input_file_stat && ( $output_file eq $input_file ) ) {
Die("Use 'perltidy -b $input_file' to modify in-place\n");
}
}
else {
Die("You may not use -o with more than one input file\n");
}
}
elsif ( $rOpts->{'standard-output'} ) {
if ($destination_stream) {
my $msg =
"You may not specify a destination array and -st together\n";
$msg .= " (-pbp contains -st; see manual)" if ($saw_pbp);
Die("$msg\n");
}
$output_file = '-';
if ( $number_of_files <= 1 ) {
}
else {
Die("You may not use -st with more than one input file\n");
}
}
elsif ($destination_stream) {
$output_file = $destination_stream;
}
elsif ($source_stream) { # source but no destination goes to stdout
$output_file = '-';
}
elsif ( $input_file eq '-' ) {
$output_file = '-';
}
else {
if ($in_place_modify) {
$output_file = IO::File->new_tmpfile()
or Die("cannot open temp file for -b option: $!\n");
}
else {
$actual_output_extension = $output_extension;
$output_file = $fileroot . $output_extension;
}
}
my $fh_tee;
my $tee_file = $fileroot . $dot . "TEE";
if ($teefile_stream) { $tee_file = $teefile_stream }
if ( $rOpts->{'tee-pod'}
|| $rOpts->{'tee-block-comments'}
|| $rOpts->{'tee-side-comments'} )
{
( $fh_tee, my $tee_filename ) =
Perl::Tidy::streamhandle( $tee_file, 'w', $is_encoded_data );
if ( !$fh_tee ) {
Warn("couldn't open TEE file $tee_file: $!\n");
}
}
my $line_separator = $rOpts->{'output-line-ending'};
if ( $rOpts->{'preserve-line-endings'} ) {
$line_separator = find_input_line_ending($input_file);
}
$line_separator = "\n" unless defined($line_separator);
# the 'sink_object' knows how to write the output file
my ( $sink_object, $postfilter_buffer );
my $use_buffer =
$postfilter
|| $remove_terminal_newline
|| $rOpts->{'assert-tidy'}
|| $rOpts->{'assert-untidy'};
$sink_object = Perl::Tidy::LineSink->new(
output_file => $use_buffer ? \$postfilter_buffer : $output_file,
line_separator => $line_separator,
rOpts => $rOpts,
rpending_logfile_message => $rpending_logfile_message,
is_encoded_data => $is_encoded_data,
);
#---------------------------------------------------------------
# initialize the error logger for this file
#---------------------------------------------------------------
my $warning_file = $fileroot . $dot . "ERR";
if ($errorfile_stream) { $warning_file = $errorfile_stream }
my $log_file = $fileroot . $dot . "LOG";
if ($logfile_stream) { $log_file = $logfile_stream }
my $logger_object = Perl::Tidy::Logger->new(
rOpts => $rOpts,
log_file => $log_file,
warning_file => $warning_file,
fh_stderr => $fh_stderr,
saw_extruce => $saw_extrude,
display_name => $display_name,
is_encoded_data => $is_encoded_data,
);
write_logfile_header(
$rOpts, $logger_object, $config_file,
$rraw_options, $Windows_type, $readable_options,
);
$logger_object->write_logfile_entry($encoding_log_message)
if $encoding_log_message;
if ( ${$rpending_logfile_message} ) {
$logger_object->write_logfile_entry( ${$rpending_logfile_message} );
}
if ( ${$rpending_complaint} ) {
$logger_object->complain( ${$rpending_complaint} );
}
#---------------------------------------------------------------
# initialize the debug object, if any
#---------------------------------------------------------------
my $debugger_object = undef;
if ( $rOpts->{DEBUG} ) {
my $debug_file = $fileroot . $dot . "DEBUG";
if ($debugfile_stream) { $debug_file = $debugfile_stream }
$debugger_object =
Perl::Tidy::Debugger->new( $debug_file, $is_encoded_data );
}
#---------------------------------------------------------------
# loop over iterations for one source stream
#---------------------------------------------------------------
# save objects to allow redirecting output during iterations
my $sink_object_final = $sink_object;
my $debugger_object_final = $debugger_object;
my $logger_object_final = $logger_object;
my $fh_tee_final = $fh_tee;
my $iteration_of_formatter_convergence;
foreach my $iter ( 1 .. $max_iterations ) {
# send output stream to temp buffers until last iteration
my $sink_buffer;
if ( $iter < $max_iterations ) {
$sink_object = Perl::Tidy::LineSink->new(
output_file => \$sink_buffer,
line_separator => $line_separator,
rOpts => $rOpts,
rpending_logfile_message => $rpending_logfile_message,
is_encoded_data => $is_encoded_data,
);
}
else {
$sink_object = $sink_object_final;
}
# Save logger, debugger and tee output only on pass 1 because:
# (1) line number references must be to the starting
# source, not an intermediate result, and
# (2) we need to know if there are errors so we can stop the
# iterations early if necessary.
# (3) the tee option only works on first pass if comments are also
# being deleted.
if ( $iter > 1 ) {
$debugger_object = undef;
$logger_object = undef;
$fh_tee = undef;
}
#------------------------------------------------------------
# create a formatter for this file : html writer or
# pretty printer
#------------------------------------------------------------
# we have to delete any old formatter because, for safety,
# the formatter will check to see that there is only one.
$formatter = undef;
if ($user_formatter) {
$formatter = $user_formatter;
}
elsif ( $rOpts->{'format'} eq 'html' ) {
$formatter = Perl::Tidy::HtmlWriter->new(
input_file => $fileroot,
html_file => $output_file,
extension => $actual_output_extension,
html_toc_extension => $html_toc_extension,
html_src_extension => $html_src_extension,
);
}
elsif ( $rOpts->{'format'} eq 'tidy' ) {
$formatter = Perl::Tidy::Formatter->new(
logger_object => $logger_object,
diagnostics_object => $diagnostics_object,
sink_object => $sink_object,
length_function => $length_function,
is_encoded_data => $is_encoded_data,
fh_tee => $fh_tee,
);
}
else {
Die("I don't know how to do -format=$rOpts->{'format'}\n");
}
unless ($formatter) {
Die("Unable to continue with $rOpts->{'format'} formatting\n");
}
#---------------------------------------------------------------
# create the tokenizer for this file
#---------------------------------------------------------------
$tokenizer = undef; # must destroy old tokenizer
$tokenizer = Perl::Tidy::Tokenizer->new(
source_object => $source_object,
logger_object => $logger_object,
debugger_object => $debugger_object,
diagnostics_object => $diagnostics_object,
tabsize => $tabsize,
rOpts => $rOpts,
starting_level => $rOpts->{'starting-indentation-level'},
indent_columns => $rOpts->{'indent-columns'},
look_for_hash_bang => $rOpts->{'look-for-hash-bang'},
look_for_autoloader => $rOpts->{'look-for-autoloader'},
look_for_selfloader => $rOpts->{'look-for-selfloader'},
trim_qw => $rOpts->{'trim-qw'},
extended_syntax => $rOpts->{'extended-syntax'},
continuation_indentation =>
$rOpts->{'continuation-indentation'},
outdent_labels => $rOpts->{'outdent-labels'},
);
#---------------------------------------------------------------
# now we can do it
#---------------------------------------------------------------
process_this_file( $tokenizer, $formatter );
#---------------------------------------------------------------
# close the input source and report errors
#---------------------------------------------------------------
$source_object->close_input_file();
# see if the formatter is converged
if ( $max_iterations > 1
&& !defined($iteration_of_formatter_convergence)
&& $formatter->can('get_convergence_check') )
{
if ( $formatter->get_convergence_check() ) {
$iteration_of_formatter_convergence = $iter;
}
}
# line source for next iteration (if any) comes from the current
# temporary output buffer
if ( $iter < $max_iterations ) {
$sink_object->close_output_file();
$source_object = Perl::Tidy::LineSource->new(
input_file => \$sink_buffer,
rOpts => $rOpts,
rpending_logfile_message => $rpending_logfile_message,
);
# stop iterations if errors or converged
my $stop_now = $tokenizer->report_tokenization_errors();
$stop_now ||= $tokenizer->get_unexpected_error_count();
my $stopping_on_error = $stop_now;
if ($stop_now) {
$convergence_log_message = <($sink_buffer);
if ( !defined( $saw_md5{$digest} ) ) {
$saw_md5{$digest} = $iter;
}
else {
# Deja vu, stop iterating
$stop_now = 1;
my $iterm = $iter - 1;
if ( $saw_md5{$digest} != $iterm ) {
# Blinking (oscillating) between two or more stable
# end states. This is unlikely to occur with normal
# parameters, but it can occur in stress testing
# with extreme parameter values, such as very short
# maximum line lengths. We want to catch and fix
# them when they happen.
$convergence_log_message = <write_diagnostics(
$convergence_log_message)
if $diagnostics_object;
# Uncomment to search for blinking states
# Warn( "$display_name: blinking; iter $iter same as for $saw_md5{$digest}\n" );
}
else {
$convergence_log_message = <write_diagnostics(
$convergence_log_message)
if $diagnostics_object && $iterm > 2;
}
}
} ## end if ($do_convergence_test)
if ($stop_now) {
if (DEVEL_MODE) {
if ( defined($iteration_of_formatter_convergence) ) {
# This message cannot appear unless the formatter
# convergence test above is temporarily skipped for
# testing.
if ( $iteration_of_formatter_convergence <
$iter - 1 )
{
print STDERR
"STRANGE Early conv in $display_name: Stopping on it=$iter, converged in formatter on $iteration_of_formatter_convergence\n";
}
}
elsif ( !$stopping_on_error ) {
print STDERR
"STRANGE no conv in $display_name: stopping on it=$iter, but not converged in formatter\n";
}
}
# we are stopping the iterations early;
# copy the output stream to its final destination
$sink_object = $sink_object_final;
while ( my $line = $source_object->get_line() ) {
$sink_object->write_line($line);
}
$source_object->close_input_file();
last;
}
} ## end if ( $iter < $max_iterations)
} # end loop over iterations for one source file
# restore objects which have been temporarily undefined
# for second and higher iterations
$debugger_object = $debugger_object_final;
$logger_object = $logger_object_final;
$fh_tee = $fh_tee_final;
$logger_object->write_logfile_entry($convergence_log_message)
if $convergence_log_message;
#---------------------------------------------------------------
# Perform any postfilter operation
#---------------------------------------------------------------
if ($use_buffer) {
$sink_object->close_output_file();
$sink_object = Perl::Tidy::LineSink->new(
output_file => $output_file,
line_separator => $line_separator,
rOpts => $rOpts,
rpending_logfile_message => $rpending_logfile_message,
is_encoded_data => $is_encoded_data,
);
my $buf =
$postfilter
? $postfilter->($postfilter_buffer)
: $postfilter_buffer;
# Check if file changed if requested, but only after any postfilter
if ( $rOpts->{'assert-tidy'} ) {
my $digest_output = $md5_hex->($buf);
if ( $digest_output ne $digest_input ) {
my $diff_msg =
compare_string_buffers( $saved_input_buf, $buf,
$is_encoded_data );
$logger_object->warning(<interrupt_logfile();
$logger_object->warning( $diff_msg . "\n" );
$logger_object->resume_logfile();
## $Warn_count ||= 1; # logger warning does this now
}
}
if ( $rOpts->{'assert-untidy'} ) {
my $digest_output = $md5_hex->($buf);
if ( $digest_output eq $digest_input ) {
$logger_object->warning(
"assertion failure: '--assert-untidy' is set but output equals input\n"
);
## $Warn_count ||= 1; # logger warning does this now
}
}
$source_object = Perl::Tidy::LineSource->new(
input_file => \$buf,
rOpts => $rOpts,
rpending_logfile_message => $rpending_logfile_message,
);
# Copy the filtered buffer to the final destination
if ( !$remove_terminal_newline ) {
while ( my $line = $source_object->get_line() ) {
$sink_object->write_line($line);
}
}
else {
# Copy the filtered buffer but remove the newline char from the
# final line
my $line;
while ( my $next_line = $source_object->get_line() ) {
$sink_object->write_line($line) if ($line);
$line = $next_line;
}
if ($line) {
$sink_object->set_line_separator(undef);
chomp $line;
$sink_object->write_line($line);
}
}
$source_object->close_input_file();
}
# Save names of the input and output files for syntax check
my $ifname = $input_file;
my $ofname = $output_file;
#---------------------------------------------------------------
# handle the -b option (backup and modify in-place)
#---------------------------------------------------------------
if ($in_place_modify) {
unless ( -f $input_file ) {
# oh, oh, no real file to backup ..
# shouldn't happen because of numerous preliminary checks
Die(
"problem with -b backing up input file '$input_file': not a file\n"
);
}
my $backup_name = $input_file . $backup_extension;
if ( -f $backup_name ) {
unlink($backup_name)
or Die(
"unable to remove previous '$backup_name' for -b option; check permissions: $!\n"
);
}
# backup the input file
# we use copy for symlinks, move for regular files
if ( -l $input_file ) {
File::Copy::copy( $input_file, $backup_name )
or Die("File::Copy failed trying to backup source: $!");
}
else {
rename( $input_file, $backup_name )
or Die(
"problem renaming $input_file to $backup_name for -b option: $!\n"
);
}
$ifname = $backup_name;
# copy the output to the original input file
# NOTE: it would be nice to just close $output_file and use
# File::Copy::copy here, but in this case $output_file is the
# handle of an open nameless temporary file so we would lose
# everything if we closed it.
seek( $output_file, 0, 0 )
or Die("unable to rewind a temporary file for -b option: $!\n");
my ( $fout, $iname ) =
Perl::Tidy::streamhandle( $input_file, 'w', $is_encoded_data );
if ( !$fout ) {
Die(
"problem re-opening $input_file for write for -b option; check file and directory permissions: $!\n"
);
}
my $line;
while ( $line = $output_file->getline() ) {
$fout->print($line);
}
$fout->close();
$output_file = $input_file;
$ofname = $input_file;
}
#---------------------------------------------------------------
# clean up and report errors
#---------------------------------------------------------------
$sink_object->close_output_file() if $sink_object;
$debugger_object->close_debug_file() if $debugger_object;
# set output file permissions
if ( $output_file && -f $output_file && !-l $output_file ) {
if (@input_file_stat) {
# Set file ownership and permissions
if ( $rOpts->{'format'} eq 'tidy' ) {
my ( $mode_i, $uid_i, $gid_i ) =
@input_file_stat[ 2, 4, 5 ];
my ( $uid_o, $gid_o ) = ( stat($output_file) )[ 4, 5 ];
my $input_file_permissions = $mode_i & oct(7777);
my $output_file_permissions = $input_file_permissions;
#rt128477: avoid inconsistent owner/group and suid/sgid
if ( $uid_i != $uid_o || $gid_i != $gid_o ) {
# try to change owner and group to match input file if
# in -b mode. Note: chown returns number of files
# successfully changed.
if ( $in_place_modify
&& chown( $uid_i, $gid_i, $output_file ) )
{
# owner/group successfully changed
}
else {
# owner or group differ: do not copy suid and sgid
$output_file_permissions = $mode_i & oct(777);
if ( $input_file_permissions !=
$output_file_permissions )
{
Warn(
"Unable to copy setuid and/or setgid bits for output file '$output_file'\n"
);
}
}
}
# Make the output file for rw unless we are in -b mode.
# Explanation: perltidy does not unlink existing output
# files before writing to them, for safety. If a
# designated output file exists and is not writable,
# perltidy will halt. This can prevent a data loss if a
# user accidentally enters "perltidy infile -o
# important_ro_file", or "perltidy infile -st
# >important_ro_file". But it also means that perltidy can
# get locked out of rerunning unless it marks its own
# output files writable. The alternative, of always
# unlinking the designated output file, is less safe and
# not always possible, except in -b mode, where there is an
# assumption that a previous backup can be unlinked even if
# not writable.
if ( !$in_place_modify ) {
$output_file_permissions |= oct(600);
}
if ( !chmod( $output_file_permissions, $output_file ) ) {
# couldn't change file permissions
my $operm = sprintf "%04o", $output_file_permissions;
Warn(
"Unable to set permissions for output file '$output_file' to $operm\n"
);
}
}
# else use default permissions for html and any other format
}
}
#---------------------------------------------------------------
# Do syntax check if requested and possible
# This is permanently deactivated but the code remains for reference
#---------------------------------------------------------------
my $infile_syntax_ok = 0; # -1 no 0=don't know 1 yes
if ( 0
&& $logger_object
&& $rOpts->{'check-syntax'}
&& $ifname
&& $ofname )
{
$infile_syntax_ok =
check_syntax( $ifname, $ofname, $logger_object, $rOpts );
}
#---------------------------------------------------------------
# remove the original file for in-place modify as follows:
# $delete_backup=0 never
# $delete_backup=1 only if no errors
# $delete_backup>1 always : NOT ALLOWED, too risky, see above
#---------------------------------------------------------------
if ( $in_place_modify
&& $delete_backup
&& -f $ifname
&& ( $delete_backup > 1 || !$logger_object->get_warning_count() ) )
{
# As an added safety precaution, do not delete the source file
# if its size has dropped from positive to zero, since this
# could indicate a disaster of some kind, including a hardware
# failure. Actually, this could happen if you had a file of
# all comments (or pod) and deleted everything with -dac (-dap)
# for some reason.
if ( !-s $output_file && -s $ifname && $delete_backup == 1 ) {
Warn(
"output file '$output_file' missing or zero length; original '$ifname' not deleted\n"
);
}
else {
unlink($ifname)
or Die(
"unable to remove previous '$ifname' for -b option; check permissions: $!\n"
);
}
}
$logger_object->finish( $infile_syntax_ok, $formatter )
if $logger_object;
} # end of main loop to process all files
# Fix for RT #130297: return a true value if anything was written to the
# standard error output, even non-fatal warning messages, otherwise return
# false.
# These exit codes are returned:
# 0 = perltidy ran to completion with no errors
# 1 = perltidy could not run to completion due to errors
# 2 = perltidy ran to completion with error messages
# Note that if perltidy is run with multiple files, any single file with
# errors or warnings will write a line like
# '## Please see file testing.t.ERR'
# to standard output for each file with errors, so the flag will be true,
# even if only some of the multiple files may have had errors.
NORMAL_EXIT:
my $ret = $Warn_count ? 2 : 0;
return $ret;
ERROR_EXIT:
return 1;
} ## end of main program perltidy
} ## end of closure for sub perltidy
sub line_diff {
# Given two strings, return
# $diff_marker = a string with carat (^) symbols indicating differences
# $pos1 = character position of first difference; pos1=-1 if no difference
# Form exclusive or of the strings, which has null characters where strings
# have same common characters so non-null characters indicate character
# differences.
my ( $s1, $s2 ) = @_;
my $diff_marker = "";
my $pos = -1;
my $pos1 = $pos;
if ( defined($s1) && defined($s2) ) {
my $count = 0;
my $mask = $s1 ^ $s2;
while ( $mask =~ /[^\0]/g ) {
$count++;
my $pos_last = $pos;
$pos = $-[0];
if ( $count == 1 ) { $pos1 = $pos; }
$diff_marker .= ' ' x ( $pos - $pos_last - 1 ) . '^';
# we could continue to mark all differences, but there is no point
last;
}
}
return wantarray ? ( $diff_marker, $pos1 ) : $diff_marker;
}
sub compare_string_buffers {
# Compare input and output string buffers and return a brief text
# description of the first difference.
my ( $bufi, $bufo, $is_encoded_data ) = @_;
my $leni = length($bufi);
my $leno = defined($bufo) ? length($bufo) : 0;
my $msg =
"Input file length is $leni chars\nOutput file length is $leno chars\n";
return $msg unless $leni && $leno;
my ( $fhi, $fnamei ) = streamhandle( \$bufi, 'r', $is_encoded_data );
my ( $fho, $fnameo ) = streamhandle( \$bufo, 'r', $is_encoded_data );
return $msg unless ( $fho && $fhi ); # for safety, shouldn't happen
my ( $linei, $lineo );
my ( $counti, $counto ) = ( 0, 0 );
my ( $last_nonblank_line, $last_nonblank_count ) = ( "", 0 );
my $truncate = sub {
my ( $str, $lenmax ) = @_;
if ( length($str) > $lenmax ) {
$str = substr( $str, 0, $lenmax ) . "...";
}
return $str;
};
while (1) {
if ($linei) {
$last_nonblank_line = $linei;
$last_nonblank_count = $counti;
}
$linei = $fhi->getline();
$lineo = $fho->getline();
# compare chomp'ed lines
if ( defined($linei) ) { $counti++; chomp $linei }
if ( defined($lineo) ) { $counto++; chomp $lineo }
# see if one or both ended before a difference
last unless ( defined($linei) && defined($lineo) );
next if ( $linei eq $lineo );
# lines differ ...
my ( $line_diff, $pos1 ) = line_diff( $linei, $lineo );
my $reason = "Files first differ at character $pos1 of line $counti";
my ( $leading_ws_i, $leading_ws_o ) = ( "", "" );
if ( $linei =~ /^(\s+)/ ) { $leading_ws_i = $1; }
if ( $lineo =~ /^(\s+)/ ) { $leading_ws_o = $1; }
if ( $leading_ws_i ne $leading_ws_o ) {
$reason .= "; leading whitespace differs";
if ( $leading_ws_i =~ /\t/ ) {
$reason .= "; input has tab char";
}
}
else {
my ( $trailing_ws_i, $trailing_ws_o ) = ( "", "" );
if ( $linei =~ /(\s+)$/ ) { $trailing_ws_i = $1; }
if ( $lineo =~ /(\s+)$/ ) { $trailing_ws_o = $1; }
if ( $trailing_ws_i ne $trailing_ws_o ) {
$reason .= "; trailing whitespace differs";
}
}
$msg .= $reason . "\n";
# limit string display length
if ( $pos1 > 60 ) {
my $drop = $pos1 - 40;
$linei = "..." . substr( $linei, $drop );
$lineo = "..." . substr( $lineo, $drop );
$line_diff = " " . substr( $line_diff, $drop );
}
$linei = $truncate->( $linei, 72 );
$lineo = $truncate->( $lineo, 72 );
$last_nonblank_line = $truncate->( $last_nonblank_line, 72 );
if ($last_nonblank_line) {
my $countm = $counti - 1;
$msg .= <$counto:$lineo
$line_diff
EOM
return $msg;
} ## end while
# no line differences found, but one file may have fewer lines
if ( $counti > $counto ) {
$msg .= <getline() ) {
$fout->print($line);
}
$fout->close();
}
$fh_stream->close();
}
}
elsif ( $stream ne '-' && -f $stream ) {
$fname = $stream;
}
}
return ( $fname, $is_tmpfile );
}
sub fileglob_to_re {
# modified (corrected) from version in find2perl
my $x = shift;
$x =~ s#([./^\$()])#\\$1#g; # escape special characters
$x =~ s#\*#.*#g; # '*' -> '.*'
$x =~ s#\?#.#g; # '?' -> '.'
return "^$x\\z"; # match whole word
}
sub make_extension {
# Make a file extension, including any leading '.' if necessary
# The '.' may actually be an '_' under VMS
my ( $extension, $default, $dot ) = @_;
# Use the default if none specified
$extension = $default unless ($extension);
# Only extensions with these leading characters get a '.'
# This rule gives the user some freedom
if ( $extension =~ /^[a-zA-Z0-9]/ ) {
$extension = $dot . $extension;
}
return $extension;
}
sub write_logfile_header {
my (
$rOpts, $logger_object, $config_file,
$rraw_options, $Windows_type, $readable_options
) = @_;
$logger_object->write_logfile_entry(
"perltidy version $VERSION log file on a $^O system, OLD_PERL_VERSION=$]\n"
);
if ($Windows_type) {
$logger_object->write_logfile_entry("Windows type is $Windows_type\n");
}
my $options_string = join( ' ', @{$rraw_options} );
if ($config_file) {
$logger_object->write_logfile_entry(
"Found Configuration File >>> $config_file \n");
}
$logger_object->write_logfile_entry(
"Configuration and command line parameters for this run:\n");
$logger_object->write_logfile_entry("$options_string\n");
if ( $rOpts->{'DEBUG'} || $rOpts->{'show-options'} ) {
$rOpts->{'logfile'} = 1; # force logfile to be saved
$logger_object->write_logfile_entry(
"Final parameter set for this run\n");
$logger_object->write_logfile_entry(
"------------------------------------\n");
$logger_object->write_logfile_entry($readable_options);
$logger_object->write_logfile_entry(
"------------------------------------\n");
}
$logger_object->write_logfile_entry(
"To find error messages search for 'WARNING' with your editor\n");
return;
}
sub generate_options {
######################################################################
# Generate and return references to:
# @option_string - the list of options to be passed to Getopt::Long
# @defaults - the list of default options
# %expansion - a hash showing how all abbreviations are expanded
# %category - a hash giving the general category of each option
# %option_range - a hash giving the valid ranges of certain options
# Note: a few options are not documented in the man page and usage
# message. This is because these are experimental or debug options and
# may or may not be retained in future versions.
#
# Here are the undocumented flags as far as I know. Any of them
# may disappear at any time. They are mainly for fine-tuning
# and debugging.
#
# fll --> fuzzy-line-length # a trivial parameter which gets
# turned off for the extrude option
# which is mainly for debugging
# scl --> short-concatenation-item-length # helps break at '.'
# recombine # for debugging line breaks
# valign # for debugging vertical alignment
# I --> DIAGNOSTICS # for debugging [**DEACTIVATED**]
######################################################################
# here is a summary of the Getopt codes:
# does not take an argument
# =s takes a mandatory string
# :s takes an optional string (DO NOT USE - filenames will get eaten up)
# =i takes a mandatory integer
# :i takes an optional integer (NOT RECOMMENDED - can cause trouble)
# ! does not take an argument and may be negated
# i.e., -foo and -nofoo are allowed
# a double dash signals the end of the options list
#
#---------------------------------------------------------------
# Define the option string passed to GetOptions.
#---------------------------------------------------------------
my @option_string = ();
my %expansion = ();
my %option_category = ();
my %option_range = ();
my $rexpansion = \%expansion;
# names of categories in manual
# leading integers will allow sorting
my @category_name = (
'0. I/O control',
'1. Basic formatting options',
'2. Code indentation control',
'3. Whitespace control',
'4. Comment controls',
'5. Linebreak controls',
'6. Controlling list formatting',
'7. Retaining or ignoring existing line breaks',
'8. Blank line control',
'9. Other controls',
'10. HTML options',
'11. pod2html options',
'12. Controlling HTML properties',
'13. Debugging',
);
# These options are parsed directly by perltidy:
# help h
# version v
# However, they are included in the option set so that they will
# be seen in the options dump.
# These long option names have no abbreviations or are treated specially
@option_string = qw(
html!
noprofile
no-profile
npro
recombine!
valign!
notidy
);
my $category = 13; # Debugging
foreach (@option_string) {
my $opt = $_; # must avoid changing the actual flag
$opt =~ s/!$//;
$option_category{$opt} = $category_name[$category];
}
$category = 11; # HTML
$option_category{html} = $category_name[$category];
# routine to install and check options
my $add_option = sub {
my ( $long_name, $short_name, $flag ) = @_;
push @option_string, $long_name . $flag;
$option_category{$long_name} = $category_name[$category];
if ($short_name) {
if ( $expansion{$short_name} ) {
my $existing_name = $expansion{$short_name}[0];
Die(
"redefining abbreviation $short_name for $long_name; already used for $existing_name\n"
);
}
$expansion{$short_name} = [$long_name];
if ( $flag eq '!' ) {
my $nshort_name = 'n' . $short_name;
my $nolong_name = 'no' . $long_name;
if ( $expansion{$nshort_name} ) {
my $existing_name = $expansion{$nshort_name}[0];
Die(
"attempting to redefine abbreviation $nshort_name for $nolong_name; already used for $existing_name\n"
);
}
$expansion{$nshort_name} = [$nolong_name];
}
}
};
# Install long option names which have a simple abbreviation.
# Options with code '!' get standard negation ('no' for long names,
# 'n' for abbreviations). Categories follow the manual.
###########################
$category = 0; # I/O_Control
###########################
$add_option->( 'backup-and-modify-in-place', 'b', '!' );
$add_option->( 'backup-file-extension', 'bext', '=s' );
$add_option->( 'character-encoding', 'enc', '=s' );
$add_option->( 'force-read-binary', 'f', '!' );
$add_option->( 'format', 'fmt', '=s' );
$add_option->( 'iterations', 'it', '=i' );
$add_option->( 'logfile', 'log', '!' );
$add_option->( 'logfile-gap', 'g', ':i' );
$add_option->( 'outfile', 'o', '=s' );
$add_option->( 'output-file-extension', 'oext', '=s' );
$add_option->( 'output-path', 'opath', '=s' );
$add_option->( 'profile', 'pro', '=s' );
$add_option->( 'quiet', 'q', '!' );
$add_option->( 'standard-error-output', 'se', '!' );
$add_option->( 'standard-output', 'st', '!' );
$add_option->( 'use-unicode-gcstring', 'gcs', '!' );
$add_option->( 'warning-output', 'w', '!' );
$add_option->( 'add-terminal-newline', 'atnl', '!' );
# options which are both toggle switches and values moved here
# to hide from tidyview (which does not show category 0 flags):
# -ole moved here from category 1
# -sil moved here from category 2
$add_option->( 'output-line-ending', 'ole', '=s' );
$add_option->( 'starting-indentation-level', 'sil', '=i' );
########################################
$category = 1; # Basic formatting options
########################################
$add_option->( 'check-syntax', 'syn', '!' );
$add_option->( 'entab-leading-whitespace', 'et', '=i' );
$add_option->( 'indent-columns', 'i', '=i' );
$add_option->( 'maximum-line-length', 'l', '=i' );
$add_option->( 'variable-maximum-line-length', 'vmll', '!' );
$add_option->( 'whitespace-cycle', 'wc', '=i' );
$add_option->( 'perl-syntax-check-flags', 'pscf', '=s' );
$add_option->( 'preserve-line-endings', 'ple', '!' );
$add_option->( 'tabs', 't', '!' );
$add_option->( 'default-tabsize', 'dt', '=i' );
$add_option->( 'extended-syntax', 'xs', '!' );
$add_option->( 'assert-tidy', 'ast', '!' );
$add_option->( 'assert-untidy', 'asu', '!' );
$add_option->( 'sub-alias-list', 'sal', '=s' );
########################################
$category = 2; # Code indentation control
########################################
$add_option->( 'continuation-indentation', 'ci', '=i' );
$add_option->( 'extended-continuation-indentation', 'xci', '!' );
$add_option->( 'line-up-parentheses', 'lp', '!' );
$add_option->( 'line-up-parentheses-exclusion-list', 'lpxl', '=s' );
$add_option->( 'outdent-keyword-list', 'okwl', '=s' );
$add_option->( 'outdent-keywords', 'okw', '!' );
$add_option->( 'outdent-labels', 'ola', '!' );
$add_option->( 'outdent-long-quotes', 'olq', '!' );
$add_option->( 'indent-closing-brace', 'icb', '!' );
$add_option->( 'closing-token-indentation', 'cti', '=i' );
$add_option->( 'closing-paren-indentation', 'cpi', '=i' );
$add_option->( 'closing-brace-indentation', 'cbi', '=i' );
$add_option->( 'closing-square-bracket-indentation', 'csbi', '=i' );
$add_option->( 'brace-left-and-indent', 'bli', '!' );
$add_option->( 'brace-left-and-indent-list', 'blil', '=s' );
########################################
$category = 3; # Whitespace control
########################################
$add_option->( 'add-semicolons', 'asc', '!' );
$add_option->( 'add-whitespace', 'aws', '!' );
$add_option->( 'block-brace-tightness', 'bbt', '=i' );
$add_option->( 'brace-tightness', 'bt', '=i' );
$add_option->( 'delete-old-whitespace', 'dws', '!' );
$add_option->( 'delete-semicolons', 'dsm', '!' );
$add_option->( 'function-paren-vertical-alignment', 'fpva', '!' );
$add_option->( 'keyword-paren-inner-tightness', 'kpit', '=i' );
$add_option->( 'keyword-paren-inner-tightness-list', 'kpitl', '=s' );
$add_option->( 'logical-padding', 'lop', '!' );
$add_option->( 'nospace-after-keyword', 'nsak', '=s' );
$add_option->( 'nowant-left-space', 'nwls', '=s' );
$add_option->( 'nowant-right-space', 'nwrs', '=s' );
$add_option->( 'paren-tightness', 'pt', '=i' );
$add_option->( 'space-after-keyword', 'sak', '=s' );
$add_option->( 'space-for-semicolon', 'sfs', '!' );
$add_option->( 'space-function-paren', 'sfp', '!' );
$add_option->( 'space-keyword-paren', 'skp', '!' );
$add_option->( 'space-terminal-semicolon', 'sts', '!' );
$add_option->( 'square-bracket-tightness', 'sbt', '=i' );
$add_option->( 'square-bracket-vertical-tightness', 'sbvt', '=i' );
$add_option->( 'square-bracket-vertical-tightness-closing', 'sbvtc', '=i' );
$add_option->( 'tight-secret-operators', 'tso', '!' );
$add_option->( 'trim-qw', 'tqw', '!' );
$add_option->( 'trim-pod', 'trp', '!' );
$add_option->( 'want-left-space', 'wls', '=s' );
$add_option->( 'want-right-space', 'wrs', '=s' );
$add_option->( 'space-prototype-paren', 'spp', '=i' );
########################################
$category = 4; # Comment controls
########################################
$add_option->( 'closing-side-comment-else-flag', 'csce', '=i' );
$add_option->( 'closing-side-comment-interval', 'csci', '=i' );
$add_option->( 'closing-side-comment-list', 'cscl', '=s' );
$add_option->( 'closing-side-comment-maximum-text', 'csct', '=i' );
$add_option->( 'closing-side-comment-prefix', 'cscp', '=s' );
$add_option->( 'closing-side-comment-warnings', 'cscw', '!' );
$add_option->( 'closing-side-comments', 'csc', '!' );
$add_option->( 'closing-side-comments-balanced', 'cscb', '!' );
$add_option->( 'code-skipping', 'cs', '!' );
$add_option->( 'code-skipping-begin', 'csb', '=s' );
$add_option->( 'code-skipping-end', 'cse', '=s' );
$add_option->( 'format-skipping', 'fs', '!' );
$add_option->( 'format-skipping-begin', 'fsb', '=s' );
$add_option->( 'format-skipping-end', 'fse', '=s' );
$add_option->( 'hanging-side-comments', 'hsc', '!' );
$add_option->( 'indent-block-comments', 'ibc', '!' );
$add_option->( 'indent-spaced-block-comments', 'isbc', '!' );
$add_option->( 'fixed-position-side-comment', 'fpsc', '=i' );
$add_option->( 'minimum-space-to-comment', 'msc', '=i' );
$add_option->( 'non-indenting-braces', 'nib', '!' );
$add_option->( 'non-indenting-brace-prefix', 'nibp', '=s' );
$add_option->( 'outdent-long-comments', 'olc', '!' );
$add_option->( 'outdent-static-block-comments', 'osbc', '!' );
$add_option->( 'static-block-comment-prefix', 'sbcp', '=s' );
$add_option->( 'static-block-comments', 'sbc', '!' );
$add_option->( 'static-side-comment-prefix', 'sscp', '=s' );
$add_option->( 'static-side-comments', 'ssc', '!' );
$add_option->( 'ignore-side-comment-lengths', 'iscl', '!' );
########################################
$category = 5; # Linebreak controls
########################################
$add_option->( 'add-newlines', 'anl', '!' );
$add_option->( 'block-brace-vertical-tightness', 'bbvt', '=i' );
$add_option->( 'block-brace-vertical-tightness-list', 'bbvtl', '=s' );
$add_option->( 'brace-vertical-tightness', 'bvt', '=i' );
$add_option->( 'brace-vertical-tightness-closing', 'bvtc', '=i' );
$add_option->( 'cuddled-else', 'ce', '!' );
$add_option->( 'cuddled-block-list', 'cbl', '=s' );
$add_option->( 'cuddled-block-list-exclusive', 'cblx', '!' );
$add_option->( 'cuddled-break-option', 'cbo', '=i' );
$add_option->( 'delete-old-newlines', 'dnl', '!' );
$add_option->( 'opening-brace-always-on-right', 'bar', '!' );
$add_option->( 'opening-brace-on-new-line', 'bl', '!' );
$add_option->( 'opening-hash-brace-right', 'ohbr', '!' );
$add_option->( 'opening-paren-right', 'opr', '!' );
$add_option->( 'opening-square-bracket-right', 'osbr', '!' );
$add_option->( 'opening-anonymous-sub-brace-on-new-line', 'asbl', '!' );
$add_option->( 'opening-sub-brace-on-new-line', 'sbl', '!' );
$add_option->( 'paren-vertical-tightness', 'pvt', '=i' );
$add_option->( 'paren-vertical-tightness-closing', 'pvtc', '=i' );
$add_option->( 'weld-nested-containers', 'wn', '!' );
$add_option->( 'weld-nested-exclusion-list', 'wnxl', '=s' );
$add_option->( 'space-backslash-quote', 'sbq', '=i' );
$add_option->( 'stack-closing-block-brace', 'scbb', '!' );
$add_option->( 'stack-closing-hash-brace', 'schb', '!' );
$add_option->( 'stack-closing-paren', 'scp', '!' );
$add_option->( 'stack-closing-square-bracket', 'scsb', '!' );
$add_option->( 'stack-opening-hash-brace', 'sohb', '!' );
$add_option->( 'stack-opening-paren', 'sop', '!' );
$add_option->( 'stack-opening-square-bracket', 'sosb', '!' );
$add_option->( 'vertical-tightness', 'vt', '=i' );
$add_option->( 'vertical-tightness-closing', 'vtc', '=i' );
$add_option->( 'want-break-after', 'wba', '=s' );
$add_option->( 'want-break-before', 'wbb', '=s' );
$add_option->( 'break-after-all-operators', 'baao', '!' );
$add_option->( 'break-before-all-operators', 'bbao', '!' );
$add_option->( 'keep-interior-semicolons', 'kis', '!' );
$add_option->( 'one-line-block-semicolons', 'olbs', '=i' );
$add_option->( 'one-line-block-nesting', 'olbn', '=i' );
$add_option->( 'break-before-hash-brace', 'bbhb', '=i' );
$add_option->( 'break-before-hash-brace-and-indent', 'bbhbi', '=i' );
$add_option->( 'break-before-square-bracket', 'bbsb', '=i' );
$add_option->( 'break-before-square-bracket-and-indent', 'bbsbi', '=i' );
$add_option->( 'break-before-paren', 'bbp', '=i' );
$add_option->( 'break-before-paren-and-indent', 'bbpi', '=i' );
########################################
$category = 6; # Controlling list formatting
########################################
$add_option->( 'break-at-old-comma-breakpoints', 'boc', '!' );
$add_option->( 'comma-arrow-breakpoints', 'cab', '=i' );
$add_option->( 'maximum-fields-per-table', 'mft', '=i' );
########################################
$category = 7; # Retaining or ignoring existing line breaks
########################################
$add_option->( 'break-at-old-keyword-breakpoints', 'bok', '!' );
$add_option->( 'break-at-old-logical-breakpoints', 'bol', '!' );
$add_option->( 'break-at-old-method-breakpoints', 'bom', '!' );
$add_option->( 'break-at-old-semicolon-breakpoints', 'bos', '!' );
$add_option->( 'break-at-old-ternary-breakpoints', 'bot', '!' );
$add_option->( 'break-at-old-attribute-breakpoints', 'boa', '!' );
$add_option->( 'keep-old-breakpoints-before', 'kbb', '=s' );
$add_option->( 'keep-old-breakpoints-after', 'kba', '=s' );
$add_option->( 'ignore-old-breakpoints', 'iob', '!' );
########################################
$category = 8; # Blank line control
########################################
$add_option->( 'blanks-before-blocks', 'bbb', '!' );
$add_option->( 'blanks-before-comments', 'bbc', '!' );
$add_option->( 'blank-lines-before-subs', 'blbs', '=i' );
$add_option->( 'blank-lines-before-packages', 'blbp', '=i' );
$add_option->( 'long-block-line-count', 'lbl', '=i' );
$add_option->( 'maximum-consecutive-blank-lines', 'mbl', '=i' );
$add_option->( 'keep-old-blank-lines', 'kbl', '=i' );
$add_option->( 'keyword-group-blanks-list', 'kgbl', '=s' );
$add_option->( 'keyword-group-blanks-size', 'kgbs', '=s' );
$add_option->( 'keyword-group-blanks-repeat-count', 'kgbr', '=i' );
$add_option->( 'keyword-group-blanks-before', 'kgbb', '=i' );
$add_option->( 'keyword-group-blanks-after', 'kgba', '=i' );
$add_option->( 'keyword-group-blanks-inside', 'kgbi', '!' );
$add_option->( 'keyword-group-blanks-delete', 'kgbd', '!' );
$add_option->( 'blank-lines-after-opening-block', 'blao', '=i' );
$add_option->( 'blank-lines-before-closing-block', 'blbc', '=i' );
$add_option->( 'blank-lines-after-opening-block-list', 'blaol', '=s' );
$add_option->( 'blank-lines-before-closing-block-list', 'blbcl', '=s' );
########################################
$category = 9; # Other controls
########################################
$add_option->( 'delete-block-comments', 'dbc', '!' );
$add_option->( 'delete-closing-side-comments', 'dcsc', '!' );
$add_option->( 'delete-pod', 'dp', '!' );
$add_option->( 'delete-side-comments', 'dsc', '!' );
$add_option->( 'tee-block-comments', 'tbc', '!' );
$add_option->( 'tee-pod', 'tp', '!' );
$add_option->( 'tee-side-comments', 'tsc', '!' );
$add_option->( 'look-for-autoloader', 'lal', '!' );
$add_option->( 'look-for-hash-bang', 'x', '!' );
$add_option->( 'look-for-selfloader', 'lsl', '!' );
$add_option->( 'pass-version-line', 'pvl', '!' );
########################################
$category = 13; # Debugging
########################################
$add_option->( 'DIAGNOSTICS', 'I', '!' ) if (DEVEL_MODE);
$add_option->( 'DEBUG', 'D', '!' );
$add_option->( 'dump-cuddled-block-list', 'dcbl', '!' );
$add_option->( 'dump-defaults', 'ddf', '!' );
$add_option->( 'dump-long-names', 'dln', '!' );
$add_option->( 'dump-options', 'dop', '!' );
$add_option->( 'dump-profile', 'dpro', '!' );
$add_option->( 'dump-short-names', 'dsn', '!' );
$add_option->( 'dump-token-types', 'dtt', '!' );
$add_option->( 'dump-want-left-space', 'dwls', '!' );
$add_option->( 'dump-want-right-space', 'dwrs', '!' );
$add_option->( 'fuzzy-line-length', 'fll', '!' );
$add_option->( 'help', 'h', '' );
$add_option->( 'short-concatenation-item-length', 'scl', '=i' );
$add_option->( 'show-options', 'opt', '!' );
$add_option->( 'timestamp', 'ts', '!' );
$add_option->( 'version', 'v', '' );
$add_option->( 'memoize', 'mem', '!' );
$add_option->( 'file-size-order', 'fso', '!' );
$add_option->( 'maximum-file-size-mb', 'maxfs', '=i' );
$add_option->( 'maximum-level-errors', 'maxle', '=i' );
$add_option->( 'maximum-unexpected-errors', 'maxue', '=i' );
#---------------------------------------------------------------------
# The Perl::Tidy::HtmlWriter will add its own options to the string
Perl::Tidy::HtmlWriter->make_getopt_long_names( \@option_string );
########################################
# Set categories 10, 11, 12
########################################
# Based on their known order
$category = 12; # HTML properties
foreach my $opt (@option_string) {
my $long_name = $opt;
$long_name =~ s/(!|=.*|:.*)$//;
unless ( defined( $option_category{$long_name} ) ) {
if ( $long_name =~ /^html-linked/ ) {
$category = 10; # HTML options
}
elsif ( $long_name =~ /^pod2html/ ) {
$category = 11; # Pod2html
}
$option_category{$long_name} = $category_name[$category];
}
}
#---------------------------------------------------------------
# Assign valid ranges to certain options
#---------------------------------------------------------------
# In the future, these may be used to make preliminary checks
# hash keys are long names
# If key or value is undefined:
# strings may have any value
# integer ranges are >=0
# If value is defined:
# value is [qw(any valid words)] for strings
# value is [min, max] for integers
# if min is undefined, there is no lower limit
# if max is undefined, there is no upper limit
# Parameters not listed here have defaults
%option_range = (
'format' => [ 'tidy', 'html', 'user' ],
'output-line-ending' => [ 'dos', 'win', 'mac', 'unix' ],
'space-backslash-quote' => [ 0, 2 ],
'block-brace-tightness' => [ 0, 2 ],
'keyword-paren-inner-tightness' => [ 0, 2 ],
'brace-tightness' => [ 0, 2 ],
'paren-tightness' => [ 0, 2 ],
'square-bracket-tightness' => [ 0, 2 ],
'block-brace-vertical-tightness' => [ 0, 2 ],
'brace-vertical-tightness' => [ 0, 2 ],
'brace-vertical-tightness-closing' => [ 0, 2 ],
'paren-vertical-tightness' => [ 0, 2 ],
'paren-vertical-tightness-closing' => [ 0, 2 ],
'square-bracket-vertical-tightness' => [ 0, 2 ],
'square-bracket-vertical-tightness-closing' => [ 0, 2 ],
'vertical-tightness' => [ 0, 2 ],
'vertical-tightness-closing' => [ 0, 2 ],
'closing-brace-indentation' => [ 0, 3 ],
'closing-paren-indentation' => [ 0, 3 ],
'closing-square-bracket-indentation' => [ 0, 3 ],
'closing-token-indentation' => [ 0, 3 ],
'closing-side-comment-else-flag' => [ 0, 2 ],
'comma-arrow-breakpoints' => [ 0, 5 ],
'keyword-group-blanks-before' => [ 0, 2 ],
'keyword-group-blanks-after' => [ 0, 2 ],
'space-prototype-paren' => [ 0, 2 ],
);
# Note: we could actually allow negative ci if someone really wants it:
# $option_range{'continuation-indentation'} = [ undef, undef ];
#---------------------------------------------------------------
# Assign default values to the above options here, except
# for 'outfile' and 'help'.
# These settings should approximate the perlstyle(1) suggestions.
#---------------------------------------------------------------
my @defaults = qw(
add-newlines
add-terminal-newline
add-semicolons
add-whitespace
blanks-before-blocks
blanks-before-comments
blank-lines-before-subs=1
blank-lines-before-packages=1
keyword-group-blanks-size=5
keyword-group-blanks-repeat-count=0
keyword-group-blanks-before=1
keyword-group-blanks-after=1
nokeyword-group-blanks-inside
nokeyword-group-blanks-delete
block-brace-tightness=0
block-brace-vertical-tightness=0
brace-tightness=1
brace-vertical-tightness-closing=0
brace-vertical-tightness=0
break-at-old-logical-breakpoints
break-at-old-ternary-breakpoints
break-at-old-attribute-breakpoints
break-at-old-keyword-breakpoints
break-before-hash-brace=0
break-before-hash-brace-and-indent=0
break-before-square-bracket=0
break-before-square-bracket-and-indent=0
break-before-paren=0
break-before-paren-and-indent=0
comma-arrow-breakpoints=5
nocheck-syntax
character-encoding=guess
closing-side-comment-interval=6
closing-side-comment-maximum-text=20
closing-side-comment-else-flag=0
closing-side-comments-balanced
closing-paren-indentation=0
closing-brace-indentation=0
closing-square-bracket-indentation=0
continuation-indentation=2
noextended-continuation-indentation
cuddled-break-option=1
delete-old-newlines
delete-semicolons
extended-syntax
function-paren-vertical-alignment
fuzzy-line-length
hanging-side-comments
indent-block-comments
indent-columns=4
iterations=1
keep-old-blank-lines=1
keyword-paren-inner-tightness=1
logical-padding
long-block-line-count=8
look-for-autoloader
look-for-selfloader
maximum-consecutive-blank-lines=1
maximum-fields-per-table=0
maximum-line-length=80
maximum-file-size-mb=10
maximum-level-errors=1
maximum-unexpected-errors=0
memoize
minimum-space-to-comment=4
nobrace-left-and-indent
nocuddled-else
nodelete-old-whitespace
nohtml
nologfile
non-indenting-braces
noquiet
noshow-options
nostatic-side-comments
notabs
nowarning-output
one-line-block-semicolons=1
one-line-block-nesting=0
outdent-labels
outdent-long-quotes
outdent-long-comments
paren-tightness=1
paren-vertical-tightness-closing=0
paren-vertical-tightness=0
pass-version-line
noweld-nested-containers
recombine
nouse-unicode-gcstring
valign
short-concatenation-item-length=8
space-for-semicolon
space-backslash-quote=1
space-prototype-paren=1
square-bracket-tightness=1
square-bracket-vertical-tightness-closing=0
square-bracket-vertical-tightness=0
static-block-comments
timestamp
trim-qw
format=tidy
backup-file-extension=bak
code-skipping
format-skipping
default-tabsize=8
pod2html
html-table-of-contents
html-entities
);
push @defaults, "perl-syntax-check-flags=-c -T";
#---------------------------------------------------------------
# Define abbreviations which will be expanded into the above primitives.
# These may be defined recursively.
#---------------------------------------------------------------
%expansion = (
%expansion,
'freeze-newlines' => [qw(noadd-newlines nodelete-old-newlines)],
'fnl' => [qw(freeze-newlines)],
'freeze-whitespace' => [qw(noadd-whitespace nodelete-old-whitespace)],
'fws' => [qw(freeze-whitespace)],
'freeze-blank-lines' =>
[qw(maximum-consecutive-blank-lines=0 keep-old-blank-lines=2)],
'fbl' => [qw(freeze-blank-lines)],
'indent-only' => [qw(freeze-newlines freeze-whitespace)],
'outdent-long-lines' => [qw(outdent-long-quotes outdent-long-comments)],
'nooutdent-long-lines' =>
[qw(nooutdent-long-quotes nooutdent-long-comments)],
'oll' => [qw(outdent-long-lines)],
'noll' => [qw(nooutdent-long-lines)],
'io' => [qw(indent-only)],
'delete-all-comments' =>
[qw(delete-block-comments delete-side-comments delete-pod)],
'nodelete-all-comments' =>
[qw(nodelete-block-comments nodelete-side-comments nodelete-pod)],
'dac' => [qw(delete-all-comments)],
'ndac' => [qw(nodelete-all-comments)],
'gnu' => [qw(gnu-style)],
'pbp' => [qw(perl-best-practices)],
'tee-all-comments' =>
[qw(tee-block-comments tee-side-comments tee-pod)],
'notee-all-comments' =>
[qw(notee-block-comments notee-side-comments notee-pod)],
'tac' => [qw(tee-all-comments)],
'ntac' => [qw(notee-all-comments)],
'html' => [qw(format=html)],
'nhtml' => [qw(format=tidy)],
'tidy' => [qw(format=tidy)],
# -cb is now a synonym for -ce
'cb' => [qw(cuddled-else)],
'cuddled-blocks' => [qw(cuddled-else)],
'utf8' => [qw(character-encoding=utf8)],
'UTF8' => [qw(character-encoding=utf8)],
'guess' => [qw(character-encoding=guess)],
'swallow-optional-blank-lines' => [qw(kbl=0)],
'noswallow-optional-blank-lines' => [qw(kbl=1)],
'sob' => [qw(kbl=0)],
'nsob' => [qw(kbl=1)],
'break-after-comma-arrows' => [qw(cab=0)],
'nobreak-after-comma-arrows' => [qw(cab=1)],
'baa' => [qw(cab=0)],
'nbaa' => [qw(cab=1)],
'blanks-before-subs' => [qw(blbs=1 blbp=1)],
'bbs' => [qw(blbs=1 blbp=1)],
'noblanks-before-subs' => [qw(blbs=0 blbp=0)],
'nbbs' => [qw(blbs=0 blbp=0)],
'keyword-group-blanks' => [qw(kgbb=2 kgbi kgba=2)],
'kgb' => [qw(kgbb=2 kgbi kgba=2)],
'nokeyword-group-blanks' => [qw(kgbb=1 nkgbi kgba=1)],
'nkgb' => [qw(kgbb=1 nkgbi kgba=1)],
'break-at-old-trinary-breakpoints' => [qw(bot)],
'cti=0' => [qw(cpi=0 cbi=0 csbi=0)],
'cti=1' => [qw(cpi=1 cbi=1 csbi=1)],
'cti=2' => [qw(cpi=2 cbi=2 csbi=2)],
'icp' => [qw(cpi=2 cbi=2 csbi=2)],
'nicp' => [qw(cpi=0 cbi=0 csbi=0)],
'closing-token-indentation=0' => [qw(cpi=0 cbi=0 csbi=0)],
'closing-token-indentation=1' => [qw(cpi=1 cbi=1 csbi=1)],
'closing-token-indentation=2' => [qw(cpi=2 cbi=2 csbi=2)],
'indent-closing-paren' => [qw(cpi=2 cbi=2 csbi=2)],
'noindent-closing-paren' => [qw(cpi=0 cbi=0 csbi=0)],
'vt=0' => [qw(pvt=0 bvt=0 sbvt=0)],
'vt=1' => [qw(pvt=1 bvt=1 sbvt=1)],
'vt=2' => [qw(pvt=2 bvt=2 sbvt=2)],
'vertical-tightness=0' => [qw(pvt=0 bvt=0 sbvt=0)],
'vertical-tightness=1' => [qw(pvt=1 bvt=1 sbvt=1)],
'vertical-tightness=2' => [qw(pvt=2 bvt=2 sbvt=2)],
'vtc=0' => [qw(pvtc=0 bvtc=0 sbvtc=0)],
'vtc=1' => [qw(pvtc=1 bvtc=1 sbvtc=1)],
'vtc=2' => [qw(pvtc=2 bvtc=2 sbvtc=2)],
'vertical-tightness-closing=0' => [qw(pvtc=0 bvtc=0 sbvtc=0)],
'vertical-tightness-closing=1' => [qw(pvtc=1 bvtc=1 sbvtc=1)],
'vertical-tightness-closing=2' => [qw(pvtc=2 bvtc=2 sbvtc=2)],
'otr' => [qw(opr ohbr osbr)],
'opening-token-right' => [qw(opr ohbr osbr)],
'notr' => [qw(nopr nohbr nosbr)],
'noopening-token-right' => [qw(nopr nohbr nosbr)],
'sot' => [qw(sop sohb sosb)],
'nsot' => [qw(nsop nsohb nsosb)],
'stack-opening-tokens' => [qw(sop sohb sosb)],
'nostack-opening-tokens' => [qw(nsop nsohb nsosb)],
'sct' => [qw(scp schb scsb)],
'stack-closing-tokens' => [qw(scp schb scsb)],
'nsct' => [qw(nscp nschb nscsb)],
'nostack-closing-tokens' => [qw(nscp nschb nscsb)],
'sac' => [qw(sot sct)],
'nsac' => [qw(nsot nsct)],
'stack-all-containers' => [qw(sot sct)],
'nostack-all-containers' => [qw(nsot nsct)],
'act=0' => [qw(pt=0 sbt=0 bt=0 bbt=0)],
'act=1' => [qw(pt=1 sbt=1 bt=1 bbt=1)],
'act=2' => [qw(pt=2 sbt=2 bt=2 bbt=2)],
'all-containers-tightness=0' => [qw(pt=0 sbt=0 bt=0 bbt=0)],
'all-containers-tightness=1' => [qw(pt=1 sbt=1 bt=1 bbt=1)],
'all-containers-tightness=2' => [qw(pt=2 sbt=2 bt=2 bbt=2)],
'stack-opening-block-brace' => [qw(bbvt=2 bbvtl=*)],
'sobb' => [qw(bbvt=2 bbvtl=*)],
'nostack-opening-block-brace' => [qw(bbvt=0)],
'nsobb' => [qw(bbvt=0)],
'converge' => [qw(it=4)],
'noconverge' => [qw(it=1)],
'conv' => [qw(it=4)],
'nconv' => [qw(it=1)],
# NOTE: This is a possible future shortcut. But it will remain
# deactivated until the -lpxl flag is no longer experimental.
# 'line-up-function-parentheses' => [ qw(lp), q#lpxl=[ { F(2# ],
# 'lfp' => [qw(line-up-function-parentheses)],
# 'mangle' originally deleted pod and comments, but to keep it
# reversible, it no longer does. But if you really want to
# delete them, just use:
# -mangle -dac
# An interesting use for 'mangle' is to do this:
# perltidy -mangle myfile.pl -st | perltidy -o myfile.pl.new
# which will form as many one-line blocks as possible
'mangle' => [
qw(
keep-old-blank-lines=0
delete-old-newlines
delete-old-whitespace
delete-semicolons
indent-columns=0
maximum-consecutive-blank-lines=0
maximum-line-length=100000
noadd-newlines
noadd-semicolons
noadd-whitespace
noblanks-before-blocks
blank-lines-before-subs=0
blank-lines-before-packages=0
notabs
)
],
# 'extrude' originally deleted pod and comments, but to keep it
# reversible, it no longer does. But if you really want to
# delete them, just use
# extrude -dac
#
# An interesting use for 'extrude' is to do this:
# perltidy -extrude myfile.pl -st | perltidy -o myfile.pl.new
# which will break up all one-line blocks.
'extrude' => [
qw(
ci=0
delete-old-newlines
delete-old-whitespace
delete-semicolons
indent-columns=0
maximum-consecutive-blank-lines=0
maximum-line-length=1
noadd-semicolons
noadd-whitespace
noblanks-before-blocks
blank-lines-before-subs=0
blank-lines-before-packages=0
nofuzzy-line-length
notabs
norecombine
)
],
# this style tries to follow the GNU Coding Standards (which do
# not really apply to perl but which are followed by some perl
# programmers).
'gnu-style' => [
qw(
lp bl noll pt=2 bt=2 sbt=2 cpi=1 csbi=1 cbi=1
)
],
# Style suggested in Damian Conway's Perl Best Practices
'perl-best-practices' => [
qw(l=78 i=4 ci=4 st se vt=2 cti=0 pt=1 bt=1 sbt=1 bbt=1 nsfs nolq),
q(wbb=% + - * / x != == >= <= =~ !~ < > | & = **= += *= &= <<= &&= -= /= |= >>= ||= //= .= %= ^= x=)
],
# Additional styles can be added here
);
Perl::Tidy::HtmlWriter->make_abbreviated_names( \%expansion );
# Uncomment next line to dump all expansions for debugging:
# dump_short_names(\%expansion);
return (
\@option_string, \@defaults, \%expansion,
\%option_category, \%option_range
);
} # end of generate_options
# Memoize process_command_line. Given same @ARGV passed in, return same
# values and same @ARGV back.
# This patch was supplied by Jonathan Swartz Nov 2012 and significantly speeds
# up masontidy (https://metacpan.org/module/masontidy)
my %process_command_line_cache;
sub process_command_line {
my @q = @_;
my (
$perltidyrc_stream, $is_Windows, $Windows_type,
$rpending_complaint, $dump_options_type
) = @q;
my $use_cache = !defined($perltidyrc_stream) && !$dump_options_type;
if ($use_cache) {
my $cache_key = join( chr(28), @ARGV );
if ( my $result = $process_command_line_cache{$cache_key} ) {
my ( $argv, @retvals ) = @{$result};
@ARGV = @{$argv};
return @retvals;
}
else {
my @retvals = _process_command_line(@q);
$process_command_line_cache{$cache_key} = [ \@ARGV, @retvals ]
if $retvals[0]->{'memoize'};
return @retvals;
}
}
else {
return _process_command_line(@q);
}
}
# (note the underscore here)
sub _process_command_line {
my (
$perltidyrc_stream, $is_Windows, $Windows_type,
$rpending_complaint, $dump_options_type
) = @_;
use Getopt::Long;
# Save any current Getopt::Long configuration
# and set to Getopt::Long defaults. Use eval to avoid
# breaking old versions of Perl without these routines.
# Previous configuration is reset at the exit of this routine.
my $glc;
eval { $glc = Getopt::Long::Configure() };
unless ($@) {
eval { Getopt::Long::ConfigDefaults() };
}
else { $glc = undef }
my (
$roption_string, $rdefaults, $rexpansion,
$roption_category, $roption_range
) = generate_options();
#---------------------------------------------------------------
# set the defaults by passing the above list through GetOptions
#---------------------------------------------------------------
my %Opts = ();
{
local @ARGV = ();
# do not load the defaults if we are just dumping perltidyrc
unless ( $dump_options_type eq 'perltidyrc' ) {
for my $i ( @{$rdefaults} ) { push @ARGV, "--" . $i }
}
if ( !GetOptions( \%Opts, @{$roption_string} ) ) {
Die(
"Programming Bug reported by 'GetOptions': error in setting default options"
);
}
}
my $word;
my @raw_options = ();
my $config_file = "";
my $saw_ignore_profile = 0;
my $saw_dump_profile = 0;
#---------------------------------------------------------------
# Take a first look at the command-line parameters. Do as many
# immediate dumps as possible, which can avoid confusion if the
# perltidyrc file has an error.
#---------------------------------------------------------------
foreach my $i (@ARGV) {
$i =~ s/^--/-/;
if ( $i =~ /^-(npro|noprofile|no-profile)$/ ) {
$saw_ignore_profile = 1;
}
# note: this must come before -pro and -profile, below:
elsif ( $i =~ /^-(dump-profile|dpro)$/ ) {
$saw_dump_profile = 1;
}
elsif ( $i =~ /^-(pro|profile)=(.+)/ ) {
if ($config_file) {
Warn(
"Only one -pro=filename allowed, using '$2' instead of '$config_file'\n"
);
}
$config_file = $2;
# resolve /.../, meaning look upwards from directory
if ( defined($config_file) ) {
if ( my ( $start_dir, $search_file ) =
( $config_file =~ m{^(.*)\.\.\./(.*)$} ) )
{
$start_dir = '.' if !$start_dir;
$start_dir = Cwd::realpath($start_dir);
if ( my $found_file =
find_file_upwards( $start_dir, $search_file ) )
{
$config_file = $found_file;
}
}
}
unless ( -e $config_file ) {
Warn("cannot find file given with -pro=$config_file: $!\n");
$config_file = "";
}
}
elsif ( $i =~ /^-(pro|profile)=?$/ ) {
Die("usage: -pro=filename or --profile=filename, no spaces\n");
}
elsif ( $i =~ /^-(help|h|HELP|H|\?)$/ ) {
usage();
Exit(0);
}
elsif ( $i =~ /^-(version|v)$/ ) {
show_version();
Exit(0);
}
elsif ( $i =~ /^-(dump-defaults|ddf)$/ ) {
dump_defaults( @{$rdefaults} );
Exit(0);
}
elsif ( $i =~ /^-(dump-long-names|dln)$/ ) {
dump_long_names( @{$roption_string} );
Exit(0);
}
elsif ( $i =~ /^-(dump-short-names|dsn)$/ ) {
dump_short_names($rexpansion);
Exit(0);
}
elsif ( $i =~ /^-(dump-token-types|dtt)$/ ) {
Perl::Tidy::Tokenizer->dump_token_types(*STDOUT);
Exit(0);
}
}
if ( $saw_dump_profile && $saw_ignore_profile ) {
Warn("No profile to dump because of -npro\n");
Exit(1);
}
#---------------------------------------------------------------
# read any .perltidyrc configuration file
#---------------------------------------------------------------
unless ($saw_ignore_profile) {
# resolve possible conflict between $perltidyrc_stream passed
# as call parameter to perltidy and -pro=filename on command
# line.
if ($perltidyrc_stream) {
if ($config_file) {
Warn(<{'vertical-tightness'} ) {
my $vt = $rOpts->{'vertical-tightness'};
$rOpts->{'paren-vertical-tightness'} = $vt;
$rOpts->{'square-bracket-vertical-tightness'} = $vt;
$rOpts->{'brace-vertical-tightness'} = $vt;
}
if ( defined $rOpts->{'vertical-tightness-closing'} ) {
my $vtc = $rOpts->{'vertical-tightness-closing'};
$rOpts->{'paren-vertical-tightness-closing'} = $vtc;
$rOpts->{'square-bracket-vertical-tightness-closing'} = $vtc;
$rOpts->{'brace-vertical-tightness-closing'} = $vtc;
}
if ( defined $rOpts->{'closing-token-indentation'} ) {
my $cti = $rOpts->{'closing-token-indentation'};
$rOpts->{'closing-square-bracket-indentation'} = $cti;
$rOpts->{'closing-brace-indentation'} = $cti;
$rOpts->{'closing-paren-indentation'} = $cti;
}
# Syntax checking is no longer supported due to concerns about executing
# code in BEGIN blocks. The flag is still accepted for backwards
# compatibility but is ignored if set.
$rOpts->{'check-syntax'} = 0;
# check iteration count and quietly fix if necessary:
# - iterations option only applies to code beautification mode
# - the convergence check should stop most runs on iteration 2, and
# virtually all on iteration 3. But we'll allow up to 6.
if ( $rOpts->{'format'} ne 'tidy' ) {
$rOpts->{'iterations'} = 1;
}
elsif ( defined( $rOpts->{'iterations'} ) ) {
if ( $rOpts->{'iterations'} <= 0 ) { $rOpts->{'iterations'} = 1 }
elsif ( $rOpts->{'iterations'} > 6 ) { $rOpts->{'iterations'} = 6 }
}
else {
$rOpts->{'iterations'} = 1;
}
my $check_blank_count = sub {
my ( $key, $abbrev ) = @_;
if ( $rOpts->{$key} ) {
if ( $rOpts->{$key} < 0 ) {
$rOpts->{$key} = 0;
Warn("negative value of $abbrev, setting 0\n");
}
if ( $rOpts->{$key} > 100 ) {
Warn("unreasonably large value of $abbrev, reducing\n");
$rOpts->{$key} = 100;
}
}
};
# check for reasonable number of blank lines and fix to avoid problems
$check_blank_count->( 'blank-lines-before-subs', '-blbs' );
$check_blank_count->( 'blank-lines-before-packages', '-blbp' );
$check_blank_count->( 'blank-lines-after-block-opening', '-blao' );
$check_blank_count->( 'blank-lines-before-block-closing', '-blbc' );
# setting a non-negative logfile gap causes logfile to be saved
if ( defined( $rOpts->{'logfile-gap'} ) && $rOpts->{'logfile-gap'} >= 0 ) {
$rOpts->{'logfile'} = 1;
}
# set short-cut flag when only indentation is to be done.
# Note that the user may or may not have already set the
# indent-only flag.
if ( !$rOpts->{'add-whitespace'}
&& !$rOpts->{'delete-old-whitespace'}
&& !$rOpts->{'add-newlines'}
&& !$rOpts->{'delete-old-newlines'} )
{
$rOpts->{'indent-only'} = 1;
}
# -isbc implies -ibc
if ( $rOpts->{'indent-spaced-block-comments'} ) {
$rOpts->{'indent-block-comments'} = 1;
}
# -bar cannot be used with -bl or -bli; arbitrarily keep -bar
if ( $rOpts->{'opening-brace-always-on-right'} ) {
if ( $rOpts->{'opening-brace-on-new-line'} ) {
Warn(<{'opening-brace-on-new-line'} = 0;
}
if ( $rOpts->{'brace-left-and-indent'} ) {
Warn(<{'brace-left-and-indent'} = 0;
}
}
# -bli flag implies -bl
if ( $rOpts->{'brace-left-and-indent'} ) {
$rOpts->{'opening-brace-on-new-line'} = 1;
}
# it simplifies things if -bl is 0 rather than undefined
if ( !defined( $rOpts->{'opening-brace-on-new-line'} ) ) {
$rOpts->{'opening-brace-on-new-line'} = 0;
}
# -sbl defaults to -bl if not defined
if ( !defined( $rOpts->{'opening-sub-brace-on-new-line'} ) ) {
$rOpts->{'opening-sub-brace-on-new-line'} =
$rOpts->{'opening-brace-on-new-line'};
}
if ( $rOpts->{'entab-leading-whitespace'} ) {
if ( $rOpts->{'entab-leading-whitespace'} < 0 ) {
Warn("-et=n must use a positive integer; ignoring -et\n");
$rOpts->{'entab-leading-whitespace'} = undef;
}
# entab leading whitespace has priority over the older 'tabs' option
if ( $rOpts->{'tabs'} ) { $rOpts->{'tabs'} = 0; }
}
# set a default tabsize to be used in guessing the starting indentation
# level if and only if this run does not use tabs and the old code does
# use tabs
if ( $rOpts->{'default-tabsize'} ) {
if ( $rOpts->{'default-tabsize'} < 0 ) {
Warn("negative value of -dt, setting 0\n");
$rOpts->{'default-tabsize'} = 0;
}
if ( $rOpts->{'default-tabsize'} > 20 ) {
Warn("unreasonably large value of -dt, reducing\n");
$rOpts->{'default-tabsize'} = 20;
}
}
else {
$rOpts->{'default-tabsize'} = 8;
}
# Check and clean up any sub-alias-list
if ( $rOpts->{'sub-alias-list'} ) {
my $sub_alias_string = $rOpts->{'sub-alias-list'};
$sub_alias_string =~ s/,/ /g; # allow commas
$sub_alias_string =~ s/^\s+//;
$sub_alias_string =~ s/\s+$//;
my @sub_alias_list = split /\s+/, $sub_alias_string;
my @filtered_word_list = ('sub');
my %seen;
# include 'sub' for later convenience
$seen{sub}++;
foreach my $word (@sub_alias_list) {
if ($word) {
if ( $word !~ /^\w[\w\d]*$/ ) {
Warn("unexpected sub alias '$word' - ignoring\n");
}
if ( !$seen{$word} ) {
$seen{$word}++;
push @filtered_word_list, $word;
}
}
}
my $joined_words = join ' ', @filtered_word_list;
$rOpts->{'sub-alias-list'} = join ' ', @filtered_word_list;
}
# Turn on fuzzy-line-length unless this is an extrude run, as determined
# by the -i and -ci settings. Otherwise blinkers can form (case b935)
if ( !$rOpts->{'fuzzy-line-length'} ) {
if ( $rOpts->{'maximum-line-length'} != 1
|| $rOpts->{'continuation-indentation'} != 0 )
{
$rOpts->{'fuzzy-line-length'} = 1;
}
}
# The freeze-whitespace option is currently a derived option which has its
# own key
$rOpts->{'freeze-whitespace'} = !$rOpts->{'add-whitespace'}
&& !$rOpts->{'delete-old-whitespace'};
# Turn off certain options if whitespace is frozen
# Note: vertical alignment will be automatically shut off
if ( $rOpts->{'freeze-whitespace'} ) {
$rOpts->{'logical-padding'} = 0;
}
# 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
my $tabsize =
$rOpts->{'entab-leading-whitespace'}
? $rOpts->{'entab-leading-whitespace'}
: $rOpts->{'tabs'} ? $rOpts->{'indent-columns'}
: $rOpts->{'default-tabsize'};
return $tabsize;
}
sub find_file_upwards {
my ( $search_dir, $search_file ) = @_;
$search_dir =~ s{/+$}{};
$search_file =~ s{^/+}{};
while (1) {
my $try_path = "$search_dir/$search_file";
if ( -f $try_path ) {
return $try_path;
}
elsif ( $search_dir eq '/' ) {
return;
}
else {
$search_dir = dirname($search_dir);
}
}
# This return is for Perl-Critic.
# We shouldn't get out of the while loop without a return
return;
}
sub expand_command_abbreviations {
# go through @ARGV and expand any abbreviations
my ( $rexpansion, $rraw_options, $config_file ) = @_;
# set a pass limit to prevent an infinite loop;
# 10 should be plenty, but it may be increased to allow deeply
# nested expansions.
my $max_passes = 10;
my @new_argv = ();
# keep looping until all expansions have been converted into actual
# dash parameters..
foreach my $pass_count ( 0 .. $max_passes ) {
my @new_argv = ();
my $abbrev_count = 0;
# loop over each item in @ARGV..
foreach my $word (@ARGV) {
# convert any leading 'no-' to just 'no'
if ( $word =~ /^(-[-]?no)-(.*)/ ) { $word = $1 . $2 }
# if it is a dash flag (instead of a file name)..
if ( $word =~ /^-[-]?([\w\-]+)(.*)/ ) {
my $abr = $1;
my $flags = $2;
# save the raw input for debug output in case of circular refs
if ( $pass_count == 0 ) {
push( @{$rraw_options}, $word );
}
# recombine abbreviation and flag, if necessary,
# to allow abbreviations with arguments such as '-vt=1'
if ( $rexpansion->{ $abr . $flags } ) {
$abr = $abr . $flags;
$flags = "";
}
# if we see this dash item in the expansion hash..
if ( $rexpansion->{$abr} ) {
$abbrev_count++;
# stuff all of the words that it expands to into the
# new arg list for the next pass
foreach my $abbrev ( @{ $rexpansion->{$abr} } ) {
next unless $abbrev; # for safety; shouldn't happen
push( @new_argv, '--' . $abbrev . $flags );
}
}
# not in expansion hash, must be actual long name
else {
push( @new_argv, $word );
}
}
# not a dash item, so just save it for the next pass
else {
push( @new_argv, $word );
}
} # end of this pass
# update parameter list @ARGV to the new one
@ARGV = @new_argv;
last unless ( $abbrev_count > 0 );
# make sure we are not in an infinite loop
if ( $pass_count == $max_passes ) {
local $" = ')(';
Warn(<{$abbrev} };
print STDOUT "$abbrev --> @list\n";
}
return;
}
sub check_vms_filename {
# given a valid filename (the perltidy input file)
# create a modified filename and separator character
# suitable for VMS.
#
# Contributed by Michael Cartmell
#
my $filename = shift;
my ( $base, $path ) = fileparse($filename);
# remove explicit ; version
$base =~ s/;-?\d*$//
# remove explicit . version ie two dots in filename NB ^ escapes a dot
or $base =~ s/( # begin capture $1
(?:^|[^^])\. # match a dot not preceded by a caret
(?: # followed by nothing
| # or
.*[^^] # anything ending in a non caret
)
) # end capture $1
\.-?\d*$ # match . version number
/$1/x;
# normalise filename, if there are no unescaped dots then append one
$base .= '.' unless $base =~ /(?:^|[^^])\./;
# if we don't already have an extension then we just append the extension
my $separator = ( $base =~ /\.$/ ) ? "" : "_";
return ( $path . $base, $separator );
}
sub Win_OS_Type {
# TODO: are these more standard names?
# Win32s Win95 Win98 WinMe WinNT3.51 WinNT4 Win2000 WinXP/.Net Win2003
# Returns a string that determines what MS OS we are on.
# Returns win32s,95,98,Me,NT3.51,NT4,2000,XP/.Net,Win2003
# Returns blank string if not an MS system.
# Original code contributed by: Yves Orton
# We need to know this to decide where to look for config files
my $rpending_complaint = shift;
my $os = "";
return $os unless $^O =~ /win32|dos/i; # is it a MS box?
# Systems built from Perl source may not have Win32.pm
# But probably have Win32::GetOSVersion() anyway so the
# following line is not 'required':
# return $os unless eval('require Win32');
# Use the standard API call to determine the version
my ( $undef, $major, $minor, $build, $id );
eval { ( $undef, $major, $minor, $build, $id ) = Win32::GetOSVersion() };
#
# NAME ID MAJOR MINOR
# Windows NT 4 2 4 0
# Windows 2000 2 5 0
# Windows XP 2 5 1
# Windows Server 2003 2 5 2
return "win32s" unless $id; # If id==0 then its a win32s box.
$os = { # Magic numbers from MSDN
# documentation of GetOSVersion
1 => {
0 => "95",
10 => "98",
90 => "Me"
},
2 => {
0 => "2000", # or NT 4, see below
1 => "XP/.Net",
2 => "Win2003",
51 => "NT3.51"
}
}->{$id}->{$minor};
# If $os is undefined, the above code is out of date. Suggested updates
# are welcome.
unless ( defined $os ) {
$os = "";
# Deactivated this message 20180322 because it was needlessly
# causing some test scripts to fail. Need help from someone
# with expertise in Windows to decide what is possible with windows.
${$rpending_complaint} .= </.../, meaning look upwards from directory
my $config_file = shift;
if ($config_file) {
if ( my ( $start_dir, $search_file ) =
( $config_file =~ m{^(.*)\.\.\./(.*)$} ) )
{
${$rconfig_file_chatter} .=
"# Searching Upward: $config_file\n";
$start_dir = '.' if !$start_dir;
$start_dir = Cwd::realpath($start_dir);
if ( my $found_file =
find_file_upwards( $start_dir, $search_file ) )
{
$config_file = $found_file;
${$rconfig_file_chatter} .= "# Found: $config_file\n";
}
}
}
return $config_file;
};
my $config_file;
# look in current directory first
$config_file = ".perltidyrc";
return $config_file if $exists_config_file->($config_file);
if ($is_Windows) {
$config_file = "perltidy.ini";
return $config_file if $exists_config_file->($config_file);
}
# Default environment vars.
my @envs = qw(PERLTIDY HOME);
# Check the NT/2k/XP locations, first a local machine def, then a
# network def
push @envs, qw(USERPROFILE HOMESHARE) if $^O =~ /win32/i;
# Now go through the environment ...
foreach my $var (@envs) {
${$rconfig_file_chatter} .= "# Examining: \$ENV{$var}";
if ( defined( $ENV{$var} ) ) {
${$rconfig_file_chatter} .= " = $ENV{$var}\n";
# test ENV{ PERLTIDY } as file:
if ( $var eq 'PERLTIDY' ) {
$config_file = "$ENV{$var}";
$config_file = $resolve_config_file->($config_file);
return $config_file if $exists_config_file->($config_file);
}
# test ENV as directory:
$config_file = catfile( $ENV{$var}, ".perltidyrc" );
$config_file = $resolve_config_file->($config_file);
return $config_file if $exists_config_file->($config_file);
if ($is_Windows) {
$config_file = catfile( $ENV{$var}, "perltidy.ini" );
$config_file = $resolve_config_file->($config_file);
return $config_file if $exists_config_file->($config_file);
}
}
else {
${$rconfig_file_chatter} .= "\n";
}
}
# then look for a system-wide definition
# where to look varies with OS
if ($is_Windows) {
if ($Windows_type) {
my ( $os, $system, $allusers ) =
Win_Config_Locs( $rpending_complaint, $Windows_type );
# Check All Users directory, if there is one.
# i.e. C:\Documents and Settings\User\perltidy.ini
if ($allusers) {
$config_file = catfile( $allusers, ".perltidyrc" );
return $config_file if $exists_config_file->($config_file);
$config_file = catfile( $allusers, "perltidy.ini" );
return $config_file if $exists_config_file->($config_file);
}
# Check system directory.
# retain old code in case someone has been able to create
# a file with a leading period.
$config_file = catfile( $system, ".perltidyrc" );
return $config_file if $exists_config_file->($config_file);
$config_file = catfile( $system, "perltidy.ini" );
return $config_file if $exists_config_file->($config_file);
}
}
# Place to add customization code for other systems
elsif ( $^O eq 'OS2' ) {
}
elsif ( $^O eq 'MacOS' ) {
}
elsif ( $^O eq 'VMS' ) {
}
# Assume some kind of Unix
else {
$config_file = "/usr/local/etc/perltidyrc";
return $config_file if $exists_config_file->($config_file);
$config_file = "/etc/perltidyrc";
return $config_file if $exists_config_file->($config_file);
}
# Couldn't find a config file
return;
}
sub Win_Config_Locs {
# In scalar context returns the OS name (95 98 ME NT3.51 NT4 2000 XP),
# or undef if its not a win32 OS. In list context returns OS, System
# Directory, and All Users Directory. All Users will be empty on a
# 9x/Me box. Contributed by: Yves Orton.
# Original coding:
# my $rpending_complaint = shift;
# my $os = (@_) ? shift : Win_OS_Type();
my ( $rpending_complaint, $os ) = @_;
if ( !$os ) { $os = Win_OS_Type(); }
return unless $os;
my $system = "";
my $allusers = "";
if ( $os =~ /9[58]|Me/ ) {
$system = "C:/Windows";
}
elsif ( $os =~ /NT|XP|200?/ ) {
$system = ( $os =~ /XP/ ) ? "C:/Windows/" : "C:/WinNT/";
$allusers =
( $os =~ /NT/ )
? "C:/WinNT/profiles/All Users/"
: "C:/Documents and Settings/All Users/";
}
else {
# This currently would only happen on a win32s computer. I don't have
# one to test, so I am unsure how to proceed. Suggestions welcome!
${$rpending_complaint} .=
"I dont know a sensible place to look for config files on an $os system.\n";
return;
}
return wantarray ? ( $os, $system, $allusers ) : $os;
}
sub dump_config_file {
my ( $fh, $config_file, $rconfig_file_chatter ) = @_;
print STDOUT "$$rconfig_file_chatter";
if ($fh) {
print STDOUT "# Dump of file: '$config_file'\n";
while ( my $line = $fh->getline() ) { print STDOUT $line }
eval { $fh->close() };
}
else {
print STDOUT "# ...no config file found\n";
}
return;
}
sub read_config_file {
my ( $fh, $config_file, $rexpansion ) = @_;
my @config_list = ();
# file is bad if non-empty $death_message is returned
my $death_message = "";
my $name = undef;
my $line_no;
my $opening_brace_line;
while ( my $line = $fh->getline() ) {
$line_no++;
chomp $line;
( $line, $death_message ) =
strip_comment( $line, $config_file, $line_no );
last if ($death_message);
next unless $line;
$line =~ s/^\s*(.*?)\s*$/$1/; # trim both ends
next unless $line;
my $body = $line;
# Look for complete or partial abbreviation definition of the form
# name { body } or name { or name { body
# See rules in perltidy's perldoc page
# Section: Other Controls - Creating a new abbreviation
if ( $line =~ /^((\w+)\s*\{)(.*)?$/ ) {
my $oldname = $name;
( $name, $body ) = ( $2, $3 );
# Cannot start new abbreviation unless old abbreviation is complete
last if ($opening_brace_line);
$opening_brace_line = $line_no unless ( $body && $body =~ s/\}$// );
# handle a new alias definition
if ( ${$rexpansion}{$name} ) {
local $" = ')(';
my @names = sort keys %$rexpansion;
$death_message =
"Here is a list of all installed aliases\n(@names)\n"
. "Attempting to redefine alias ($name) in config file $config_file line $.\n";
last;
}
${$rexpansion}{$name} = [];
}
# leading opening braces not allowed
elsif ( $line =~ /^{/ ) {
$opening_brace_line = undef;
$death_message =
"Unexpected '{' at line $line_no in config file '$config_file'\n";
last;
}
# Look for abbreviation closing: body } or }
elsif ( $line =~ /^(.*)?\}$/ ) {
$body = $1;
if ($opening_brace_line) {
$opening_brace_line = undef;
}
else {
$death_message =
"Unexpected '}' at line $line_no in config file '$config_file'\n";
last;
}
}
# Now store any parameters
if ($body) {
my ( $rbody_parts, $msg ) = parse_args($body);
if ($msg) {
$death_message = <close() };
return ( \@config_list, $death_message );
}
sub strip_comment {
# Strip any comment from a command line
my ( $instr, $config_file, $line_no ) = @_;
my $msg = "";
# check for full-line comment
if ( $instr =~ /^\s*#/ ) {
return ( "", $msg );
}
# nothing to do if no comments
if ( $instr !~ /#/ ) {
return ( $instr, $msg );
}
# handle case of no quotes
elsif ( $instr !~ /['"]/ ) {
# We now require a space before the # of a side comment
# this allows something like:
# -sbcp=#
# Otherwise, it would have to be quoted:
# -sbcp='#'
$instr =~ s/\s+\#.*$//;
return ( $instr, $msg );
}
# handle comments and quotes
my $outstr = "";
my $quote_char = "";
while (1) {
# looking for ending quote character
if ($quote_char) {
if ( $instr =~ /\G($quote_char)/gc ) {
$quote_char = "";
$outstr .= $1;
}
elsif ( $instr =~ /\G(.)/gc ) {
$outstr .= $1;
}
# error..we reached the end without seeing the ending quote char
else {
$msg = < in this text:
$instr
Please fix this line or use -npro to avoid reading this file
EOM
last;
}
}
# accumulating characters and looking for start of a quoted string
else {
if ( $instr =~ /\G([\"\'])/gc ) {
$outstr .= $1;
$quote_char = $1;
}
# Note: not yet enforcing the space-before-hash rule for side
# comments if the parameter is quoted.
elsif ( $instr =~ /\G#/gc ) {
last;
}
elsif ( $instr =~ /\G(.)/gc ) {
$outstr .= $1;
}
else {
last;
}
}
}
return ( $outstr, $msg );
}
sub parse_args {
# Parse a command string containing multiple string with possible
# quotes, into individual commands. It might look like this, for example:
#
# -wba=" + - " -some-thing -wbb='. && ||'
#
# There is no need, at present, to handle escaped quote characters.
# (They are not perltidy tokens, so needn't be in strings).
my ($body) = @_;
my @body_parts = ();
my $quote_char = "";
my $part = "";
my $msg = "";
while (1) {
# looking for ending quote character
if ($quote_char) {
if ( $body =~ /\G($quote_char)/gc ) {
$quote_char = "";
}
elsif ( $body =~ /\G(.)/gc ) {
$part .= $1;
}
# error..we reached the end without seeing the ending quote char
else {
if ( length($part) ) { push @body_parts, $part; }
$msg = < in this text:
$body
EOM
last;
}
}
# accumulating characters and looking for start of a quoted string
else {
if ( $body =~ /\G([\"\'])/gc ) {
$quote_char = $1;
}
elsif ( $body =~ /\G(\s+)/gc ) {
if ( length($part) ) { push @body_parts, $part; }
$part = "";
}
elsif ( $body =~ /\G(.)/gc ) {
$part .= $1;
}
else {
if ( length($part) ) { push @body_parts, $part; }
last;
}
}
}
return ( \@body_parts, $msg );
}
sub dump_long_names {
my @names = @_;
print STDOUT < does not take an argument
# =s takes a mandatory string
# :s takes an optional string
# =i takes a mandatory integer
# :i takes an optional integer
# ! does not take an argument and may be negated
# i.e., -foo and -nofoo are allowed
# a double dash signals the end of the options list
#
#---------------------------------------------------------------
EOM
foreach my $name ( sort @names ) { print STDOUT "$name\n" }
return;
}
sub dump_defaults {
my @defaults = @_;
print STDOUT "Default command line options:\n";
foreach my $line ( sort @defaults ) { print STDOUT "$line\n" }
return;
}
sub readable_options {
# return options for this run as a string which could be
# put in a perltidyrc file
my ( $rOpts, $roption_string ) = @_;
my %Getopt_flags;
my $rGetopt_flags = \%Getopt_flags;
my $readable_options = "# Final parameter set for this run.\n";
$readable_options .=
"# See utility 'perltidyrc_dump.pl' for nicer formatting.\n";
foreach my $opt ( @{$roption_string} ) {
my $flag = "";
if ( $opt =~ /(.*)(!|=.*)$/ ) {
$opt = $1;
$flag = $2;
}
if ( defined( $rOpts->{$opt} ) ) {
$rGetopt_flags->{$opt} = $flag;
}
}
foreach my $key ( sort keys %{$rOpts} ) {
my $flag = $rGetopt_flags->{$key};
my $value = $rOpts->{$key};
my $prefix = '--';
my $suffix = "";
if ($flag) {
if ( $flag =~ /^=/ ) {
if ( $value !~ /^\d+$/ ) { $value = '"' . $value . '"' }
$suffix = "=" . $value;
}
elsif ( $flag =~ /^!/ ) {
$prefix .= "no" unless ($value);
}
else {
# shouldn't happen
$readable_options .=
"# ERROR in dump_options: unrecognized flag $flag for $key\n";
}
}
$readable_options .= $prefix . $key . $suffix . "\n";
}
return $readable_options;
}
sub show_version {
print STDOUT <<"EOM";
This is perltidy, v$VERSION
Copyright 2000-2021, Steve Hancock
Perltidy is free software and may be copied under the terms of the GNU
General Public License, which is included in the distribution files.
Complete documentation for perltidy can be found using 'man perltidy'
or on the internet at http://perltidy.sourceforge.net.
EOM
return;
}
sub usage {
print STDOUT <outfile
perltidy [ options ] outfile
Options have short and long forms. Short forms are shown; see
man pages for long forms. Note: '=s' indicates a required string,
and '=n' indicates a required integer.
I/O control
-h show this help
-o=file name of the output file (only if single input file)
-oext=s change output extension from 'tdy' to s
-opath=path change path to be 'path' for output files
-b backup original to .bak and modify file in-place
-bext=s change default backup extension from 'bak' to s
-q deactivate error messages (for running under editor)
-w include non-critical warning messages in the .ERR error output
-syn run perl -c to check syntax (default under unix systems)
-log save .LOG file, which has useful diagnostics
-f force perltidy to read a binary file
-g like -log but writes more detailed .LOG file, for debugging scripts
-opt write the set of options actually used to a .LOG file
-npro ignore .perltidyrc configuration command file
-pro=file read configuration commands from file instead of .perltidyrc
-st send output to standard output, STDOUT
-se send all error output to standard error output, STDERR
-v display version number to standard output and quit
Basic Options:
-i=n use n columns per indentation level (default n=4)
-t tabs: use one tab character per indentation level, not recommended
-nt no tabs: use n spaces per indentation level (default)
-et=n entab leading whitespace n spaces per tab; not recommended
-io "indent only": just do indentation, no other formatting.
-sil=n set starting indentation level to n; use if auto detection fails
-ole=s specify output line ending (s=dos or win, mac, unix)
-ple keep output line endings same as input (input must be filename)
Whitespace Control
-fws freeze whitespace; this disables all whitespace changes
and disables the following switches:
-bt=n sets brace tightness, n= (0 = loose, 1=default, 2 = tight)
-bbt same as -bt but for code block braces; same as -bt if not given
-bbvt block braces vertically tight; use with -bl or -bli
-bbvtl=s make -bbvt to apply to selected list of block types
-pt=n paren tightness (n=0, 1 or 2)
-sbt=n square bracket tightness (n=0, 1, or 2)
-bvt=n brace vertical tightness,
n=(0=open, 1=close unless multiple steps on a line, 2=always close)
-pvt=n paren vertical tightness (see -bvt for n)
-sbvt=n square bracket vertical tightness (see -bvt for n)
-bvtc=n closing brace vertical tightness:
n=(0=open, 1=sometimes close, 2=always close)
-pvtc=n closing paren vertical tightness, see -bvtc for n.
-sbvtc=n closing square bracket vertical tightness, see -bvtc for n.
-ci=n sets continuation indentation=n, default is n=2 spaces
-lp line up parentheses, brackets, and non-BLOCK braces
-sfs add space before semicolon in for( ; ; )
-aws allow perltidy to add whitespace (default)
-dws delete all old non-essential whitespace
-icb indent closing brace of a code block
-cti=n closing indentation of paren, square bracket, or non-block brace:
n=0 none, =1 align with opening, =2 one full indentation level
-icp equivalent to -cti=2
-wls=s want space left of tokens in string; i.e. -nwls='+ - * /'
-wrs=s want space right of tokens in string;
-sts put space before terminal semicolon of a statement
-sak=s put space between keywords given in s and '(';
-nsak=s no space between keywords in s and '('; i.e. -nsak='my our local'
Line Break Control
-fnl freeze newlines; this disables all line break changes
and disables the following switches:
-anl add newlines; ok to introduce new line breaks
-bbs add blank line before subs and packages
-bbc add blank line before block comments
-bbb add blank line between major blocks
-kbl=n keep old blank lines? 0=no, 1=some, 2=all
-mbl=n maximum consecutive blank lines to output (default=1)
-ce cuddled else; use this style: '} else {'
-cb cuddled blocks (other than 'if-elsif-else')
-cbl=s list of blocks to cuddled, default 'try-catch-finally'
-dnl delete old newlines (default)
-l=n maximum line length; default n=80
-bl opening brace on new line
-sbl opening sub brace on new line. value of -bl is used if not given.
-bli opening brace on new line and indented
-bar opening brace always on right, even for long clauses
-vt=n vertical tightness (requires -lp); n controls break after opening
token: 0=never 1=no break if next line balanced 2=no break
-vtc=n vertical tightness of closing container; n controls if closing
token starts new line: 0=always 1=not unless list 1=never
-wba=s want break after tokens in string; i.e. wba=': .'
-wbb=s want break before tokens in string
-wn weld nested: combines opening and closing tokens when both are adjacent
-wnxl=s weld nested exclusion list: provides some control over the types of
containers which can be welded
Following Old Breakpoints
-kis keep interior semicolons. Allows multiple statements per line.
-boc break at old comma breaks: turns off all automatic list formatting
-bol break at old logical breakpoints: or, and, ||, && (default)
-bom break at old method call breakpoints: ->
-bok break at old list keyword breakpoints such as map, sort (default)
-bot break at old conditional (ternary ?:) operator breakpoints (default)
-boa break at old attribute breakpoints
-cab=n break at commas after a comma-arrow (=>):
n=0 break at all commas after =>
n=1 stable: break unless this breaks an existing one-line container
n=2 break only if a one-line container cannot be formed
n=3 do not treat commas after => specially at all
Comment controls
-ibc indent block comments (default)
-isbc indent spaced block comments; may indent unless no leading space
-msc=n minimum desired spaces to side comment, default 4
-fpsc=n fix position for side comments; default 0;
-csc add or update closing side comments after closing BLOCK brace
-dcsc delete closing side comments created by a -csc command
-cscp=s change closing side comment prefix to be other than '## end'
-cscl=s change closing side comment to apply to selected list of blocks
-csci=n minimum number of lines needed to apply a -csc tag, default n=6
-csct=n maximum number of columns of appended text, default n=20
-cscw causes warning if old side comment is overwritten with -csc
-sbc use 'static block comments' identified by leading '##' (default)
-sbcp=s change static block comment identifier to be other than '##'
-osbc outdent static block comments
-ssc use 'static side comments' identified by leading '##' (default)
-sscp=s change static side comment identifier to be other than '##'
Delete selected text
-dac delete all comments AND pod
-dbc delete block comments
-dsc delete side comments
-dp delete pod
Send selected text to a '.TEE' file
-tac tee all comments AND pod
-tbc tee block comments
-tsc tee side comments
-tp tee pod
Outdenting
-olq outdent long quoted strings (default)
-olc outdent a long block comment line
-ola outdent statement labels
-okw outdent control keywords (redo, next, last, goto, return)
-okwl=s specify alternative keywords for -okw command
Other controls
-mft=n maximum fields per table; default n=40
-x do not format lines before hash-bang line (i.e., for VMS)
-asc allows perltidy to add a ';' when missing (default)
-dsm allows perltidy to delete an unnecessary ';' (default)
Combinations of other parameters
-gnu attempt to follow GNU Coding Standards as applied to perl
-mangle remove as many newlines as possible (but keep comments and pods)
-extrude insert as many newlines as possible
Dump and die, debugging
-dop dump options used in this run to standard output and quit
-ddf dump default options to standard output and quit
-dsn dump all option short names to standard output and quit
-dln dump option long names to standard output and quit
-dpro dump whatever configuration file is in effect to standard output
-dtt dump all token types to standard output and quit
HTML
-html write an html file (see 'man perl2web' for many options)
Note: when -html is used, no indentation or formatting are done.
Hint: try perltidy -html -css=mystyle.css filename.pl
and edit mystyle.css to change the appearance of filename.html.
-nnn gives line numbers
-pre only writes out ..
code section
-toc places a table of contents to subs at the top (default)
-pod passes pod text through pod2html (default)
-frm write html as a frame (3 files)
-text=s extra extension for table of contents if -frm, default='toc'
-sext=s extra extension for file content if -frm, default='src'
A prefix of "n" negates short form toggle switches, and a prefix of "no"
negates the long forms. For example, -nasc means don't add missing
semicolons.
If you are unable to see this entire text, try "perltidy -h | more"
For more detailed information, and additional options, try "man perltidy",
or go to the perltidy home page at http://perltidy.sourceforge.net
EOF
return;
}
sub process_this_file {
my ( $tokenizer, $formatter ) = @_;
while ( my $line = $tokenizer->get_line() ) {
$formatter->write_line($line);
}
my $severe_error = $tokenizer->report_tokenization_errors();
# user-defined formatters are possible, and may not have a
# sub 'finish_formatting', so we have to check
$formatter->finish_formatting($severe_error)
if $formatter->can('finish_formatting');
return;
}
sub check_syntax {
# Use 'perl -c' to make sure that we did not create bad syntax
# This is a very good independent check for programming errors
#
# Given names of the input and output files, ($istream, $ostream),
# we do the following:
# - check syntax of the input file
# - if bad, all done (could be an incomplete code snippet)
# - if infile syntax ok, then check syntax of the output file;
# - if outfile syntax bad, issue warning; this implies a code bug!
# - set and return flag "infile_syntax_ok" : =-1 bad 0 unknown 1 good
my ( $istream, $ostream, $logger_object, $rOpts ) = @_;
my $infile_syntax_ok = 0;
my $line_of_dashes = '-' x 42 . "\n";
my $flags = $rOpts->{'perl-syntax-check-flags'};
# be sure we invoke perl with -c
# note: perl will accept repeated flags like '-c -c'. It is safest
# to append another -c than try to find an interior bundled c, as
# in -Tc, because such a 'c' might be in a quoted string, for example.
if ( $flags !~ /(^-c|\s+-c)/ ) { $flags .= " -c" }
# be sure we invoke perl with -x if requested
# same comments about repeated parameters applies
if ( $rOpts->{'look-for-hash-bang'} ) {
if ( $flags !~ /(^-x|\s+-x)/ ) { $flags .= " -x" }
}
# this shouldn't happen unless a temporary file couldn't be made
if ( $istream eq '-' ) {
$logger_object->write_logfile_entry(
"Cannot run perl -c on STDIN and STDOUT\n");
return $infile_syntax_ok;
}
$logger_object->write_logfile_entry(
"checking input file syntax with perl $flags\n");
# Not all operating systems/shells support redirection of the standard
# error output.
my $error_redirection = ( $^O eq 'VMS' ) ? "" : '2>&1';
my ( $istream_filename, $perl_output ) =
do_syntax_check( $istream, $flags, $error_redirection );
$logger_object->write_logfile_entry(
"Input stream passed to Perl as file $istream_filename\n");
$logger_object->write_logfile_entry($line_of_dashes);
$logger_object->write_logfile_entry("$perl_output\n");
if ( $perl_output =~ /syntax\s*OK/ ) {
$infile_syntax_ok = 1;
$logger_object->write_logfile_entry($line_of_dashes);
$logger_object->write_logfile_entry(
"checking output file syntax with perl $flags ...\n");
my ( $ostream_filename, $perl_output ) =
do_syntax_check( $ostream, $flags, $error_redirection );
$logger_object->write_logfile_entry(
"Output stream passed to Perl as file $ostream_filename\n");
$logger_object->write_logfile_entry($line_of_dashes);
$logger_object->write_logfile_entry("$perl_output\n");
unless ( $perl_output =~ /syntax\s*OK/ ) {
$logger_object->write_logfile_entry($line_of_dashes);
$logger_object->warning(
"The output file has a syntax error when tested with perl $flags $ostream !\n"
);
$logger_object->warning(
"This implies an error in perltidy; the file $ostream is bad\n"
);
$logger_object->report_definite_bug();
# the perl version number will be helpful for diagnosing the problem
$logger_object->write_logfile_entry( $^V . "\n" );
}
}
else {
# Only warn of perl -c syntax errors. Other messages,
# such as missing modules, are too common. They can be
# seen by running with perltidy -w
$logger_object->complain("A syntax check using perl $flags\n");
$logger_object->complain(
"for the output in file $istream_filename gives:\n");
$logger_object->complain($line_of_dashes);
$logger_object->complain("$perl_output\n");
$logger_object->complain($line_of_dashes);
$infile_syntax_ok = -1;
$logger_object->write_logfile_entry($line_of_dashes);
$logger_object->write_logfile_entry(
"The output file will not be checked because of input file problems\n"
);
}
return $infile_syntax_ok;
}
sub do_syntax_check {
# This should not be called; the syntax check is deactivated
Die("Unexpected call for syntax check-shouldn't happen\n");
return;
}
1;
Perl-Tidy-20210717/t/ 0002755 0001750 0001750 00000000000 14074553103 013075 5 ustar steve steve Perl-Tidy-20210717/t/snippets16.t 0000644 0001750 0001750 00000027370 14072572630 015311 0 ustar steve steve # Created with: ./make_t.pl
# Contents:
#1 spp.spp1
#2 spp.spp2
#3 git16.def
#4 git10.def
#5 git10.git10
#6 multiple_equals.def
#7 align31.def
#8 almost1.def
#9 almost2.def
#10 almost3.def
#11 rt130394.def
#12 rt131115.def
#13 rt131115.rt131115
#14 ndsm1.def
#15 ndsm1.ndsm
#16 rt131288.def
#17 rt130394.rt130394
#18 git18.def
#19 here2.def
# To locate test #13 you can search for its name or the string '#13'
use strict;
use Test::More;
use Carp;
use Perl::Tidy;
my $rparams;
my $rsources;
my $rtests;
BEGIN {
###########################################
# BEGIN SECTION 1: Parameter combinations #
###########################################
$rparams = {
'def' => "",
'git10' => "-wn -ce -cbl=sort,map,grep",
'ndsm' => "-ndsm",
'rt130394' => "-olbn=1",
'rt131115' => "-bli",
'spp1' => "-spp=1",
'spp2' => "-spp=2",
};
############################
# BEGIN SECTION 2: Sources #
############################
$rsources = {
'align31' => <<'----------',
# do not align the commas
$w->insert(
ListBox => origin => [ 270, 160 ],
size => [ 200, 55 ],
);
----------
'almost1' => <<'----------',
# not a good alignment
my $realname = catfile( $dir, $file );
my $display_name = defined $disp ? catfile( $disp, $file ) : $file;
----------
'almost2' => <<'----------',
# not a good alignment
my $substname = ( $indtot > 1 ? $indname . $indno : $indname );
my $incname = $indname . ( $indtot > 1 ? $indno : "" );
----------
'almost3' => <<'----------',
# not a good alignment
sub head {
match_on_type @_ => Null => sub { die "Cannot get head of Null" },
ArrayRef => sub { $_->[0] };
}
----------
'git10' => <<'----------',
# perltidy -wn -ce -cbl=sort,map,grep
@sorted = map {
$_->[0]
} sort {
$a->[1] <=> $b->[1] or $a->[0] cmp $b->[0]
} map {
[ $_, length($_) ]
} @unsorted;
----------
'git16' => <<'----------',
# git#16, two equality lines with fat commas on the right
my $Package = $Self->RepositoryGet( %Param, Result => 'SCALAR' );
my %Structure = $Self->PackageParse( String => $Package );
----------
'git18' => <<'----------',
# parsing stuff like 'x17' before fat comma
my %bb = (
123x18 => '123x18',
123 x19 => '123 x19',
123x 20 => '123x 20',
2 x 7 => '2 x 7',
x40 => 'x40',
'd' x17 => "'d' x17",
c x17 => 'c x17',
);
foreach my $key ( keys %bb ) {
print "key='$key' => $bb{$key}\n";
}
----------
'here2' => <<'----------',
$_ = "";
s|(?:)|"${\< <<'----------',
# ignore second '=' here
$| = $debug = 1 if $opt_d;
$full_index = 1 if $opt_i;
$query_all = $opt_A if $opt_A;
# not aligning multiple '='s here
$start = $end = $len = $ismut = $number = $allele_ori = $allele_mut =
$proof = $xxxxreg = $reg = $dist = '';
----------
'ndsm1' => <<'----------',
;;;;; # 1 trapped semicolon
sub numerically {$a <=> $b};
;;;;;
sub Numerically {$a <=> $b}; # trapped semicolon
@: = qw;2c72656b636168
2020202020
;; __;
----------
'rt130394' => <<'----------',
# rt130394: keep on one line with -olbn=1
$factorial = sub { reduce { $a * $b } 1 .. 11 };
----------
'rt131115' => <<'----------',
# closing braces to be inteded with -bli
sub a {
my %uniq;
foreach my $par (@_) {
$uniq{$par} = 1;
}
}
----------
'rt131288' => <<'----------',
sub OptArgs2::STYLE_FULL { 3 }
$style == OptArgs2::STYLE_FULL ? 'FullUsage' : 'NormalUsage', 'usage: ' . $usage . "\n";
----------
'spp' => <<'----------',
sub get_val() { }
sub get_Val () { }
sub Get_val () { }
my $sub1=sub () { };
my $sub2=sub () { };
----------
};
####################################
# BEGIN SECTION 3: Expected output #
####################################
$rtests = {
'spp.spp1' => {
source => "spp",
params => "spp1",
expect => <<'#1...........',
sub get_val() { }
sub get_Val () { }
sub Get_val () { }
my $sub1 = sub () { };
my $sub2 = sub () { };
#1...........
},
'spp.spp2' => {
source => "spp",
params => "spp2",
expect => <<'#2...........',
sub get_val () { }
sub get_Val () { }
sub Get_val () { }
my $sub1 = sub () { };
my $sub2 = sub () { };
#2...........
},
'git16.def' => {
source => "git16",
params => "def",
expect => <<'#3...........',
# git#16, two equality lines with fat commas on the right
my $Package = $Self->RepositoryGet( %Param, Result => 'SCALAR' );
my %Structure = $Self->PackageParse( String => $Package );
#3...........
},
'git10.def' => {
source => "git10",
params => "def",
expect => <<'#4...........',
# perltidy -wn -ce -cbl=sort,map,grep
@sorted =
map { $_->[0] }
sort { $a->[1] <=> $b->[1] or $a->[0] cmp $b->[0] }
map { [ $_, length($_) ] } @unsorted;
#4...........
},
'git10.git10' => {
source => "git10",
params => "git10",
expect => <<'#5...........',
# perltidy -wn -ce -cbl=sort,map,grep
@sorted = map {
$_->[0]
} sort {
$a->[1] <=> $b->[1] or $a->[0] cmp $b->[0]
} map {
[ $_, length($_) ]
} @unsorted;
#5...........
},
'multiple_equals.def' => {
source => "multiple_equals",
params => "def",
expect => <<'#6...........',
# ignore second '=' here
$| = $debug = 1 if $opt_d;
$full_index = 1 if $opt_i;
$query_all = $opt_A if $opt_A;
# not aligning multiple '='s here
$start = $end = $len = $ismut = $number = $allele_ori = $allele_mut = $proof =
$xxxxreg = $reg = $dist = '';
#6...........
},
'align31.def' => {
source => "align31",
params => "def",
expect => <<'#7...........',
# do not align the commas
$w->insert(
ListBox => origin => [ 270, 160 ],
size => [ 200, 55 ],
);
#7...........
},
'almost1.def' => {
source => "almost1",
params => "def",
expect => <<'#8...........',
# not a good alignment
my $realname = catfile( $dir, $file );
my $display_name = defined $disp ? catfile( $disp, $file ) : $file;
#8...........
},
'almost2.def' => {
source => "almost2",
params => "def",
expect => <<'#9...........',
# not a good alignment
my $substname = ( $indtot > 1 ? $indname . $indno : $indname );
my $incname = $indname . ( $indtot > 1 ? $indno : "" );
#9...........
},
'almost3.def' => {
source => "almost3",
params => "def",
expect => <<'#10...........',
# not a good alignment
sub head {
match_on_type @_ => Null => sub { die "Cannot get head of Null" },
ArrayRef => sub { $_->[0] };
}
#10...........
},
'rt130394.def' => {
source => "rt130394",
params => "def",
expect => <<'#11...........',
# rt130394: keep on one line with -olbn=1
$factorial = sub {
reduce { $a * $b } 1 .. 11;
};
#11...........
},
'rt131115.def' => {
source => "rt131115",
params => "def",
expect => <<'#12...........',
# closing braces to be inteded with -bli
sub a {
my %uniq;
foreach my $par (@_) {
$uniq{$par} = 1;
}
}
#12...........
},
'rt131115.rt131115' => {
source => "rt131115",
params => "rt131115",
expect => <<'#13...........',
# closing braces to be inteded with -bli
sub a
{
my %uniq;
foreach my $par (@_)
{
$uniq{$par} = 1;
}
}
#13...........
},
'ndsm1.def' => {
source => "ndsm1",
params => "def",
expect => <<'#14...........',
; # 1 trapped semicolon
sub numerically { $a <=> $b }
sub Numerically { $a <=> $b }; # trapped semicolon
@: = qw;2c72656b636168
2020202020
;;
__;
#14...........
},
'ndsm1.ndsm' => {
source => "ndsm1",
params => "ndsm",
expect => <<'#15...........',
;
;
;
;
; # 1 trapped semicolon
sub numerically { $a <=> $b };
;
;
;
;
;
sub Numerically { $a <=> $b }; # trapped semicolon
@: = qw;2c72656b636168
2020202020
;;
__;
#15...........
},
'rt131288.def' => {
source => "rt131288",
params => "def",
expect => <<'#16...........',
sub OptArgs2::STYLE_FULL { 3 }
$style == OptArgs2::STYLE_FULL ? 'FullUsage' : 'NormalUsage',
'usage: ' . $usage . "\n";
#16...........
},
'rt130394.rt130394' => {
source => "rt130394",
params => "rt130394",
expect => <<'#17...........',
# rt130394: keep on one line with -olbn=1
$factorial = sub { reduce { $a * $b } 1 .. 11 };
#17...........
},
'git18.def' => {
source => "git18",
params => "def",
expect => <<'#18...........',
# parsing stuff like 'x17' before fat comma
my %bb = (
123 x 18 => '123x18',
123 x 19 => '123 x19',
123 x 20 => '123x 20',
2 x 7 => '2 x 7',
x40 => 'x40',
'd' x 17 => "'d' x17",
c x17 => 'c x17',
);
foreach my $key ( keys %bb ) {
print "key='$key' => $bb{$key}\n";
}
#18...........
},
'here2.def' => {
source => "here2",
params => "def",
expect => <<'#19...........',
$_ = "";
s|(?:)|"${\< $ntests;
}
###############
# EXECUTE TESTS
###############
foreach my $key ( sort keys %{$rtests} ) {
my $output;
my $sname = $rtests->{$key}->{source};
my $expect = $rtests->{$key}->{expect};
my $pname = $rtests->{$key}->{params};
my $source = $rsources->{$sname};
my $params = defined($pname) ? $rparams->{$pname} : "";
my $stderr_string;
my $errorfile_string;
my $err = Perl::Tidy::perltidy(
source => \$source,
destination => \$output,
perltidyrc => \$params,
argv => '', # for safety; hide any ARGV from perltidy
stderr => \$stderr_string,
errorfile => \$errorfile_string, # not used when -se flag is set
);
if ( $err || $stderr_string || $errorfile_string ) {
print STDERR "Error output received for test '$key'\n";
if ($err) {
print STDERR "An error flag '$err' was returned\n";
ok( !$err );
}
if ($stderr_string) {
print STDERR "---------------------\n";
print STDERR "<>\n$stderr_string\n";
print STDERR "---------------------\n";
ok( !$stderr_string );
}
if ($errorfile_string) {
print STDERR "---------------------\n";
print STDERR "<<.ERR file>>\n$errorfile_string\n";
print STDERR "---------------------\n";
ok( !$errorfile_string );
}
}
else {
if ( !is( $output, $expect, $key ) ) {
my $leno = length($output);
my $lene = length($expect);
if ( $leno == $lene ) {
print STDERR
"#> Test '$key' gave unexpected output. Strings differ but both have length $leno\n";
}
else {
print STDERR
"#> Test '$key' gave unexpected output. String lengths differ: output=$leno, expected=$lene\n";
}
}
}
}
Perl-Tidy-20210717/t/snippets13.t 0000644 0001750 0001750 00000034001 14072572630 015273 0 ustar steve steve # Created with: ./make_t.pl
# Contents:
#1 align10.def
#2 align11.def
#3 align12.def
#4 align13.def
#5 rt127633.def
#6 rt127633.rt127633
#7 align14.def
#8 align15.def
#9 align16.def
#10 break5.def
#11 align19.def
#12 align20.def
#13 align21.def
#14 align22.def
#15 align23.def
#16 align24.def
#17 align25.def
#18 align26.def
#19 align27.def
# To locate test #13 you can search for its name or the string '#13'
use strict;
use Test::More;
use Carp;
use Perl::Tidy;
my $rparams;
my $rsources;
my $rtests;
BEGIN {
###########################################
# BEGIN SECTION 1: Parameter combinations #
###########################################
$rparams = {
'def' => "",
'rt127633' => "-baao",
};
############################
# BEGIN SECTION 2: Sources #
############################
$rsources = {
'align10' => <<'----------',
$message =~ &rhs_wordwrap( $message, $width );
$message_len =~ split( /^/, $message );
----------
'align11' => <<'----------',
my $accountno = getnextacctno( $env, $bornum, $dbh );
my $item = getiteminformation( $env, $itemno );
my $account = "Insert into accountlines
bla bla";
----------
'align12' => <<'----------',
my $type = shift || "o";
my $fname = ( $type eq 'oo' ? 'orte_city' : 'orte' );
my $suffix = ( $coord_system eq 'standard' ? '' : '-orig' );
----------
'align13' => <<'----------',
# symbols =~ and !~ are equivalent in alignment
ok( $out !~ /EXACT /, "No 'baz'" );
ok( $out =~ //, "Got 'liz'" ); # liz
ok( $out =~ //, "Got 'zoo'" ); # zoo
ok( $out !~ //, "Got 'zap'" ); # zap
----------
'align14' => <<'----------',
# align the =
my($apple)=new Fruit("Apple1",.1,.30);
my($grapefruit)=new Grapefruit("Grapefruit1",.3);
my($redgrapefruit)=new RedGrapefruit("Grapefruit2",.3);
----------
'align15' => <<'----------',
# align both = and //
my$color=$opts{'-color'}//'black';
my$background=$opts{'-background'}//'none';
my$linewidth=$opts{'-linewidth'}//1;
my$radius=$opts{'-radius'}//0;
----------
'align16' => <<'----------',
# align all at first =>
use constant {
PHFAM => [ { John => 1, Jane => 2, Sally => 3 }, 33, 28, 3 ],
FAMILY => [qw( John Jane Sally )],
AGES => { John => 33, Jane => 28, Sally => 3 },
RFAM => [ [qw( John Jane Sally )] ],
THREE => 3,
SPIT => sub { shift },
};
----------
'align19' => <<'----------',
# different lhs patterns, do not align the '='
@_ = qw(sort grep map do eval);
@is_not_zero_continuation_block_type{@_} = (1) x scalar(@_);
----------
'align20' => <<'----------',
# marginal two-line match; different lhs patterns; do not align
$w[$i] = $t;
$t = 1000000;
----------
'align21' => <<'----------',
# two lines with large gap but same lhs pattern so align equals
local (@pieces) = split( /\./, $filename, 2 );
local ($just_dir_and_base) = $pieces[0];
# two lines with 3 alignment tokens
$expect = "1$expect" if $expect =~ /^e/i;
$p = "1$p" if defined $p and $p =~ /^e/i;
# two lines where alignment causes a large gap
is( eval { sysopen( my $ro, $foo, &O_RDONLY | $TAINT0 ) }, undef );
is( $@, '' );
----------
'align22' => <<'----------',
# two equality lines with different patterns to left of equals do not align
$signame{$_} = ++$signal;
$signum[$signal] = $_;
----------
'align23' => <<'----------',
# two equality lines with same pattern on left of equals will align
my $orig = my $format = "^<<<<< ~~\n";
my $abc = "abc";
----------
'align24' => <<'----------',
# Do not align interior fat commas here; different container types
my $p = TAP::Parser::SubclassTest->new(
{
exec => [ $cat => $file ],
sources => { MySourceHandler => { accept_all => 1 } },
}
);
----------
'align25' => <<'----------',
# do not align internal commas here; different container types
is_deeply( [ $a, $a ], [ $b, $c ] );
is_deeply( { foo => $a, bar => $a }, { foo => $b, bar => $c } );
is_deeply( [ \$a, \$a ], [ \$b, \$c ] );
----------
'align26' => <<'----------',
# align first of multiple equals
$SIG{PIPE}=sub{die"writingtoaclosedpipe"};
$SIG{BREAK}=$SIG{INT}=$SIG{TERM};
$SIG{HUP}=\&some_handler;
----------
'align27' => <<'----------',
# do not align first equals here (unmatched commas on left side of =)
my ( $self, $name, $type ) = @_;
my $html_toc_fh = $self->{_html_toc_fh};
my $html_prelim_fh = $self->{_html_prelim_fh};
----------
'break5' => <<'----------',
# do not break at .'s after the ?
return (
( $pod eq $pod2 ) & amp;
&
( $htype eq "NAME" )
)
? "\n<A NAME=\""
. $value
. "\">\n$text</A>\n"
: "\n$type$pod2.html\#" . $value . "\">$text<\/A>\n";
----------
'rt127633' => <<'----------',
# keep lines long; do not break after 'return' and '.' with -baoo
return $ref eq 'SCALAR' ? $self->encode_scalar( $object, $name, $type, $attr ) : $ref eq 'ARRAY';
my $s = 'aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa' . 'bbbbbbbbbbbbbbbbbbbbbbbbb';
----------
};
####################################
# BEGIN SECTION 3: Expected output #
####################################
$rtests = {
'align10.def' => {
source => "align10",
params => "def",
expect => <<'#1...........',
$message =~ &rhs_wordwrap( $message, $width );
$message_len =~ split( /^/, $message );
#1...........
},
'align11.def' => {
source => "align11",
params => "def",
expect => <<'#2...........',
my $accountno = getnextacctno( $env, $bornum, $dbh );
my $item = getiteminformation( $env, $itemno );
my $account = "Insert into accountlines
bla bla";
#2...........
},
'align12.def' => {
source => "align12",
params => "def",
expect => <<'#3...........',
my $type = shift || "o";
my $fname = ( $type eq 'oo' ? 'orte_city' : 'orte' );
my $suffix = ( $coord_system eq 'standard' ? '' : '-orig' );
#3...........
},
'align13.def' => {
source => "align13",
params => "def",
expect => <<'#4...........',
# symbols =~ and !~ are equivalent in alignment
ok( $out !~ /EXACT /, "No 'baz'" );
ok( $out =~ //, "Got 'liz'" ); # liz
ok( $out =~ //, "Got 'zoo'" ); # zoo
ok( $out !~ //, "Got 'zap'" ); # zap
#4...........
},
'rt127633.def' => {
source => "rt127633",
params => "def",
expect => <<'#5...........',
# keep lines long; do not break after 'return' and '.' with -baoo
return $ref eq 'SCALAR'
? $self->encode_scalar( $object, $name, $type, $attr )
: $ref eq 'ARRAY';
my $s = 'aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa'
. 'bbbbbbbbbbbbbbbbbbbbbbbbb';
#5...........
},
'rt127633.rt127633' => {
source => "rt127633",
params => "rt127633",
expect => <<'#6...........',
# keep lines long; do not break after 'return' and '.' with -baoo
return $ref eq 'SCALAR' ? $self->encode_scalar( $object, $name, $type, $attr ) :
$ref eq 'ARRAY';
my $s = 'aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa' .
'bbbbbbbbbbbbbbbbbbbbbbbbb';
#6...........
},
'align14.def' => {
source => "align14",
params => "def",
expect => <<'#7...........',
# align the =
my ($apple) = new Fruit( "Apple1", .1, .30 );
my ($grapefruit) = new Grapefruit( "Grapefruit1", .3 );
my ($redgrapefruit) = new RedGrapefruit( "Grapefruit2", .3 );
#7...........
},
'align15.def' => {
source => "align15",
params => "def",
expect => <<'#8...........',
# align both = and //
my $color = $opts{'-color'} // 'black';
my $background = $opts{'-background'} // 'none';
my $linewidth = $opts{'-linewidth'} // 1;
my $radius = $opts{'-radius'} // 0;
#8...........
},
'align16.def' => {
source => "align16",
params => "def",
expect => <<'#9...........',
# align all at first =>
use constant {
PHFAM => [ { John => 1, Jane => 2, Sally => 3 }, 33, 28, 3 ],
FAMILY => [qw( John Jane Sally )],
AGES => { John => 33, Jane => 28, Sally => 3 },
RFAM => [ [qw( John Jane Sally )] ],
THREE => 3,
SPIT => sub { shift },
};
#9...........
},
'break5.def' => {
source => "break5",
params => "def",
expect => <<'#10...........',
# do not break at .'s after the ?
return (
( $pod eq $pod2 ) & amp;
&
( $htype eq "NAME" )
)
? "\n<A NAME=\"" . $value . "\">\n$text</A>\n"
: "\n$type$pod2.html\#" . $value . "\">$text<\/A>\n";
#10...........
},
'align19.def' => {
source => "align19",
params => "def",
expect => <<'#11...........',
# different lhs patterns, do not align the '='
@_ = qw(sort grep map do eval);
@is_not_zero_continuation_block_type{@_} = (1) x scalar(@_);
#11...........
},
'align20.def' => {
source => "align20",
params => "def",
expect => <<'#12...........',
# marginal two-line match; different lhs patterns; do not align
$w[$i] = $t;
$t = 1000000;
#12...........
},
'align21.def' => {
source => "align21",
params => "def",
expect => <<'#13...........',
# two lines with large gap but same lhs pattern so align equals
local (@pieces) = split( /\./, $filename, 2 );
local ($just_dir_and_base) = $pieces[0];
# two lines with 3 alignment tokens
$expect = "1$expect" if $expect =~ /^e/i;
$p = "1$p" if defined $p and $p =~ /^e/i;
# two lines where alignment causes a large gap
is( eval { sysopen( my $ro, $foo, &O_RDONLY | $TAINT0 ) }, undef );
is( $@, '' );
#13...........
},
'align22.def' => {
source => "align22",
params => "def",
expect => <<'#14...........',
# two equality lines with different patterns to left of equals do not align
$signame{$_} = ++$signal;
$signum[$signal] = $_;
#14...........
},
'align23.def' => {
source => "align23",
params => "def",
expect => <<'#15...........',
# two equality lines with same pattern on left of equals will align
my $orig = my $format = "^<<<<< ~~\n";
my $abc = "abc";
#15...........
},
'align24.def' => {
source => "align24",
params => "def",
expect => <<'#16...........',
# Do not align interior fat commas here; different container types
my $p = TAP::Parser::SubclassTest->new(
{
exec => [ $cat => $file ],
sources => { MySourceHandler => { accept_all => 1 } },
}
);
#16...........
},
'align25.def' => {
source => "align25",
params => "def",
expect => <<'#17...........',
# do not align internal commas here; different container types
is_deeply( [ $a, $a ], [ $b, $c ] );
is_deeply( { foo => $a, bar => $a }, { foo => $b, bar => $c } );
is_deeply( [ \$a, \$a ], [ \$b, \$c ] );
#17...........
},
'align26.def' => {
source => "align26",
params => "def",
expect => <<'#18...........',
# align first of multiple equals
$SIG{PIPE} = sub { die "writingtoaclosedpipe" };
$SIG{BREAK} = $SIG{INT} = $SIG{TERM};
$SIG{HUP} = \&some_handler;
#18...........
},
'align27.def' => {
source => "align27",
params => "def",
expect => <<'#19...........',
# do not align first equals here (unmatched commas on left side of =)
my ( $self, $name, $type ) = @_;
my $html_toc_fh = $self->{_html_toc_fh};
my $html_prelim_fh = $self->{_html_prelim_fh};
#19...........
},
};
my $ntests = 0 + keys %{$rtests};
plan tests => $ntests;
}
###############
# EXECUTE TESTS
###############
foreach my $key ( sort keys %{$rtests} ) {
my $output;
my $sname = $rtests->{$key}->{source};
my $expect = $rtests->{$key}->{expect};
my $pname = $rtests->{$key}->{params};
my $source = $rsources->{$sname};
my $params = defined($pname) ? $rparams->{$pname} : "";
my $stderr_string;
my $errorfile_string;
my $err = Perl::Tidy::perltidy(
source => \$source,
destination => \$output,
perltidyrc => \$params,
argv => '', # for safety; hide any ARGV from perltidy
stderr => \$stderr_string,
errorfile => \$errorfile_string, # not used when -se flag is set
);
if ( $err || $stderr_string || $errorfile_string ) {
print STDERR "Error output received for test '$key'\n";
if ($err) {
print STDERR "An error flag '$err' was returned\n";
ok( !$err );
}
if ($stderr_string) {
print STDERR "---------------------\n";
print STDERR "<>\n$stderr_string\n";
print STDERR "---------------------\n";
ok( !$stderr_string );
}
if ($errorfile_string) {
print STDERR "---------------------\n";
print STDERR "<<.ERR file>>\n$errorfile_string\n";
print STDERR "---------------------\n";
ok( !$errorfile_string );
}
}
else {
if ( !is( $output, $expect, $key ) ) {
my $leno = length($output);
my $lene = length($expect);
if ( $leno == $lene ) {
print STDERR
"#> Test '$key' gave unexpected output. Strings differ but both have length $leno\n";
}
else {
print STDERR
"#> Test '$key' gave unexpected output. String lengths differ: output=$leno, expected=$lene\n";
}
}
}
}
Perl-Tidy-20210717/t/filter_example.t 0000755 0001750 0001750 00000003010 13743146146 016264 0 ustar steve steve # Test use of prefilter and postfilter parameters
use strict;
use Carp;
use Perl::Tidy;
use Test::More;
my $name = 'filter_example';
BEGIN {
plan tests => 1;
}
my $source = <<'ENDS';
use Method::Signatures::Simple;
method foo1 { $self->bar }
# with signature
method foo2($bar, %opts) { $self->bar(reverse $bar) if $opts{rev};
}
# attributes
method foo3 : lvalue { $self->{foo}
}
# change invocant name
method
foo4 ( $class : $bar ) { $class->bar($bar) }
ENDS
my $expect = <<'ENDE';
use Method::Signatures::Simple;
method foo1 { $self->bar }
# with signature
method foo2 ( $bar, %opts ) {
$self->bar( reverse $bar ) if $opts{rev};
}
# attributes
method foo3 : lvalue {
$self->{foo};
}
# change invocant name
method foo4 ( $class : $bar ) { $class->bar($bar) }
ENDE
my $output;
my $stderr_string;
my $errorfile_string;
my $params = "";
my $err = Perl::Tidy::perltidy(
#argv => '-npro', # fix for RT#127679, avoid reading unwanted .perltidyrc
argv => '',
perltidyrc => \$params, # avoid reading unwanted .perltidyrc
prefilter =>
sub { $_ = $_[0]; s/^\s*method\s+(\w.*)/sub METHOD_$1/gm; return $_ },
postfilter => sub { $_ = $_[0]; s/sub\s+METHOD_/method /gm; return $_ },
source => \$source,
destination => \$output,
stderr => \$stderr_string,
errorfile => \$errorfile_string, # not used when -se flag is set
);
if ( $err || $stderr_string || $errorfile_string ) {
ok(0);
}
else {
is( $output, $expect, $name );
}
Perl-Tidy-20210717/t/snippets14.t 0000644 0001750 0001750 00000074711 14072572630 015310 0 ustar steve steve # Created with: ./make_t.pl
# Contents:
#1 else1.def
#2 else2.def
#3 ternary3.def
#4 align17.def
#5 align18.def
#6 kgb1.def
#7 kgb1.kgb
#8 kgb2.def
#9 kgb2.kgb
#10 kgb3.def
#11 kgb3.kgb
#12 kgb4.def
#13 kgb4.kgb
#14 kgb5.def
#15 kgb5.kgb
#16 kgbd.def
#17 kgbd.kgbd
#18 kgb_tight.def
#19 gnu5.def
# To locate test #13 you can search for its name or the string '#13'
use strict;
use Test::More;
use Carp;
use Perl::Tidy;
my $rparams;
my $rsources;
my $rtests;
BEGIN {
###########################################
# BEGIN SECTION 1: Parameter combinations #
###########################################
$rparams = {
'def' => "",
'kgb' => "-kgb",
'kgbd' => "-kgbd -kgb",
};
############################
# BEGIN SECTION 2: Sources #
############################
$rsources = {
'align17' => <<'----------',
# align => even at broken sub block
my%opt=(
'cc'=>sub{$param::cachecom=1;},
'cd'=>sub{$param::cachedisable=1;},
'p'=>sub{
$param::pflag=1;
$param::build=0;
}
);
----------
'align18' => <<'----------',
#align '&&'
for($ENV{HTTP_USER_AGENT}){
$page=
/Mac/&&'m/Macintrash.html'
||/Win(dows)?NT/&&'e/evilandrude.html'
||/Win|MSIE|WebTV/&&'m/MicroslothWindows.html'
||/Linux/&&'l/Linux.html'
||/HP-UX/&&'h/HP-SUX.html'
||/SunOS/&&'s/ScumOS.html'
||'a/AppendixB.html';
}
----------
'else1' => <<'----------',
# pad after 'if' when followed by 'elsif'
if ( not defined $dir or not length $dir ) { $rslt = ''; }
elsif ( $dir =~ /^\$\([^\)]+\)\Z(?!\n)/s ) { $rslt = $dir; }
else { $rslt = vmspath($dir); }
----------
'else2' => <<'----------',
# no pad after 'if' when followed by 'else'
if ( $m = $g[$x][$y] ) { print $$m{v}; $$m{i}->() }
else { print " " }
----------
'gnu5' => <<'----------',
# side comments limit gnu type formatting with l=80; note extra comma
push @tests, [
"Lowest code point requiring 13 bytes to represent", # 2**36
"\xff\x80\x80\x80\x80\x80\x81\x80\x80\x80\x80\x80\x80",
($::is64bit) ? 0x1000000000 : -1, # overflows on 32bit
],
;
----------
'kgb1' => <<'----------',
# a variety of line types for testing -kgb
use strict;
use Test;
use Encode qw(from_to encode decode
encode_utf8 decode_utf8
find_encoding is_utf8);
use charnames qw(greek);
our $targetdir = "/usr/local/doc/HTML/Perl";
local (
$tocfile, $loffile, $lotfile, $footfile,
$citefile, $idxfile, $figure_captions, $table_captions,
$footnotes, $citations, %font_size, %index,
%done, $t_title, $t_author, $t_date,
$t_address, $t_affil, $changed
);
my @UNITCHECKs =
B::unitcheck_av->isa("B::AV")
? B::unitcheck_av->ARRAY
: ();
my @CHECKs = B::check_av->isa("B::AV") ? B::check_av->ARRAY : ();
my $dna = Bio::LiveSeq::DNA->new( -seq => $dnasequence );
my $min = 1;
my $max = length($dnasequence);
my $T = $G->_strongly_connected;
my %R = $T->vertex_roots;
my @C; # We're not calling the strongly_connected_components()
# Do not separate this hanging side comment from previous
my $G = shift;
my $exon = Bio::LiveSeq::Exon->new(
-seq => $dna,
-start => $min,
-end => $max,
-strand => 1
);
my $octal_mode;
my @inputs = (
0777, 0700, 0470, 0407, 0433, 0400, 0430, 0403, 0111, 0100,
0110, 0101, 0731, 0713, 0317, 0371, 0173, 0137
);
my $impulse =
( 1 - $factor ) * ( 170 - $u ) +
( 350 / $u**0.65 + 500 / $u**5 ) * $factor;
my $r = q{
pm_to_blib: $(TO_INST_PM)
};
my $regcomp_re =
"(?ckWARN(?:\\d+)?reg\\w*|vWARN\\d+|$regcomp_fail_re)";
my $position = List::MoreUtils::firstidx {
refaddr $_ == $key
}
my @exons = ($exon);
my $fastafile2 = "/tmp/tmpfastafile2";
my $grepcut = 'egrep -v "[[:digit:]]|^ *$|sequences" | cut -c8-'; # grep/cut
my $alignprogram =
"/usr/local/etc/bioinfo/fasta2/align -s /usr/local/etc/bioinfo/fasta2/idnaa.mat $fastafile1 $fastafile2 2>/dev/null | $grepcut"
; # ALIGN
my $xml = new Mioga::XML::Simple( forcearray => 1 );
my $xml_tree = $xml->XMLin($skel_file);
my $skel_name =
( exists( $xml_tree->{'name'} ) ) ? $xml_tree->{'name'} : "";
my $grp = GroupGetValues( $conf->{dbh}, $group_id );
my $adm_profile =
ProfileGetUser( $conf->{dbh}, $grp->{id_admin}, $group_id );
my $harness = TAP::Harness->new(
{ verbosity => 1, formatter_class => "TAP::Formatter::Console" } );
require File::Temp;
require Time::HiRes;
my ( $fh, $filename ) = File::Temp::tempfile("Time-HiRes-utime-XXXXXXXXX");
use File::Basename qw[dirname];
my $dirname = dirname($filename);
my $CUT = qr/\n=cut.*$EOP/;
my $pod_or_DATA = qr/
^=(?:head[1-4]|item) .*? $CUT
| ^=pod .*? $CUT
| ^=for .*? $CUT
| ^=begin .*? $CUT
| ^__(DATA|END)__\r?\n.*
/smx;
require Cwd;
( my $boot = $self->{NAME} ) =~ s/:/_/g;
doit(
sub { @E::ISA = qw/F/ },
sub { @E::ISA = qw/D/; @C::ISA = qw/F/ },
sub { @C::ISA = qw//; @A::ISA = qw/K/ },
sub { @A::ISA = qw//; @J::ISA = qw/F K/ },
sub { @J::ISA = qw/F/; @H::ISA = qw/K G/ },
sub { @H::ISA = qw/G/; @B::ISA = qw/B/ },
sub { @B::ISA = qw//; @K::ISA = qw/K J I/ },
sub { @K::ISA = qw/J I/; @D::ISA = qw/A H B C/ },
return;
);
my %extractor_for = (
quotelike => [ $ws, $variable, $id, { MATCH => \&extract_quotelike } ],
regex => [ $ws, $pod_or_DATA, $id, $exql ],
string => [ $ws, $pod_or_DATA, $id, $exql ],
code => [
$ws, { DONT_MATCH => $pod_or_DATA },
$variable, $id, { DONT_MATCH => \&extract_quotelike }
],
code_no_comments => [
{ DONT_MATCH => $comment },
$ncws, { DONT_MATCH => $pod_or_DATA },
$variable, $id, { DONT_MATCH => \&extract_quotelike }
],
executable => [ $ws, { DONT_MATCH => $pod_or_DATA } ],
executable_no_comments =>
[ { DONT_MATCH => $comment }, $ncws, { DONT_MATCH => $pod_or_DATA } ],
all => [ { MATCH => qr/(?s:.*)/ } ],
);
exit 1;
----------
'kgb2' => <<'----------',
# with -kgb, do no break after last my
sub next_sibling {
my $self = shift;
my $parent = $_PARENT{refaddr $self} or return '';
my $key = refaddr $self;
my $elements = $parent->{children};
my $position = List::MoreUtils::firstidx {
refaddr $_ == $key
} @$elements;
$elements->[$position + 1] || '';
}
----------
'kgb3' => <<'----------',
#!/usr/bin/perl -w
use strict; # with -kgb, no break after hash bang
our ( @Changed, $TAP ); # break after isolated 'our'
use File::Compare;
use Symbol;
use Text::Wrap();
use Text::Warp();
use Blast::IPS::MathUtils qw(
set_interpolation_points
table_row_interpolation
two_point_interpolation
); # with -kgb, break around isolated 'local' below
use Text::Warp();
local($delta2print) =
(defined $size) ? int($size/50) : $defaultdelta2print;
print "break before this line\n";
----------
'kgb4' => <<'----------',
print "hello"; # with -kgb, break after this line
use strict;
use warnings;
use Test::More tests => 1;
use Pod::Simple::XHTML;
my $c = < <<'----------',
# with -kgb, do not put blank in ternary
print "Starting\n"; # with -kgb, break after this line
my $A = "1";
my $B = "0";
my $C = "1";
my $D = "1";
my $result =
$A
? $B
? $C
? "+A +B +C"
: "+A +B -C"
: "+A -B"
: "-A";
my $F = "0";
print "with -kgb, put blank above this line; result=$result\n";
----------
'kgb_tight' => <<'----------',
# a variety of line types for testing -kgb
use strict;
use Test;
use Encode qw(from_to encode decode
encode_utf8 decode_utf8
find_encoding is_utf8);
use charnames qw(greek);
our $targetdir = "/usr/local/doc/HTML/Perl";
local (
$tocfile, $loffile, $lotfile, $footfile,
$citefile, $idxfile, $figure_captions, $table_captions,
$footnotes, $citations, %font_size, %index,
%done, $t_title, $t_author, $t_date,
$t_address, $t_affil, $changed
);
my @UNITCHECKs =
B::unitcheck_av->isa("B::AV")
? B::unitcheck_av->ARRAY
: ();
my @CHECKs = B::check_av->isa("B::AV") ? B::check_av->ARRAY : ();
my $dna = Bio::LiveSeq::DNA->new( -seq => $dnasequence );
my $min = 1;
my $max = length($dnasequence);
my $T = $G->_strongly_connected;
my %R = $T->vertex_roots;
my @C; # We're not calling the strongly_connected_components()
# Do not separate this hanging side comment from previous
my $G = shift;
my $exon = Bio::LiveSeq::Exon->new(
-seq => $dna,
-start => $min,
-end => $max,
-strand => 1
);
my @inputs = (
0777, 0700, 0470, 0407, 0433, 0400, 0430, 0403, 0111, 0100,
0110, 0101, 0731, 0713, 0317, 0371, 0173, 0137
);
my $impulse =
( 1 - $factor ) * ( 170 - $u ) +
( 350 / $u**0.65 + 500 / $u**5 ) * $factor;
my $r = q{
pm_to_blib: $(TO_INST_PM)
};
my $regcomp_re =
"(?ckWARN(?:\\d+)?reg\\w*|vWARN\\d+|$regcomp_fail_re)";
my $position = List::MoreUtils::firstidx {
refaddr $_ == $key
}
my $alignprogram =
"/usr/local/etc/bioinfo/fasta2/align -s /usr/local/etc/bioinfo/fasta2/idnaa.mat $fastafile1 $fastafile2 2>/dev/null | $grepcut"
; # ALIGN
my $skel_name =
( exists( $xml_tree->{'name'} ) ) ? $xml_tree->{'name'} : "";
my $grp = GroupGetValues( $conf->{dbh}, $group_id );
my $adm_profile =
ProfileGetUser( $conf->{dbh}, $grp->{id_admin}, $group_id );
my $harness = TAP::Harness->new(
{ verbosity => 1, formatter_class => "TAP::Formatter::Console" } );
require File::Temp;
require Time::HiRes;
my ( $fh, $filename ) = File::Temp::tempfile("Time-HiRes-utime-XXXXXXXXX");
use File::Basename qw[dirname];
my $dirname = dirname($filename);
my $CUT = qr/\n=cut.*$EOP/;
my $pod_or_DATA = qr/
^=(?:head[1-4]|item) .*? $CUT
| ^=pod .*? $CUT
| ^=for .*? $CUT
| ^=begin .*? $CUT
| ^__(DATA|END)__\r?\n.*
/smx;
require Cwd;
print "continuing\n";
exit 1;
----------
'kgbd' => <<'----------',
package A1::B2;
use strict;
require Exporter;
use A1::Context;
use A1::Database;
use A1::Bibliotek;
use A1::Author;
use A1::Title;
use vars qw($VERSION @ISA @EXPORT);
$VERSION = 0.01;
----------
'ternary3' => <<'----------',
# this previously caused trouble because of the = and =~
push( @aligns,
( ( $a = shift @a ) =~ /[^n]/ ) ? $a
: (@isnum) ? 'n'
: 'l' )
unless $opt_a;
----------
};
####################################
# BEGIN SECTION 3: Expected output #
####################################
$rtests = {
'else1.def' => {
source => "else1",
params => "def",
expect => <<'#1...........',
# pad after 'if' when followed by 'elsif'
if ( not defined $dir or not length $dir ) { $rslt = ''; }
elsif ( $dir =~ /^\$\([^\)]+\)\Z(?!\n)/s ) { $rslt = $dir; }
else { $rslt = vmspath($dir); }
#1...........
},
'else2.def' => {
source => "else2",
params => "def",
expect => <<'#2...........',
# no pad after 'if' when followed by 'else'
if ( $m = $g[$x][$y] ) { print $$m{v}; $$m{i}->() }
else { print " " }
#2...........
},
'ternary3.def' => {
source => "ternary3",
params => "def",
expect => <<'#3...........',
# this previously caused trouble because of the = and =~
push(
@aligns,
( ( $a = shift @a ) =~ /[^n]/ ) ? $a
: (@isnum) ? 'n'
: 'l'
) unless $opt_a;
#3...........
},
'align17.def' => {
source => "align17",
params => "def",
expect => <<'#4...........',
# align => even at broken sub block
my %opt = (
'cc' => sub { $param::cachecom = 1; },
'cd' => sub { $param::cachedisable = 1; },
'p' => sub {
$param::pflag = 1;
$param::build = 0;
}
);
#4...........
},
'align18.def' => {
source => "align18",
params => "def",
expect => <<'#5...........',
#align '&&'
for ( $ENV{HTTP_USER_AGENT} ) {
$page =
/Mac/ && 'm/Macintrash.html'
|| /Win(dows)?NT/ && 'e/evilandrude.html'
|| /Win|MSIE|WebTV/ && 'm/MicroslothWindows.html'
|| /Linux/ && 'l/Linux.html'
|| /HP-UX/ && 'h/HP-SUX.html'
|| /SunOS/ && 's/ScumOS.html'
|| 'a/AppendixB.html';
}
#5...........
},
'kgb1.def' => {
source => "kgb1",
params => "def",
expect => <<'#6...........',
# a variety of line types for testing -kgb
use strict;
use Test;
use Encode qw(from_to encode decode
encode_utf8 decode_utf8
find_encoding is_utf8);
use charnames qw(greek);
our $targetdir = "/usr/local/doc/HTML/Perl";
local (
$tocfile, $loffile, $lotfile, $footfile,
$citefile, $idxfile, $figure_captions, $table_captions,
$footnotes, $citations, %font_size, %index,
%done, $t_title, $t_author, $t_date,
$t_address, $t_affil, $changed
);
my @UNITCHECKs =
B::unitcheck_av->isa("B::AV")
? B::unitcheck_av->ARRAY
: ();
my @CHECKs = B::check_av->isa("B::AV") ? B::check_av->ARRAY : ();
my $dna = Bio::LiveSeq::DNA->new( -seq => $dnasequence );
my $min = 1;
my $max = length($dnasequence);
my $T = $G->_strongly_connected;
my %R = $T->vertex_roots;
my @C; # We're not calling the strongly_connected_components()
# Do not separate this hanging side comment from previous
my $G = shift;
my $exon = Bio::LiveSeq::Exon->new(
-seq => $dna,
-start => $min,
-end => $max,
-strand => 1
);
my $octal_mode;
my @inputs = (
0777, 0700, 0470, 0407, 0433, 0400, 0430, 0403, 0111, 0100,
0110, 0101, 0731, 0713, 0317, 0371, 0173, 0137
);
my $impulse =
( 1 - $factor ) * ( 170 - $u ) + ( 350 / $u**0.65 + 500 / $u**5 ) * $factor;
my $r = q{
pm_to_blib: $(TO_INST_PM)
};
my $regcomp_re =
"(?ckWARN(?:\\d+)?reg\\w*|vWARN\\d+|$regcomp_fail_re)";
my $position = List::MoreUtils::firstidx {
refaddr $_ == $key
}
my @exons = ($exon);
my $fastafile2 = "/tmp/tmpfastafile2";
my $grepcut = 'egrep -v "[[:digit:]]|^ *$|sequences" | cut -c8-'; # grep/cut
my $alignprogram =
"/usr/local/etc/bioinfo/fasta2/align -s /usr/local/etc/bioinfo/fasta2/idnaa.mat $fastafile1 $fastafile2 2>/dev/null | $grepcut"
; # ALIGN
my $xml = new Mioga::XML::Simple( forcearray => 1 );
my $xml_tree = $xml->XMLin($skel_file);
my $skel_name =
( exists( $xml_tree->{'name'} ) ) ? $xml_tree->{'name'} : "";
my $grp = GroupGetValues( $conf->{dbh}, $group_id );
my $adm_profile =
ProfileGetUser( $conf->{dbh}, $grp->{id_admin}, $group_id );
my $harness = TAP::Harness->new(
{ verbosity => 1, formatter_class => "TAP::Formatter::Console" } );
require File::Temp;
require Time::HiRes;
my ( $fh, $filename ) = File::Temp::tempfile("Time-HiRes-utime-XXXXXXXXX");
use File::Basename qw[dirname];
my $dirname = dirname($filename);
my $CUT = qr/\n=cut.*$EOP/;
my $pod_or_DATA = qr/
^=(?:head[1-4]|item) .*? $CUT
| ^=pod .*? $CUT
| ^=for .*? $CUT
| ^=begin .*? $CUT
| ^__(DATA|END)__\r?\n.*
/smx;
require Cwd;
( my $boot = $self->{NAME} ) =~ s/:/_/g;
doit(
sub { @E::ISA = qw/F/ },
sub { @E::ISA = qw/D/; @C::ISA = qw/F/ },
sub { @C::ISA = qw//; @A::ISA = qw/K/ },
sub { @A::ISA = qw//; @J::ISA = qw/F K/ },
sub { @J::ISA = qw/F/; @H::ISA = qw/K G/ },
sub { @H::ISA = qw/G/; @B::ISA = qw/B/ },
sub { @B::ISA = qw//; @K::ISA = qw/K J I/ },
sub { @K::ISA = qw/J I/; @D::ISA = qw/A H B C/ },
return;
);
my %extractor_for = (
quotelike => [ $ws, $variable, $id, { MATCH => \&extract_quotelike } ],
regex => [ $ws, $pod_or_DATA, $id, $exql ],
string => [ $ws, $pod_or_DATA, $id, $exql ],
code => [
$ws, { DONT_MATCH => $pod_or_DATA },
$variable, $id, { DONT_MATCH => \&extract_quotelike }
],
code_no_comments => [
{ DONT_MATCH => $comment },
$ncws, { DONT_MATCH => $pod_or_DATA },
$variable, $id, { DONT_MATCH => \&extract_quotelike }
],
executable => [ $ws, { DONT_MATCH => $pod_or_DATA } ],
executable_no_comments =>
[ { DONT_MATCH => $comment }, $ncws, { DONT_MATCH => $pod_or_DATA } ],
all => [ { MATCH => qr/(?s:.*)/ } ],
);
exit 1;
#6...........
},
'kgb1.kgb' => {
source => "kgb1",
params => "kgb",
expect => <<'#7...........',
# a variety of line types for testing -kgb
use strict;
use Test;
use Encode qw(from_to encode decode
encode_utf8 decode_utf8
find_encoding is_utf8);
use charnames qw(greek);
our $targetdir = "/usr/local/doc/HTML/Perl";
local (
$tocfile, $loffile, $lotfile, $footfile,
$citefile, $idxfile, $figure_captions, $table_captions,
$footnotes, $citations, %font_size, %index,
%done, $t_title, $t_author, $t_date,
$t_address, $t_affil, $changed
);
my @UNITCHECKs =
B::unitcheck_av->isa("B::AV")
? B::unitcheck_av->ARRAY
: ();
my @CHECKs = B::check_av->isa("B::AV") ? B::check_av->ARRAY : ();
my $dna = Bio::LiveSeq::DNA->new( -seq => $dnasequence );
my $min = 1;
my $max = length($dnasequence);
my $T = $G->_strongly_connected;
my %R = $T->vertex_roots;
my @C; # We're not calling the strongly_connected_components()
# Do not separate this hanging side comment from previous
my $G = shift;
my $exon = Bio::LiveSeq::Exon->new(
-seq => $dna,
-start => $min,
-end => $max,
-strand => 1
);
my $octal_mode;
my @inputs = (
0777, 0700, 0470, 0407, 0433, 0400, 0430, 0403, 0111, 0100,
0110, 0101, 0731, 0713, 0317, 0371, 0173, 0137
);
my $impulse =
( 1 - $factor ) * ( 170 - $u ) + ( 350 / $u**0.65 + 500 / $u**5 ) * $factor;
my $r = q{
pm_to_blib: $(TO_INST_PM)
};
my $regcomp_re =
"(?ckWARN(?:\\d+)?reg\\w*|vWARN\\d+|$regcomp_fail_re)";
my $position = List::MoreUtils::firstidx {
refaddr $_ == $key
}
my @exons = ($exon);
my $fastafile2 = "/tmp/tmpfastafile2";
my $grepcut = 'egrep -v "[[:digit:]]|^ *$|sequences" | cut -c8-'; # grep/cut
my $alignprogram =
"/usr/local/etc/bioinfo/fasta2/align -s /usr/local/etc/bioinfo/fasta2/idnaa.mat $fastafile1 $fastafile2 2>/dev/null | $grepcut"
; # ALIGN
my $xml = new Mioga::XML::Simple( forcearray => 1 );
my $xml_tree = $xml->XMLin($skel_file);
my $skel_name =
( exists( $xml_tree->{'name'} ) ) ? $xml_tree->{'name'} : "";
my $grp = GroupGetValues( $conf->{dbh}, $group_id );
my $adm_profile =
ProfileGetUser( $conf->{dbh}, $grp->{id_admin}, $group_id );
my $harness = TAP::Harness->new(
{ verbosity => 1, formatter_class => "TAP::Formatter::Console" } );
require File::Temp;
require Time::HiRes;
my ( $fh, $filename ) = File::Temp::tempfile("Time-HiRes-utime-XXXXXXXXX");
use File::Basename qw[dirname];
my $dirname = dirname($filename);
my $CUT = qr/\n=cut.*$EOP/;
my $pod_or_DATA = qr/
^=(?:head[1-4]|item) .*? $CUT
| ^=pod .*? $CUT
| ^=for .*? $CUT
| ^=begin .*? $CUT
| ^__(DATA|END)__\r?\n.*
/smx;
require Cwd;
( my $boot = $self->{NAME} ) =~ s/:/_/g;
doit(
sub { @E::ISA = qw/F/ },
sub { @E::ISA = qw/D/; @C::ISA = qw/F/ },
sub { @C::ISA = qw//; @A::ISA = qw/K/ },
sub { @A::ISA = qw//; @J::ISA = qw/F K/ },
sub { @J::ISA = qw/F/; @H::ISA = qw/K G/ },
sub { @H::ISA = qw/G/; @B::ISA = qw/B/ },
sub { @B::ISA = qw//; @K::ISA = qw/K J I/ },
sub { @K::ISA = qw/J I/; @D::ISA = qw/A H B C/ },
return;
);
my %extractor_for = (
quotelike => [ $ws, $variable, $id, { MATCH => \&extract_quotelike } ],
regex => [ $ws, $pod_or_DATA, $id, $exql ],
string => [ $ws, $pod_or_DATA, $id, $exql ],
code => [
$ws, { DONT_MATCH => $pod_or_DATA },
$variable, $id, { DONT_MATCH => \&extract_quotelike }
],
code_no_comments => [
{ DONT_MATCH => $comment },
$ncws, { DONT_MATCH => $pod_or_DATA },
$variable, $id, { DONT_MATCH => \&extract_quotelike }
],
executable => [ $ws, { DONT_MATCH => $pod_or_DATA } ],
executable_no_comments =>
[ { DONT_MATCH => $comment }, $ncws, { DONT_MATCH => $pod_or_DATA } ],
all => [ { MATCH => qr/(?s:.*)/ } ],
);
exit 1;
#7...........
},
'kgb2.def' => {
source => "kgb2",
params => "def",
expect => <<'#8...........',
# with -kgb, do no break after last my
sub next_sibling {
my $self = shift;
my $parent = $_PARENT{ refaddr $self} or return '';
my $key = refaddr $self;
my $elements = $parent->{children};
my $position = List::MoreUtils::firstidx {
refaddr $_ == $key
}
@$elements;
$elements->[ $position + 1 ] || '';
}
#8...........
},
'kgb2.kgb' => {
source => "kgb2",
params => "kgb",
expect => <<'#9...........',
# with -kgb, do no break after last my
sub next_sibling {
my $self = shift;
my $parent = $_PARENT{ refaddr $self} or return '';
my $key = refaddr $self;
my $elements = $parent->{children};
my $position = List::MoreUtils::firstidx {
refaddr $_ == $key
}
@$elements;
$elements->[ $position + 1 ] || '';
}
#9...........
},
'kgb3.def' => {
source => "kgb3",
params => "def",
expect => <<'#10...........',
#!/usr/bin/perl -w
use strict; # with -kgb, no break after hash bang
our ( @Changed, $TAP ); # break after isolated 'our'
use File::Compare;
use Symbol;
use Text::Wrap();
use Text::Warp();
use Blast::IPS::MathUtils qw(
set_interpolation_points
table_row_interpolation
two_point_interpolation
); # with -kgb, break around isolated 'local' below
use Text::Warp();
local ($delta2print) =
( defined $size ) ? int( $size / 50 ) : $defaultdelta2print;
print "break before this line\n";
#10...........
},
'kgb3.kgb' => {
source => "kgb3",
params => "kgb",
expect => <<'#11...........',
#!/usr/bin/perl -w
use strict; # with -kgb, no break after hash bang
our ( @Changed, $TAP ); # break after isolated 'our'
use File::Compare;
use Symbol;
use Text::Wrap();
use Text::Warp();
use Blast::IPS::MathUtils qw(
set_interpolation_points
table_row_interpolation
two_point_interpolation
); # with -kgb, break around isolated 'local' below
use Text::Warp();
local ($delta2print) =
( defined $size ) ? int( $size / 50 ) : $defaultdelta2print;
print "break before this line\n";
#11...........
},
'kgb4.def' => {
source => "kgb4",
params => "def",
expect => <<'#12...........',
print "hello"; # with -kgb, break after this line
use strict;
use warnings;
use Test::More tests => 1;
use Pod::Simple::XHTML;
my $c = < {
source => "kgb4",
params => "kgb",
expect => <<'#13...........',
print "hello"; # with -kgb, break after this line
use strict;
use warnings;
use Test::More tests => 1;
use Pod::Simple::XHTML;
my $c = < {
source => "kgb5",
params => "def",
expect => <<'#14...........',
# with -kgb, do not put blank in ternary
print "Starting\n"; # with -kgb, break after this line
my $A = "1";
my $B = "0";
my $C = "1";
my $D = "1";
my $result =
$A
? $B
? $C
? "+A +B +C"
: "+A +B -C"
: "+A -B"
: "-A";
my $F = "0";
print "with -kgb, put blank above this line; result=$result\n";
#14...........
},
'kgb5.kgb' => {
source => "kgb5",
params => "kgb",
expect => <<'#15...........',
# with -kgb, do not put blank in ternary
print "Starting\n"; # with -kgb, break after this line
my $A = "1";
my $B = "0";
my $C = "1";
my $D = "1";
my $result =
$A
? $B
? $C
? "+A +B +C"
: "+A +B -C"
: "+A -B"
: "-A";
my $F = "0";
print "with -kgb, put blank above this line; result=$result\n";
#15...........
},
'kgbd.def' => {
source => "kgbd",
params => "def",
expect => <<'#16...........',
package A1::B2;
use strict;
require Exporter;
use A1::Context;
use A1::Database;
use A1::Bibliotek;
use A1::Author;
use A1::Title;
use vars qw($VERSION @ISA @EXPORT);
$VERSION = 0.01;
#16...........
},
'kgbd.kgbd' => {
source => "kgbd",
params => "kgbd",
expect => <<'#17...........',
package A1::B2;
use strict;
require Exporter;
use A1::Context;
use A1::Database;
use A1::Bibliotek;
use A1::Author;
use A1::Title;
use vars qw($VERSION @ISA @EXPORT);
$VERSION = 0.01;
#17...........
},
'kgb_tight.def' => {
source => "kgb_tight",
params => "def",
expect => <<'#18...........',
# a variety of line types for testing -kgb
use strict;
use Test;
use Encode qw(from_to encode decode
encode_utf8 decode_utf8
find_encoding is_utf8);
use charnames qw(greek);
our $targetdir = "/usr/local/doc/HTML/Perl";
local (
$tocfile, $loffile, $lotfile, $footfile,
$citefile, $idxfile, $figure_captions, $table_captions,
$footnotes, $citations, %font_size, %index,
%done, $t_title, $t_author, $t_date,
$t_address, $t_affil, $changed
);
my @UNITCHECKs =
B::unitcheck_av->isa("B::AV")
? B::unitcheck_av->ARRAY
: ();
my @CHECKs = B::check_av->isa("B::AV") ? B::check_av->ARRAY : ();
my $dna = Bio::LiveSeq::DNA->new( -seq => $dnasequence );
my $min = 1;
my $max = length($dnasequence);
my $T = $G->_strongly_connected;
my %R = $T->vertex_roots;
my @C; # We're not calling the strongly_connected_components()
# Do not separate this hanging side comment from previous
my $G = shift;
my $exon = Bio::LiveSeq::Exon->new(
-seq => $dna,
-start => $min,
-end => $max,
-strand => 1
);
my @inputs = (
0777, 0700, 0470, 0407, 0433, 0400, 0430, 0403, 0111, 0100,
0110, 0101, 0731, 0713, 0317, 0371, 0173, 0137
);
my $impulse =
( 1 - $factor ) * ( 170 - $u ) + ( 350 / $u**0.65 + 500 / $u**5 ) * $factor;
my $r = q{
pm_to_blib: $(TO_INST_PM)
};
my $regcomp_re =
"(?ckWARN(?:\\d+)?reg\\w*|vWARN\\d+|$regcomp_fail_re)";
my $position = List::MoreUtils::firstidx {
refaddr $_ == $key
}
my $alignprogram =
"/usr/local/etc/bioinfo/fasta2/align -s /usr/local/etc/bioinfo/fasta2/idnaa.mat $fastafile1 $fastafile2 2>/dev/null | $grepcut"
; # ALIGN
my $skel_name =
( exists( $xml_tree->{'name'} ) ) ? $xml_tree->{'name'} : "";
my $grp = GroupGetValues( $conf->{dbh}, $group_id );
my $adm_profile =
ProfileGetUser( $conf->{dbh}, $grp->{id_admin}, $group_id );
my $harness = TAP::Harness->new(
{ verbosity => 1, formatter_class => "TAP::Formatter::Console" } );
require File::Temp;
require Time::HiRes;
my ( $fh, $filename ) = File::Temp::tempfile("Time-HiRes-utime-XXXXXXXXX");
use File::Basename qw[dirname];
my $dirname = dirname($filename);
my $CUT = qr/\n=cut.*$EOP/;
my $pod_or_DATA = qr/
^=(?:head[1-4]|item) .*? $CUT
| ^=pod .*? $CUT
| ^=for .*? $CUT
| ^=begin .*? $CUT
| ^__(DATA|END)__\r?\n.*
/smx;
require Cwd;
print "continuing\n";
exit 1;
#18...........
},
'gnu5.def' => {
source => "gnu5",
params => "def",
expect => <<'#19...........',
# side comments limit gnu type formatting with l=80; note extra comma
push @tests, [
"Lowest code point requiring 13 bytes to represent", # 2**36
"\xff\x80\x80\x80\x80\x80\x81\x80\x80\x80\x80\x80\x80",
($::is64bit) ? 0x1000000000 : -1, # overflows on 32bit
],
;
#19...........
},
};
my $ntests = 0 + keys %{$rtests};
plan tests => $ntests;
}
###############
# EXECUTE TESTS
###############
foreach my $key ( sort keys %{$rtests} ) {
my $output;
my $sname = $rtests->{$key}->{source};
my $expect = $rtests->{$key}->{expect};
my $pname = $rtests->{$key}->{params};
my $source = $rsources->{$sname};
my $params = defined($pname) ? $rparams->{$pname} : "";
my $stderr_string;
my $errorfile_string;
my $err = Perl::Tidy::perltidy(
source => \$source,
destination => \$output,
perltidyrc => \$params,
argv => '', # for safety; hide any ARGV from perltidy
stderr => \$stderr_string,
errorfile => \$errorfile_string, # not used when -se flag is set
);
if ( $err || $stderr_string || $errorfile_string ) {
print STDERR "Error output received for test '$key'\n";
if ($err) {
print STDERR "An error flag '$err' was returned\n";
ok( !$err );
}
if ($stderr_string) {
print STDERR "---------------------\n";
print STDERR "<>\n$stderr_string\n";
print STDERR "---------------------\n";
ok( !$stderr_string );
}
if ($errorfile_string) {
print STDERR "---------------------\n";
print STDERR "<<.ERR file>>\n$errorfile_string\n";
print STDERR "---------------------\n";
ok( !$errorfile_string );
}
}
else {
if ( !is( $output, $expect, $key ) ) {
my $leno = length($output);
my $lene = length($expect);
if ( $leno == $lene ) {
print STDERR
"#> Test '$key' gave unexpected output. Strings differ but both have length $leno\n";
}
else {
print STDERR
"#> Test '$key' gave unexpected output. String lengths differ: output=$leno, expected=$lene\n";
}
}
}
}
Perl-Tidy-20210717/t/snippets10.t 0000644 0001750 0001750 00000067037 14072572630 015307 0 ustar steve steve # Created with: ./make_t.pl
# Contents:
#1 scl.def
#2 scl.scl
#3 semicolon2.def
#4 side_comments1.def
#5 sil1.def
#6 sil1.sil
#7 slashslash.def
#8 smart.def
#9 space1.def
#10 space2.def
#11 space3.def
#12 space4.def
#13 space5.def
#14 structure1.def
#15 style.def
#16 style.style1
#17 style.style2
#18 style.style3
#19 style.style4
#20 style.style5
# To locate test #13 you can search for its name or the string '#13'
use strict;
use Test::More;
use Carp;
use Perl::Tidy;
my $rparams;
my $rsources;
my $rtests;
BEGIN {
###########################################
# BEGIN SECTION 1: Parameter combinations #
###########################################
$rparams = {
'def' => "",
'scl' => "-scl=12",
'sil' => "-sil=0",
'style1' => <<'----------',
-b
-se
-w
-i=2
-l=100
-nolq
-bbt=1
-bt=2
-pt=2
-nsfs
-sbt=2
-sbvt=2
-nhsc
-isbc
-bvt=2
-pvt=2
-wbb="% + - * / x != == >= <= =~ < > | & **= += *= &= <<= &&= -= /= |= >>= ||= .= %= ^= x="
-mbl=2
----------
'style2' => <<'----------',
-bt=2
-nwls=".."
-nwrs=".."
-pt=2
-nsfs
-sbt=2
-cuddled-blocks
-bar
-nsbl
-nbbc
----------
'style3' => <<'----------',
-l=160
-cbi=1
-cpi=1
-csbi=1
-lp
-nolq
-csci=20
-csct=40
-csc
-isbc
-cuddled-blocks
-nsbl
-dcsc
----------
'style4' => <<'----------',
-bt=2
-pt=2
-sbt=2
-cuddled-blocks
-bar
----------
'style5' => <<'----------',
-b
-bext="~"
-et=8
-l=77
-cbi=2
-cpi=2
-csbi=2
-ci=4
-nolq
-nasc
-bt=2
-ndsm
-nwls="++ -- ?"
-nwrs="++ --"
-pt=2
-nsfs
-nsts
-sbt=2
-sbvt=1
-wls="= .= =~ !~ :"
-wrs="= .= =~ !~ ? :"
-ncsc
-isbc
-msc=2
-nolc
-bvt=1
-bl
-sbl
-pvt=1
-wba="% + - * / x != == >= <= =~ !~ < > | & >= < = **= += *= &= <<= &&= -= /= |= >>= ||= .= %= ^= x= . << >> -> && ||"
-wbb=" "
-cab=1
-mbl=2
----------
};
############################
# BEGIN SECTION 2: Sources #
############################
$rsources = {
'scl' => <<'----------',
# try -scl=12 to see '$returns' joined with the previous line
$format = "format STDOUT =\n" . &format_line('Function: @') . '$name' . "\n" . &format_line('Arguments: @') . '$args' . "\n" . &format_line('Returns: @') . '$returns' . "\n" . &format_line(' ~~ ^') . '$desc' . "\n.\n";
----------
'semicolon2' => <<'----------',
# will not add semicolon for this block type
$highest = List::Util::reduce { Sort::Versions::versioncmp( $a, $b ) > 0 ? $a : $b }
----------
'side_comments1' => <<'----------',
# side comments at different indentation levels should not be aligned
{ { { { { ${msg} = "Hello World!"; print "My message: ${msg}\n"; } } #end level 4
} # end level 3
} # end level 2
} # end level 1
----------
'sil1' => <<'----------',
#############################################################
# This will walk to the left because of bad -sil guess
SKIP: {
#############################################################
}
# This will walk to the right if it is the first line of a file.
ov_method mycan( $package, '(""' ), $package
or ov_method mycan( $package, '(0+' ), $package
or ov_method mycan( $package, '(bool' ), $package
or ov_method mycan( $package, '(nomethod' ), $package;
----------
'slashslash' => <<'----------',
$home = $ENV{HOME} // $ENV{LOGDIR} // ( getpwuid($<) )[7]
// die "You're homeless!\n";
defined( $x // $y );
$version = 'v' . join '.', map ord, split //, $version->PV;
foreach ( split( //, $lets ) ) { }
foreach ( split( //, $input ) ) { }
'xyz' =~ //;
----------
'smart' => <<'----------',
\&foo !~~ \&foo;
\&foo ~~ \&foo;
\&foo ~~ \&foo;
\&foo ~~ sub {};
sub {} ~~ \&foo;
\&foo ~~ \&bar;
\&bar ~~ \&foo;
1 ~~ sub{shift};
sub{shift} ~~ 1;
0 ~~ sub{shift};
sub{shift} ~~ 0;
1 ~~ sub{scalar @_};
sub{scalar @_} ~~ 1;
[] ~~ \&bar;
\&bar ~~ [];
{} ~~ \&bar;
\&bar ~~ {};
qr// ~~ \&bar;
\&bar ~~ qr//;
a_const ~~ "a constant";
"a constant" ~~ a_const;
a_const ~~ a_const;
a_const ~~ a_const;
a_const ~~ b_const;
b_const ~~ a_const;
{} ~~ {};
{} ~~ {};
{} ~~ {1 => 2};
{1 => 2} ~~ {};
{1 => 2} ~~ {1 => 2};
{1 => 2} ~~ {1 => 2};
{1 => 2} ~~ {1 => 3};
{1 => 3} ~~ {1 => 2};
{1 => 2} ~~ {2 => 3};
{2 => 3} ~~ {1 => 2};
\%main:: ~~ {map {$_ => 'x'} keys %main::};
{map {$_ => 'x'} keys %main::} ~~ \%main::;
\%hash ~~ \%tied_hash;
\%tied_hash ~~ \%hash;
\%tied_hash ~~ \%tied_hash;
\%tied_hash ~~ \%tied_hash;
\%:: ~~ [keys %main::];
[keys %main::] ~~ \%::;
\%:: ~~ [];
[] ~~ \%::;
{"" => 1} ~~ [undef];
[undef] ~~ {"" => 1};
{foo => 1} ~~ qr/^(fo[ox])$/;
qr/^(fo[ox])$/ ~~ {foo => 1};
+{0..100} ~~ qr/[13579]$/;
qr/[13579]$/ ~~ +{0..100};
+{foo => 1, bar => 2} ~~ "foo";
"foo" ~~ +{foo => 1, bar => 2};
+{foo => 1, bar => 2} ~~ "baz";
"baz" ~~ +{foo => 1, bar => 2};
[] ~~ [];
[] ~~ [];
[] ~~ [1];
[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;
$deep1 ~~ $deep1;
$deep1 ~~ $deep2;
$deep2 ~~ $deep1;
\@nums ~~ \@tied_nums;
\@tied_nums ~~ \@nums;
[qw(foo bar baz quux)] ~~ qr/x/;
qr/x/ ~~ [qw(foo bar baz quux)];
[qw(foo bar baz quux)] ~~ qr/y/;
qr/y/ ~~ [qw(foo bar baz quux)];
[qw(1foo 2bar)] ~~ 2;
2 ~~ [qw(1foo 2bar)];
[qw(1foo 2bar)] ~~ "2";
"2" ~~ [qw(1foo 2bar)];
2 ~~ 2;
2 ~~ 2;
2 ~~ 3;
3 ~~ 2;
2 ~~ "2";
"2" ~~ 2;
2 ~~ "2.0";
"2.0" ~~ 2;
2 ~~ "2bananas";
"2bananas" ~~ 2;
2_3 ~~ "2_3";
"2_3" ~~ 2_3;
qr/x/ ~~ "x";
"x" ~~ qr/x/;
qr/y/ ~~ "x";
"x" ~~ qr/y/;
12345 ~~ qr/3/;
qr/3/ ~~ 12345;
@nums ~~ 7;
7 ~~ @nums;
@nums ~~ \@nums;
\@nums ~~ @nums;
@nums ~~ \\@nums;
\\@nums ~~ @nums;
@nums ~~ [1..10];
[1..10] ~~ @nums;
@nums ~~ [0..9];
[0..9] ~~ @nums;
%hash ~~ "foo";
"foo" ~~ %hash;
%hash ~~ /bar/;
/bar/ ~~ %hash;
----------
'space1' => <<'----------',
# We usually want a space at '} (', for example:
map { 1 * $_; } ( $y, $M, $w, $d, $h, $m, $s );
# But not others:
&{ $_->[1] }( delete $_[$#_]{ $_->[0] } );
# remove unwanted spaces after $ and -> here
&{ $ _ -> [1] }( delete $ _ [$#_ ]{ $_ -> [0] } );
# this has both tabs and spaces to remove
$ setup = $ labels -> labelsetup( Output_Width => 2.625) ;
----------
'space2' => <<'----------',
# space before this opening paren
for$i(0..20){}
# retain any space between '-' and bare word
$myhash{USER-NAME}='steve';
----------
'space3' => <<'----------',
# Treat newline as a whitespace. Otherwise, we might combine
# 'Send' and '-recipients' here
my $msg = new Fax::Send
-recipients => $to,
-data => $data;
----------
'space4' => <<'----------',
# first prototype line will cause space between 'redirect' and '(' to close
sub html::redirect($); #<-- temporary prototype;
use html;
print html::redirect ('http://www.glob.com.au/');
----------
'space5' => <<'----------',
# first prototype line commented out; space after 'redirect' remains
#sub html::redirect($); #<-- temporary prototype;
use html;
print html::redirect ('http://www.glob.com.au/');
----------
'structure1' => <<'----------',
push@contents,$c->table({-width=>'100%'},$c->Tr($c->td({-align=>'left'},"The emboldened field names are mandatory, ","the remainder are optional",),$c->td({-align=>'right'},$c->a({-href=>'help.cgi',-target=>'_blank'},"What are the various fields?"))));
----------
'style' => <<'----------',
# This test snippet is from package bbbike v3.214 by Slaven Rezic; GPL 2.0 licence
sub arrange_topframe {
my(@order) = ($hslabel_frame, $km_frame, $speed_frame[0],
$power_frame[0], $wind_frame, $percent_frame, $temp_frame,
@speed_frame[1..$#speed_frame],
@power_frame[1..$#power_frame],
);
my(@col) = (0, 1, 3, 4+$#speed_frame, 5+$#speed_frame+$#power_frame,
2, 6+$#speed_frame+$#power_frame,
4..3+$#speed_frame,
5+$#speed_frame..4+$#speed_frame+$#power_frame);
$top->idletasks;
my $width = 0;
my(%gridslaves) = map {($_, 1)} $top_frame->gridSlaves;
for(my $i = 0; $i <= $#order; $i++) {
my $w = $order[$i];
next unless Tk::Exists($w);
my $col = $col[$i] || 0;
$width += $w->reqwidth;
if ($gridslaves{$w}) {
$w->gridForget;
}
if ($width <= $top->width) {
$w->grid(-row => 0,
-column => $col,
-sticky => 'nsew'); # XXX
}
}
}
----------
};
####################################
# BEGIN SECTION 3: Expected output #
####################################
$rtests = {
'scl.def' => {
source => "scl",
params => "def",
expect => <<'#1...........',
# try -scl=12 to see '$returns' joined with the previous line
$format =
"format STDOUT =\n"
. &format_line('Function: @') . '$name' . "\n"
. &format_line('Arguments: @') . '$args' . "\n"
. &format_line('Returns: @')
. '$returns' . "\n"
. &format_line(' ~~ ^') . '$desc' . "\n.\n";
#1...........
},
'scl.scl' => {
source => "scl",
params => "scl",
expect => <<'#2...........',
# try -scl=12 to see '$returns' joined with the previous line
$format =
"format STDOUT =\n"
. &format_line('Function: @') . '$name' . "\n"
. &format_line('Arguments: @') . '$args' . "\n"
. &format_line('Returns: @') . '$returns' . "\n"
. &format_line(' ~~ ^') . '$desc' . "\n.\n";
#2...........
},
'semicolon2.def' => {
source => "semicolon2",
params => "def",
expect => <<'#3...........',
# will not add semicolon for this block type
$highest = List::Util::reduce {
Sort::Versions::versioncmp( $a, $b ) > 0 ? $a : $b
}
#3...........
},
'side_comments1.def' => {
source => "side_comments1",
params => "def",
expect => <<'#4...........',
# side comments at different indentation levels should not be aligned
{
{
{
{
{ ${msg} = "Hello World!"; print "My message: ${msg}\n"; }
} #end level 4
} # end level 3
} # end level 2
} # end level 1
#4...........
},
'sil1.def' => {
source => "sil1",
params => "def",
expect => <<'#5...........',
#############################################################
# This will walk to the left because of bad -sil guess
SKIP: {
#############################################################
}
# This will walk to the right if it is the first line of a file.
ov_method mycan( $package, '(""' ), $package
or ov_method mycan( $package, '(0+' ), $package
or ov_method mycan( $package, '(bool' ), $package
or ov_method mycan( $package, '(nomethod' ), $package;
#5...........
},
'sil1.sil' => {
source => "sil1",
params => "sil",
expect => <<'#6...........',
#############################################################
# This will walk to the left because of bad -sil guess
SKIP: {
#############################################################
}
# This will walk to the right if it is the first line of a file.
ov_method mycan( $package, '(""' ), $package
or ov_method mycan( $package, '(0+' ), $package
or ov_method mycan( $package, '(bool' ), $package
or ov_method mycan( $package, '(nomethod' ), $package;
#6...........
},
'slashslash.def' => {
source => "slashslash",
params => "def",
expect => <<'#7...........',
$home = $ENV{HOME} // $ENV{LOGDIR} // ( getpwuid($<) )[7]
// die "You're homeless!\n";
defined( $x // $y );
$version = 'v' . join '.', map ord, split //, $version->PV;
foreach ( split( //, $lets ) ) { }
foreach ( split( //, $input ) ) { }
'xyz' =~ //;
#7...........
},
'smart.def' => {
source => "smart",
params => "def",
expect => <<'#8...........',
\&foo !~~ \&foo;
\&foo ~~ \&foo;
\&foo ~~ \&foo;
\&foo ~~ sub { };
sub { } ~~ \&foo;
\&foo ~~ \&bar;
\&bar ~~ \&foo;
1 ~~ sub { shift };
sub { shift } ~~ 1;
0 ~~ sub { shift };
sub { shift } ~~ 0;
1 ~~ sub { scalar @_ };
sub { scalar @_ } ~~ 1;
[] ~~ \&bar;
\&bar ~~ [];
{} ~~ \&bar;
\&bar ~~ {};
qr// ~~ \&bar;
\&bar ~~ qr//;
a_const ~~ "a constant";
"a constant" ~~ a_const;
a_const ~~ a_const;
a_const ~~ a_const;
a_const ~~ b_const;
b_const ~~ a_const;
{} ~~ {};
{} ~~ {};
{} ~~ { 1 => 2 };
{ 1 => 2 } ~~ {};
{ 1 => 2 } ~~ { 1 => 2 };
{ 1 => 2 } ~~ { 1 => 2 };
{ 1 => 2 } ~~ { 1 => 3 };
{ 1 => 3 } ~~ { 1 => 2 };
{ 1 => 2 } ~~ { 2 => 3 };
{ 2 => 3 } ~~ { 1 => 2 };
\%main:: ~~ { map { $_ => 'x' } keys %main:: };
{
map { $_ => 'x' } keys %main::
}
~~ \%main::;
\%hash ~~ \%tied_hash;
\%tied_hash ~~ \%hash;
\%tied_hash ~~ \%tied_hash;
\%tied_hash ~~ \%tied_hash;
\%:: ~~ [ keys %main:: ];
[ keys %main:: ] ~~ \%::;
\%:: ~~ [];
[] ~~ \%::;
{ "" => 1 } ~~ [undef];
[undef] ~~ { "" => 1 };
{ foo => 1 } ~~ qr/^(fo[ox])$/;
qr/^(fo[ox])$/ ~~ { foo => 1 };
+{ 0 .. 100 } ~~ qr/[13579]$/;
qr/[13579]$/ ~~ +{ 0 .. 100 };
+{ foo => 1, bar => 2 } ~~ "foo";
"foo" ~~ +{ foo => 1, bar => 2 };
+{ foo => 1, bar => 2 } ~~ "baz";
"baz" ~~ +{ foo => 1, bar => 2 };
[] ~~ [];
[] ~~ [];
[] ~~ [1];
[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;
$deep1 ~~ $deep1;
$deep1 ~~ $deep2;
$deep2 ~~ $deep1;
\@nums ~~ \@tied_nums;
\@tied_nums ~~ \@nums;
[qw(foo bar baz quux)] ~~ qr/x/;
qr/x/ ~~ [qw(foo bar baz quux)];
[qw(foo bar baz quux)] ~~ qr/y/;
qr/y/ ~~ [qw(foo bar baz quux)];
[qw(1foo 2bar)] ~~ 2;
2 ~~ [qw(1foo 2bar)];
[qw(1foo 2bar)] ~~ "2";
"2" ~~ [qw(1foo 2bar)];
2 ~~ 2;
2 ~~ 2;
2 ~~ 3;
3 ~~ 2;
2 ~~ "2";
"2" ~~ 2;
2 ~~ "2.0";
"2.0" ~~ 2;
2 ~~ "2bananas";
"2bananas" ~~ 2;
2_3 ~~ "2_3";
"2_3" ~~ 2_3;
qr/x/ ~~ "x";
"x" ~~ qr/x/;
qr/y/ ~~ "x";
"x" ~~ qr/y/;
12345 ~~ qr/3/;
qr/3/ ~~ 12345;
@nums ~~ 7;
7 ~~ @nums;
@nums ~~ \@nums;
\@nums ~~ @nums;
@nums ~~ \\@nums;
\\@nums ~~ @nums;
@nums ~~ [ 1 .. 10 ];
[ 1 .. 10 ] ~~ @nums;
@nums ~~ [ 0 .. 9 ];
[ 0 .. 9 ] ~~ @nums;
%hash ~~ "foo";
"foo" ~~ %hash;
%hash ~~ /bar/;
/bar/ ~~ %hash;
#8...........
},
'space1.def' => {
source => "space1",
params => "def",
expect => <<'#9...........',
# We usually want a space at '} (', for example:
map { 1 * $_; } ( $y, $M, $w, $d, $h, $m, $s );
# But not others:
&{ $_->[1] }( delete $_[$#_]{ $_->[0] } );
# remove unwanted spaces after $ and -> here
&{ $_->[1] }( delete $_[$#_]{ $_->[0] } );
# this has both tabs and spaces to remove
$setup = $labels->labelsetup( Output_Width => 2.625 );
#9...........
},
'space2.def' => {
source => "space2",
params => "def",
expect => <<'#10...........',
# space before this opening paren
for $i ( 0 .. 20 ) { }
# retain any space between '-' and bare word
$myhash{ USER-NAME } = 'steve';
#10...........
},
'space3.def' => {
source => "space3",
params => "def",
expect => <<'#11...........',
# Treat newline as a whitespace. Otherwise, we might combine
# 'Send' and '-recipients' here
my $msg = new Fax::Send
-recipients => $to,
-data => $data;
#11...........
},
'space4.def' => {
source => "space4",
params => "def",
expect => <<'#12...........',
# first prototype line will cause space between 'redirect' and '(' to close
sub html::redirect($); #<-- temporary prototype;
use html;
print html::redirect('http://www.glob.com.au/');
#12...........
},
'space5.def' => {
source => "space5",
params => "def",
expect => <<'#13...........',
# first prototype line commented out; space after 'redirect' remains
#sub html::redirect($); #<-- temporary prototype;
use html;
print html::redirect ('http://www.glob.com.au/');
#13...........
},
'structure1.def' => {
source => "structure1",
params => "def",
expect => <<'#14...........',
push @contents,
$c->table(
{ -width => '100%' },
$c->Tr(
$c->td(
{ -align => 'left' },
"The emboldened field names are mandatory, ",
"the remainder are optional",
),
$c->td(
{ -align => 'right' },
$c->a(
{ -href => 'help.cgi', -target => '_blank' },
"What are the various fields?"
)
)
)
);
#14...........
},
'style.def' => {
source => "style",
params => "def",
expect => <<'#15...........',
# This test snippet is from package bbbike v3.214 by Slaven Rezic; GPL 2.0 licence
sub arrange_topframe {
my (@order) = (
$hslabel_frame,
$km_frame,
$speed_frame[0],
$power_frame[0],
$wind_frame,
$percent_frame,
$temp_frame,
@speed_frame[ 1 .. $#speed_frame ],
@power_frame[ 1 .. $#power_frame ],
);
my (@col) = (
0,
1,
3,
4 + $#speed_frame,
5 + $#speed_frame + $#power_frame,
2,
6 + $#speed_frame + $#power_frame,
4 .. 3 + $#speed_frame,
5 + $#speed_frame .. 4 + $#speed_frame + $#power_frame
);
$top->idletasks;
my $width = 0;
my (%gridslaves) = map { ( $_, 1 ) } $top_frame->gridSlaves;
for ( my $i = 0 ; $i <= $#order ; $i++ ) {
my $w = $order[$i];
next unless Tk::Exists($w);
my $col = $col[$i] || 0;
$width += $w->reqwidth;
if ( $gridslaves{$w} ) {
$w->gridForget;
}
if ( $width <= $top->width ) {
$w->grid(
-row => 0,
-column => $col,
-sticky => 'nsew'
); # XXX
}
}
}
#15...........
},
'style.style1' => {
source => "style",
params => "style1",
expect => <<'#16...........',
# This test snippet is from package bbbike v3.214 by Slaven Rezic; GPL 2.0 licence
sub arrange_topframe {
my (@order) = (
$hslabel_frame, $km_frame, $speed_frame[0],
$power_frame[0], $wind_frame, $percent_frame, $temp_frame,
@speed_frame[1 .. $#speed_frame],
@power_frame[1 .. $#power_frame],
);
my (@col) = (
0, 1, 3,
4 + $#speed_frame,
5 + $#speed_frame + $#power_frame,
2,
6 + $#speed_frame + $#power_frame,
4 .. 3 + $#speed_frame,
5 + $#speed_frame .. 4 + $#speed_frame + $#power_frame
);
$top->idletasks;
my $width = 0;
my (%gridslaves) = map { ($_, 1) } $top_frame->gridSlaves;
for (my $i = 0; $i <= $#order; $i++) {
my $w = $order[$i];
next unless Tk::Exists($w);
my $col = $col[$i] || 0;
$width += $w->reqwidth;
if ($gridslaves{$w}) {
$w->gridForget;
}
if ($width <= $top->width) {
$w->grid(
-row => 0,
-column => $col,
-sticky => 'nsew'
); # XXX
}
}
}
#16...........
},
'style.style2' => {
source => "style",
params => "style2",
expect => <<'#17...........',
# This test snippet is from package bbbike v3.214 by Slaven Rezic; GPL 2.0 licence
sub arrange_topframe {
my (@order) = (
$hslabel_frame, $km_frame,
$speed_frame[0], $power_frame[0],
$wind_frame, $percent_frame,
$temp_frame, @speed_frame[1..$#speed_frame],
@power_frame[1..$#power_frame],
);
my (@col) = (
0,
1,
3,
4 + $#speed_frame,
5 + $#speed_frame + $#power_frame,
2,
6 + $#speed_frame + $#power_frame,
4..3 + $#speed_frame,
5 + $#speed_frame..4 + $#speed_frame + $#power_frame
);
$top->idletasks;
my $width = 0;
my (%gridslaves) = map { ($_, 1) } $top_frame->gridSlaves;
for (my $i = 0; $i <= $#order; $i++) {
my $w = $order[$i];
next unless Tk::Exists($w);
my $col = $col[$i] || 0;
$width += $w->reqwidth;
if ($gridslaves{$w}) {
$w->gridForget;
}
if ($width <= $top->width) {
$w->grid(
-row => 0,
-column => $col,
-sticky => 'nsew'
); # XXX
}
}
}
#17...........
},
'style.style3' => {
source => "style",
params => "style3",
expect => <<'#18...........',
# This test snippet is from package bbbike v3.214 by Slaven Rezic; GPL 2.0 licence
sub arrange_topframe {
my (@order) = (
$hslabel_frame, $km_frame, $speed_frame[0], $power_frame[0], $wind_frame, $percent_frame, $temp_frame,
@speed_frame[ 1 .. $#speed_frame ],
@power_frame[ 1 .. $#power_frame ],
);
my (@col) = (
0, 1, 3,
4 + $#speed_frame,
5 + $#speed_frame + $#power_frame,
2,
6 + $#speed_frame + $#power_frame,
4 .. 3 + $#speed_frame,
5 + $#speed_frame .. 4 + $#speed_frame + $#power_frame
);
$top->idletasks;
my $width = 0;
my (%gridslaves) = map { ( $_, 1 ) } $top_frame->gridSlaves;
for ( my $i = 0 ; $i <= $#order ; $i++ ) {
my $w = $order[$i];
next unless Tk::Exists($w);
my $col = $col[$i] || 0;
$width += $w->reqwidth;
if ( $gridslaves{$w} ) {
$w->gridForget;
}
if ( $width <= $top->width ) {
$w->grid(
-row => 0,
-column => $col,
-sticky => 'nsew'
); # XXX
}
}
} ## end sub arrange_topframe
#18...........
},
'style.style4' => {
source => "style",
params => "style4",
expect => <<'#19...........',
# This test snippet is from package bbbike v3.214 by Slaven Rezic; GPL 2.0 licence
sub arrange_topframe {
my (@order) = (
$hslabel_frame, $km_frame,
$speed_frame[0], $power_frame[0],
$wind_frame, $percent_frame,
$temp_frame, @speed_frame[1 .. $#speed_frame],
@power_frame[1 .. $#power_frame],
);
my (@col) = (
0,
1,
3,
4 + $#speed_frame,
5 + $#speed_frame + $#power_frame,
2,
6 + $#speed_frame + $#power_frame,
4 .. 3 + $#speed_frame,
5 + $#speed_frame .. 4 + $#speed_frame + $#power_frame
);
$top->idletasks;
my $width = 0;
my (%gridslaves) = map { ($_, 1) } $top_frame->gridSlaves;
for (my $i = 0 ; $i <= $#order ; $i++) {
my $w = $order[$i];
next unless Tk::Exists($w);
my $col = $col[$i] || 0;
$width += $w->reqwidth;
if ($gridslaves{$w}) {
$w->gridForget;
}
if ($width <= $top->width) {
$w->grid(
-row => 0,
-column => $col,
-sticky => 'nsew'
); # XXX
}
}
}
#19...........
},
'style.style5' => {
source => "style",
params => "style5",
expect => <<'#20...........',
# This test snippet is from package bbbike v3.214 by Slaven Rezic; GPL 2.0 licence
sub arrange_topframe
{
my (@order) = (
$hslabel_frame, $km_frame,
$speed_frame[0], $power_frame[0],
$wind_frame, $percent_frame,
$temp_frame, @speed_frame[1 .. $#speed_frame],
@power_frame[1 .. $#power_frame],
);
my (@col) = (
0,
1,
3,
4 + $#speed_frame,
5 + $#speed_frame + $#power_frame,
2,
6 + $#speed_frame + $#power_frame,
4 .. 3 + $#speed_frame,
5 + $#speed_frame .. 4 + $#speed_frame + $#power_frame
);
$top->idletasks;
my $width = 0;
my (%gridslaves) = map { ($_, 1) } $top_frame->gridSlaves;
for (my $i = 0; $i <= $#order; $i++)
{
my $w = $order[$i];
next unless Tk::Exists($w);
my $col = $col[$i] || 0;
$width += $w->reqwidth;
if ($gridslaves{$w})
{
$w->gridForget;
}
if ($width <= $top->width)
{
$w->grid(
-row => 0,
-column => $col,
-sticky => 'nsew'
); # XXX
}
}
}
#20...........
},
};
my $ntests = 0 + keys %{$rtests};
plan tests => $ntests;
}
###############
# EXECUTE TESTS
###############
foreach my $key ( sort keys %{$rtests} ) {
my $output;
my $sname = $rtests->{$key}->{source};
my $expect = $rtests->{$key}->{expect};
my $pname = $rtests->{$key}->{params};
my $source = $rsources->{$sname};
my $params = defined($pname) ? $rparams->{$pname} : "";
my $stderr_string;
my $errorfile_string;
my $err = Perl::Tidy::perltidy(
source => \$source,
destination => \$output,
perltidyrc => \$params,
argv => '', # for safety; hide any ARGV from perltidy
stderr => \$stderr_string,
errorfile => \$errorfile_string, # not used when -se flag is set
);
if ( $err || $stderr_string || $errorfile_string ) {
print STDERR "Error output received for test '$key'\n";
if ($err) {
print STDERR "An error flag '$err' was returned\n";
ok( !$err );
}
if ($stderr_string) {
print STDERR "---------------------\n";
print STDERR "<>\n$stderr_string\n";
print STDERR "---------------------\n";
ok( !$stderr_string );
}
if ($errorfile_string) {
print STDERR "---------------------\n";
print STDERR "<<.ERR file>>\n$errorfile_string\n";
print STDERR "---------------------\n";
ok( !$errorfile_string );
}
}
else {
if ( !is( $output, $expect, $key ) ) {
my $leno = length($output);
my $lene = length($expect);
if ( $leno == $lene ) {
print STDERR
"#> Test '$key' gave unexpected output. Strings differ but both have length $leno\n";
}
else {
print STDERR
"#> Test '$key' gave unexpected output. String lengths differ: output=$leno, expected=$lene\n";
}
}
}
}
Perl-Tidy-20210717/t/snippets15.t 0000644 0001750 0001750 00000034242 14072572630 015304 0 ustar steve steve # Created with: ./make_t.pl
# Contents:
#1 gnu5.gnu
#2 wngnu1.def
#3 olbs.def
#4 olbs.olbs0
#5 olbs.olbs2
#6 break_old_methods.break_old_methods
#7 break_old_methods.def
#8 bom1.bom
#9 bom1.def
#10 align28.def
#11 align29.def
#12 align30.def
#13 git09.def
#14 git09.git09
#15 git14.def
#16 sal.def
#17 sal.sal
#18 spp.def
#19 spp.spp0
# To locate test #13 you can search for its name or the string '#13'
use strict;
use Test::More;
use Carp;
use Perl::Tidy;
my $rparams;
my $rsources;
my $rtests;
BEGIN {
###########################################
# BEGIN SECTION 1: Parameter combinations #
###########################################
$rparams = {
'bom' => "-bom -wn",
'break_old_methods' => "--break-at-old-method-breakpoints",
'def' => "",
'git09' => "-ce -cbl=map,sort,grep",
'gnu' => "-gnu",
'olbs0' => "-olbs=0",
'olbs2' => "-olbs=2",
'sal' => <<'----------',
-sal='method fun'
----------
'spp0' => "-spp=0",
};
############################
# BEGIN SECTION 2: Sources #
############################
$rsources = {
'align28' => <<'----------',
# tests for 'delete_needless_parens'
# align all '='s; but do not align parens
my $w = $columns * $cell_w + ( $columns + 1 ) * $border;
my $h = $rows * $cell_h + ( $rows + 1 ) * $border;
my $img = new Gimp::Image( $w, $h, RGB );
# keep leading paren after if as alignment for padding
eval {
if ( $a->{'abc'} eq 'ABC' ) { no_op(23) }
else { no_op(42) }
};
----------
'align29' => <<'----------',
# alignment with lots of commas
is( floor(1.23441242), 1, "Basic floor(1.23441242) test" );
is( fmod( 3.5, 2.0 ), 1.5, "Basic fmod(3.5, 2.0) test" );
is( join( " ", frexp(1) ), "0.5 1", "Basic frexp(1) test" );
is( ldexp( 0, 1 ), 0, "Basic ldexp(0,1) test" );
is( log10(1), 0, "Basic log10(1) test" );
----------
'align30' => <<'----------',
# commas on lhs align, commas on rhs do not (different subs)
($x,$y,$z)=spherical_to_cartesian($rho,$theta,$phi);
($rho_c,$theta,$z)=spherical_to_cylindrical($rho_s,$theta,$phi);
( $r2, $theta2, $z2 )=cartesian_to_cylindrical( $x1, $y1, $z1 );
# two-line if/elsif gets aligned
if($i==$depth){$_++;}
elsif($i>$depth){$_=0;}
----------
'bom1' => <<'----------',
# keep cuddled call chain with -bom
return Mojo::Promise->resolve(
$query_params
)->then(
&_reveal_event
)->then(sub ($code) {
return $c->render(text => '', status => $code);
})->catch(sub {
# 1. return error
return $c->render(json => {}, status => 400);
});
----------
'break_old_methods' => <<'----------',
my $q = $rs
->related_resultset('CDs')
->related_resultset('Tracks')
->search({
'track.id' => { -ident => 'none_search.id' },
})
->as_query;
----------
'git09' => <<'----------',
# no one-line block for first map with -ce -cbl=map,sort,grep
@sorted = map {
$_->[0]
} sort {
$a->[1] <=> $b->[1] or $a->[0] cmp $b->[0]
} map {
[$_, length($_)]
} @unsorted;
----------
'git14' => <<'----------',
# git#14; do not break at trailing 'or'
$second = {
key1 => 'aaa',
key2 => 'bbb',
} if $flag1 or $flag2;
----------
'gnu5' => <<'----------',
# side comments limit gnu type formatting with l=80; note extra comma
push @tests, [
"Lowest code point requiring 13 bytes to represent", # 2**36
"\xff\x80\x80\x80\x80\x80\x81\x80\x80\x80\x80\x80\x80",
($::is64bit) ? 0x1000000000 : -1, # overflows on 32bit
],
;
----------
'olbs' => <<'----------',
for $x ( 1, 2 ) { s/(.*)/+$1/ }
for $x ( 1, 2 ) { s/(.*)/+$1/ } # side comment
if ( $editlblk eq 1 ) { $editlblk = "on"; $editlblkchecked = "checked" }
for $x ( 1, 2 ) { s/(.*)/+$1/; }
for $x ( 1, 2 ) { s/(.*)/+$1/; } # side comment
if ( $editlblk eq 1 ) { $editlblk = "on"; $editlblkchecked = "checked"; }
----------
'sal' => <<'----------',
sub get_val () {
}
method get_value () {
}
fun get_other_value () {
}
----------
'spp' => <<'----------',
sub get_val() { }
sub get_Val () { }
sub Get_val () { }
my $sub1=sub () { };
my $sub2=sub () { };
----------
'wngnu1' => <<'----------',
# test with -wn -gnu
foreach my $parameter (
qw(
set_themes
add_themes
severity
maximum_violations_per_document
_non_public_data
)
)
{
is(
$config->get($parameter),
undef,
qq<"$parameter" is not defined via get() for $policy_short_name.>,
);
}
----------
};
####################################
# BEGIN SECTION 3: Expected output #
####################################
$rtests = {
'gnu5.gnu' => {
source => "gnu5",
params => "gnu",
expect => <<'#1...........',
# side comments limit gnu type formatting with l=80; note extra comma
push @tests, [
"Lowest code point requiring 13 bytes to represent", # 2**36
"\xff\x80\x80\x80\x80\x80\x81\x80\x80\x80\x80\x80\x80",
($::is64bit) ? 0x1000000000 : -1, # overflows on 32bit
],
;
#1...........
},
'wngnu1.def' => {
source => "wngnu1",
params => "def",
expect => <<'#2...........',
# test with -wn -gnu
foreach my $parameter (
qw(
set_themes
add_themes
severity
maximum_violations_per_document
_non_public_data
)
)
{
is(
$config->get($parameter),
undef,
qq<"$parameter" is not defined via get() for $policy_short_name.>,
);
}
#2...........
},
'olbs.def' => {
source => "olbs",
params => "def",
expect => <<'#3...........',
for $x ( 1, 2 ) { s/(.*)/+$1/ }
for $x ( 1, 2 ) { s/(.*)/+$1/ } # side comment
if ( $editlblk eq 1 ) { $editlblk = "on"; $editlblkchecked = "checked" }
for $x ( 1, 2 ) { s/(.*)/+$1/; }
for $x ( 1, 2 ) { s/(.*)/+$1/; } # side comment
if ( $editlblk eq 1 ) { $editlblk = "on"; $editlblkchecked = "checked"; }
#3...........
},
'olbs.olbs0' => {
source => "olbs",
params => "olbs0",
expect => <<'#4...........',
for $x ( 1, 2 ) { s/(.*)/+$1/ }
for $x ( 1, 2 ) { s/(.*)/+$1/ } # side comment
if ( $editlblk eq 1 ) { $editlblk = "on"; $editlblkchecked = "checked" }
for $x ( 1, 2 ) { s/(.*)/+$1/ }
for $x ( 1, 2 ) { s/(.*)/+$1/ } # side comment
if ( $editlblk eq 1 ) { $editlblk = "on"; $editlblkchecked = "checked"; }
#4...........
},
'olbs.olbs2' => {
source => "olbs",
params => "olbs2",
expect => <<'#5...........',
for $x ( 1, 2 ) { s/(.*)/+$1/; }
for $x ( 1, 2 ) { s/(.*)/+$1/; } # side comment
if ( $editlblk eq 1 ) { $editlblk = "on"; $editlblkchecked = "checked"; }
for $x ( 1, 2 ) { s/(.*)/+$1/; }
for $x ( 1, 2 ) { s/(.*)/+$1/; } # side comment
if ( $editlblk eq 1 ) { $editlblk = "on"; $editlblkchecked = "checked"; }
#5...........
},
'break_old_methods.break_old_methods' => {
source => "break_old_methods",
params => "break_old_methods",
expect => <<'#6...........',
my $q = $rs
->related_resultset('CDs')
->related_resultset('Tracks')
->search(
{
'track.id' => { -ident => 'none_search.id' },
}
)->as_query;
#6...........
},
'break_old_methods.def' => {
source => "break_old_methods",
params => "def",
expect => <<'#7...........',
my $q = $rs->related_resultset('CDs')->related_resultset('Tracks')->search(
{
'track.id' => { -ident => 'none_search.id' },
}
)->as_query;
#7...........
},
'bom1.bom' => {
source => "bom1",
params => "bom",
expect => <<'#8...........',
# keep cuddled call chain with -bom
return Mojo::Promise->resolve(
$query_params
)->then(
&_reveal_event
)->then( sub ($code) {
return $c->render( text => '', status => $code );
} )->catch( sub {
# 1. return error
return $c->render( json => {}, status => 400 );
} );
#8...........
},
'bom1.def' => {
source => "bom1",
params => "def",
expect => <<'#9...........',
# keep cuddled call chain with -bom
return Mojo::Promise->resolve($query_params)->then(&_reveal_event)->then(
sub ($code) {
return $c->render( text => '', status => $code );
}
)->catch(
sub {
# 1. return error
return $c->render( json => {}, status => 400 );
}
);
#9...........
},
'align28.def' => {
source => "align28",
params => "def",
expect => <<'#10...........',
# tests for 'delete_needless_parens'
# align all '='s; but do not align parens
my $w = $columns * $cell_w + ( $columns + 1 ) * $border;
my $h = $rows * $cell_h + ( $rows + 1 ) * $border;
my $img = new Gimp::Image( $w, $h, RGB );
# keep leading paren after if as alignment for padding
eval {
if ( $a->{'abc'} eq 'ABC' ) { no_op(23) }
else { no_op(42) }
};
#10...........
},
'align29.def' => {
source => "align29",
params => "def",
expect => <<'#11...........',
# alignment with lots of commas
is( floor(1.23441242), 1, "Basic floor(1.23441242) test" );
is( fmod( 3.5, 2.0 ), 1.5, "Basic fmod(3.5, 2.0) test" );
is( join( " ", frexp(1) ), "0.5 1", "Basic frexp(1) test" );
is( ldexp( 0, 1 ), 0, "Basic ldexp(0,1) test" );
is( log10(1), 0, "Basic log10(1) test" );
#11...........
},
'align30.def' => {
source => "align30",
params => "def",
expect => <<'#12...........',
# commas on lhs align, commas on rhs do not (different subs)
( $x, $y, $z ) = spherical_to_cartesian( $rho, $theta, $phi );
( $rho_c, $theta, $z ) = spherical_to_cylindrical( $rho_s, $theta, $phi );
( $r2, $theta2, $z2 ) = cartesian_to_cylindrical( $x1, $y1, $z1 );
# two-line if/elsif gets aligned
if ( $i == $depth ) { $_++; }
elsif ( $i > $depth ) { $_ = 0; }
#12...........
},
'git09.def' => {
source => "git09",
params => "def",
expect => <<'#13...........',
# no one-line block for first map with -ce -cbl=map,sort,grep
@sorted =
map { $_->[0] }
sort { $a->[1] <=> $b->[1] or $a->[0] cmp $b->[0] }
map { [ $_, length($_) ] } @unsorted;
#13...........
},
'git09.git09' => {
source => "git09",
params => "git09",
expect => <<'#14...........',
# no one-line block for first map with -ce -cbl=map,sort,grep
@sorted = map {
$_->[0]
} sort {
$a->[1] <=> $b->[1] or $a->[0] cmp $b->[0]
} map {
[ $_, length($_) ]
} @unsorted;
#14...........
},
'git14.def' => {
source => "git14",
params => "def",
expect => <<'#15...........',
# git#14; do not break at trailing 'or'
$second = {
key1 => 'aaa',
key2 => 'bbb',
} if $flag1 or $flag2;
#15...........
},
'sal.def' => {
source => "sal",
params => "def",
expect => <<'#16...........',
sub get_val () {
}
method get_value() {
}
fun get_other_value() {
}
#16...........
},
'sal.sal' => {
source => "sal",
params => "sal",
expect => <<'#17...........',
sub get_val () {
}
method get_value () {
}
fun get_other_value () {
}
#17...........
},
'spp.def' => {
source => "spp",
params => "def",
expect => <<'#18...........',
sub get_val() { }
sub get_Val () { }
sub Get_val () { }
my $sub1 = sub () { };
my $sub2 = sub () { };
#18...........
},
'spp.spp0' => {
source => "spp",
params => "spp0",
expect => <<'#19...........',
sub get_val() { }
sub get_Val() { }
sub Get_val() { }
my $sub1 = sub() { };
my $sub2 = sub() { };
#19...........
},
};
my $ntests = 0 + keys %{$rtests};
plan tests => $ntests;
}
###############
# EXECUTE TESTS
###############
foreach my $key ( sort keys %{$rtests} ) {
my $output;
my $sname = $rtests->{$key}->{source};
my $expect = $rtests->{$key}->{expect};
my $pname = $rtests->{$key}->{params};
my $source = $rsources->{$sname};
my $params = defined($pname) ? $rparams->{$pname} : "";
my $stderr_string;
my $errorfile_string;
my $err = Perl::Tidy::perltidy(
source => \$source,
destination => \$output,
perltidyrc => \$params,
argv => '', # for safety; hide any ARGV from perltidy
stderr => \$stderr_string,
errorfile => \$errorfile_string, # not used when -se flag is set
);
if ( $err || $stderr_string || $errorfile_string ) {
print STDERR "Error output received for test '$key'\n";
if ($err) {
print STDERR "An error flag '$err' was returned\n";
ok( !$err );
}
if ($stderr_string) {
print STDERR "---------------------\n";
print STDERR "<>\n$stderr_string\n";
print STDERR "---------------------\n";
ok( !$stderr_string );
}
if ($errorfile_string) {
print STDERR "---------------------\n";
print STDERR "<<.ERR file>>\n$errorfile_string\n";
print STDERR "---------------------\n";
ok( !$errorfile_string );
}
}
else {
if ( !is( $output, $expect, $key ) ) {
my $leno = length($output);
my $lene = length($expect);
if ( $leno == $lene ) {
print STDERR
"#> Test '$key' gave unexpected output. Strings differ but both have length $leno\n";
}
else {
print STDERR
"#> Test '$key' gave unexpected output. String lengths differ: output=$leno, expected=$lene\n";
}
}
}
}
Perl-Tidy-20210717/t/snippets12.t 0000644 0001750 0001750 00000037465 14072572630 015313 0 ustar steve steve # Created with: ./make_t.pl
# Contents:
#1 vtc1.def
#2 vtc1.vtc
#3 vtc2.def
#4 vtc2.vtc
#5 vtc3.def
#6 vtc3.vtc
#7 vtc4.def
#8 vtc4.vtc
#9 wn1.def
#10 wn1.wn
#11 wn2.def
#12 wn2.wn
#13 wn3.def
#14 wn3.wn
#15 wn4.def
#16 wn4.wn
#17 wn5.def
#18 wn5.wn
#19 wn6.def
#20 wn6.wn
# To locate test #13 you can search for its name or the string '#13'
use strict;
use Test::More;
use Carp;
use Perl::Tidy;
my $rparams;
my $rsources;
my $rtests;
BEGIN {
###########################################
# BEGIN SECTION 1: Parameter combinations #
###########################################
$rparams = {
'def' => "",
'vtc' => <<'----------',
-sbvtc=2
-bvtc=2
-pvtc=2
----------
'wn' => "-wn",
};
############################
# BEGIN SECTION 2: Sources #
############################
$rsources = {
'vtc1' => <<'----------',
@lol = (
[ 'Dr. Watson', undef, '221b', 'Baker St.',
undef, 'London', 'NW1', undef,
'England', undef
],
[ 'Sam Gamgee', undef, undef, 'Bagshot Row',
undef, 'Hobbiton', undef, undef,
'The Shire', undef],
);
----------
'vtc2' => <<'----------',
ok(
$s->call(
SOAP::Data->name('getStateName')
->attr( { xmlns => 'urn:/My/Examples' } ),
1
)->result eq 'Alabama'
);
----------
'vtc3' => <<'----------',
$day_long = (
"Sunday", "Monday", "Tuesday", "Wednesday",
"Thursday", "Friday", "Saturday", "Sunday"
)[$wday];
----------
'vtc4' => <<'----------',
my$bg_color=$im->colorAllocate(unpack('C3',pack('H2H2H2',unpack('a2a2a2',(length($options_r->{'bg_color'})?$options_r->{'bg_color'}:$MIDI::Opus::BG_color)))));
----------
'wn1' => <<'----------',
my $bg_color = $im->colorAllocate(
unpack(
'C3',
pack(
'H2H2H2',
unpack(
'a2a2a2',
(
length( $options_r->{'bg_color'} )
? $options_r->{'bg_color'}
: $MIDI::Opus::BG_color
)
)
)
)
);
----------
'wn2' => <<'----------',
if ($PLATFORM eq 'aix') {
skip_symbols([qw(
Perl_dump_fds
Perl_ErrorNo
Perl_GetVars
PL_sys_intern
)]);
}
----------
'wn3' => <<'----------',
deferred->resolve->then(
sub {
push @out, 'Resolve';
return $then;
}
)->then(
sub {
push @out, 'Reject';
push @out, @_;
}
);
----------
'wn4' => <<'----------',
{{{
# Orignal formatting looks nice but would be hard to duplicate
return exists $G->{ Attr }->{ E } &&
exists $G->{ Attr }->{ E }->{ $u } &&
exists $G->{ Attr }->{ E }->{ $u }->{ $v } ?
%{ $G->{ Attr }->{ E }->{ $u }->{ $v } } :
( );
}}}
----------
'wn5' => <<'----------',
# qw weld with -wn
use_all_ok(
qw{
PPI
PPI::Tokenizer
PPI::Lexer
PPI::Dumper
PPI::Find
PPI::Normal
PPI::Util
PPI::Cache
}
);
----------
'wn6' => <<'----------',
# illustration of some do-not-weld rules
# do not weld a two-line function call
$trans->add_transformation( PDL::Graphics::TriD::Scale->new( $sx, $sy, $sz ) );
# but weld this more complex statement
my $compass = uc( opposite_direction( line_to_canvas_direction(
@{ $coords[0] }, @{ $coords[1] } ) ) );
# OLD: do not weld to a one-line block because the function could
# get separated from its opening paren.
# NEW: (30-jan-2021): keep one-line block together for stability
$_[0]->code_handler
( sub { $morexxxxxxxxxxxxxxxxxx .= $_[1] . ":" . $_[0] . "\n" } );
# another example; do not weld because the sub is not broken
$wrapped->add_around_modifier(
sub { push @tracelog => 'around 1'; $_[0]->(); } );
# but okay to weld here because the sub is broken
$wrapped->add_around_modifier( sub {
push @tracelog => 'around 1'; $_[0]->(); } );
----------
};
####################################
# BEGIN SECTION 3: Expected output #
####################################
$rtests = {
'vtc1.def' => {
source => "vtc1",
params => "def",
expect => <<'#1...........',
@lol = (
[
'Dr. Watson', undef, '221b', 'Baker St.',
undef, 'London', 'NW1', undef,
'England', undef
],
[
'Sam Gamgee', undef, undef, 'Bagshot Row',
undef, 'Hobbiton', undef, undef,
'The Shire', undef
],
);
#1...........
},
'vtc1.vtc' => {
source => "vtc1",
params => "vtc",
expect => <<'#2...........',
@lol = (
[
'Dr. Watson', undef, '221b', 'Baker St.',
undef, 'London', 'NW1', undef,
'England', undef ],
[
'Sam Gamgee', undef, undef, 'Bagshot Row',
undef, 'Hobbiton', undef, undef,
'The Shire', undef ], );
#2...........
},
'vtc2.def' => {
source => "vtc2",
params => "def",
expect => <<'#3...........',
ok(
$s->call(
SOAP::Data->name('getStateName')
->attr( { xmlns => 'urn:/My/Examples' } ),
1
)->result eq 'Alabama'
);
#3...........
},
'vtc2.vtc' => {
source => "vtc2",
params => "vtc",
expect => <<'#4...........',
ok(
$s->call(
SOAP::Data->name('getStateName')
->attr( { xmlns => 'urn:/My/Examples' } ),
1 )->result eq 'Alabama' );
#4...........
},
'vtc3.def' => {
source => "vtc3",
params => "def",
expect => <<'#5...........',
$day_long = (
"Sunday", "Monday", "Tuesday", "Wednesday",
"Thursday", "Friday", "Saturday", "Sunday"
)[$wday];
#5...........
},
'vtc3.vtc' => {
source => "vtc3",
params => "vtc",
expect => <<'#6...........',
$day_long = (
"Sunday", "Monday", "Tuesday", "Wednesday",
"Thursday", "Friday", "Saturday", "Sunday" )[$wday];
#6...........
},
'vtc4.def' => {
source => "vtc4",
params => "def",
expect => <<'#7...........',
my $bg_color = $im->colorAllocate(
unpack(
'C3',
pack(
'H2H2H2',
unpack(
'a2a2a2',
(
length( $options_r->{'bg_color'} )
? $options_r->{'bg_color'}
: $MIDI::Opus::BG_color
)
)
)
)
);
#7...........
},
'vtc4.vtc' => {
source => "vtc4",
params => "vtc",
expect => <<'#8...........',
my $bg_color = $im->colorAllocate(
unpack(
'C3',
pack(
'H2H2H2',
unpack(
'a2a2a2',
(
length( $options_r->{'bg_color'} )
? $options_r->{'bg_color'}
: $MIDI::Opus::BG_color ) ) ) ) );
#8...........
},
'wn1.def' => {
source => "wn1",
params => "def",
expect => <<'#9...........',
my $bg_color = $im->colorAllocate(
unpack(
'C3',
pack(
'H2H2H2',
unpack(
'a2a2a2',
(
length( $options_r->{'bg_color'} )
? $options_r->{'bg_color'}
: $MIDI::Opus::BG_color
)
)
)
)
);
#9...........
},
'wn1.wn' => {
source => "wn1",
params => "wn",
expect => <<'#10...........',
my $bg_color = $im->colorAllocate( unpack(
'C3',
pack(
'H2H2H2',
unpack(
'a2a2a2',
(
length( $options_r->{'bg_color'} )
? $options_r->{'bg_color'}
: $MIDI::Opus::BG_color
)
)
)
) );
#10...........
},
'wn2.def' => {
source => "wn2",
params => "def",
expect => <<'#11...........',
if ( $PLATFORM eq 'aix' ) {
skip_symbols(
[
qw(
Perl_dump_fds
Perl_ErrorNo
Perl_GetVars
PL_sys_intern
)
]
);
}
#11...........
},
'wn2.wn' => {
source => "wn2",
params => "wn",
expect => <<'#12...........',
if ( $PLATFORM eq 'aix' ) {
skip_symbols( [ qw(
Perl_dump_fds
Perl_ErrorNo
Perl_GetVars
PL_sys_intern
) ] );
}
#12...........
},
'wn3.def' => {
source => "wn3",
params => "def",
expect => <<'#13...........',
deferred->resolve->then(
sub {
push @out, 'Resolve';
return $then;
}
)->then(
sub {
push @out, 'Reject';
push @out, @_;
}
);
#13...........
},
'wn3.wn' => {
source => "wn3",
params => "wn",
expect => <<'#14...........',
deferred->resolve->then( sub {
push @out, 'Resolve';
return $then;
} )->then( sub {
push @out, 'Reject';
push @out, @_;
} );
#14...........
},
'wn4.def' => {
source => "wn4",
params => "def",
expect => <<'#15...........',
{
{
{
# Orignal formatting looks nice but would be hard to duplicate
return
exists $G->{Attr}->{E}
&& exists $G->{Attr}->{E}->{$u}
&& exists $G->{Attr}->{E}->{$u}->{$v}
? %{ $G->{Attr}->{E}->{$u}->{$v} }
: ();
}
}
}
#15...........
},
'wn4.wn' => {
source => "wn4",
params => "wn",
expect => <<'#16...........',
{ { {
# Orignal formatting looks nice but would be hard to duplicate
return
exists $G->{Attr}->{E}
&& exists $G->{Attr}->{E}->{$u} && exists $G->{Attr}->{E}->{$u}->{$v}
? %{ $G->{Attr}->{E}->{$u}->{$v} }
: ();
} } }
#16...........
},
'wn5.def' => {
source => "wn5",
params => "def",
expect => <<'#17...........',
# qw weld with -wn
use_all_ok(
qw{
PPI
PPI::Tokenizer
PPI::Lexer
PPI::Dumper
PPI::Find
PPI::Normal
PPI::Util
PPI::Cache
}
);
#17...........
},
'wn5.wn' => {
source => "wn5",
params => "wn",
expect => <<'#18...........',
# qw weld with -wn
use_all_ok( qw{
PPI
PPI::Tokenizer
PPI::Lexer
PPI::Dumper
PPI::Find
PPI::Normal
PPI::Util
PPI::Cache
} );
#18...........
},
'wn6.def' => {
source => "wn6",
params => "def",
expect => <<'#19...........',
# illustration of some do-not-weld rules
# do not weld a two-line function call
$trans->add_transformation(
PDL::Graphics::TriD::Scale->new( $sx, $sy, $sz ) );
# but weld this more complex statement
my $compass = uc(
opposite_direction(
line_to_canvas_direction(
@{ $coords[0] }, @{ $coords[1] }
)
)
);
# OLD: do not weld to a one-line block because the function could
# get separated from its opening paren.
# NEW: (30-jan-2021): keep one-line block together for stability
$_[0]->code_handler(
sub { $morexxxxxxxxxxxxxxxxxx .= $_[1] . ":" . $_[0] . "\n" } );
# another example; do not weld because the sub is not broken
$wrapped->add_around_modifier(
sub { push @tracelog => 'around 1'; $_[0]->(); } );
# but okay to weld here because the sub is broken
$wrapped->add_around_modifier(
sub {
push @tracelog => 'around 1';
$_[0]->();
}
);
#19...........
},
'wn6.wn' => {
source => "wn6",
params => "wn",
expect => <<'#20...........',
# illustration of some do-not-weld rules
# do not weld a two-line function call
$trans->add_transformation(
PDL::Graphics::TriD::Scale->new( $sx, $sy, $sz ) );
# but weld this more complex statement
my $compass = uc( opposite_direction( line_to_canvas_direction(
@{ $coords[0] }, @{ $coords[1] }
) ) );
# OLD: do not weld to a one-line block because the function could
# get separated from its opening paren.
# NEW: (30-jan-2021): keep one-line block together for stability
$_[0]->code_handler(
sub { $morexxxxxxxxxxxxxxxxxx .= $_[1] . ":" . $_[0] . "\n" } );
# another example; do not weld because the sub is not broken
$wrapped->add_around_modifier(
sub { push @tracelog => 'around 1'; $_[0]->(); } );
# but okay to weld here because the sub is broken
$wrapped->add_around_modifier( sub {
push @tracelog => 'around 1';
$_[0]->();
} );
#20...........
},
};
my $ntests = 0 + keys %{$rtests};
plan tests => $ntests;
}
###############
# EXECUTE TESTS
###############
foreach my $key ( sort keys %{$rtests} ) {
my $output;
my $sname = $rtests->{$key}->{source};
my $expect = $rtests->{$key}->{expect};
my $pname = $rtests->{$key}->{params};
my $source = $rsources->{$sname};
my $params = defined($pname) ? $rparams->{$pname} : "";
my $stderr_string;
my $errorfile_string;
my $err = Perl::Tidy::perltidy(
source => \$source,
destination => \$output,
perltidyrc => \$params,
argv => '', # for safety; hide any ARGV from perltidy
stderr => \$stderr_string,
errorfile => \$errorfile_string, # not used when -se flag is set
);
if ( $err || $stderr_string || $errorfile_string ) {
print STDERR "Error output received for test '$key'\n";
if ($err) {
print STDERR "An error flag '$err' was returned\n";
ok( !$err );
}
if ($stderr_string) {
print STDERR "---------------------\n";
print STDERR "<>\n$stderr_string\n";
print STDERR "---------------------\n";
ok( !$stderr_string );
}
if ($errorfile_string) {
print STDERR "---------------------\n";
print STDERR "<<.ERR file>>\n$errorfile_string\n";
print STDERR "---------------------\n";
ok( !$errorfile_string );
}
}
else {
if ( !is( $output, $expect, $key ) ) {
my $leno = length($output);
my $lene = length($expect);
if ( $leno == $lene ) {
print STDERR
"#> Test '$key' gave unexpected output. Strings differ but both have length $leno\n";
}
else {
print STDERR
"#> Test '$key' gave unexpected output. String lengths differ: output=$leno, expected=$lene\n";
}
}
}
}
Perl-Tidy-20210717/t/snippets4.t 0000644 0001750 0001750 00000041466 14072572632 015232 0 ustar steve steve # Created with: ./make_t.pl
# Contents:
#1 gnu1.gnu
#2 gnu2.def
#3 gnu2.gnu
#4 gnu3.def
#5 gnu3.gnu
#6 gnu4.def
#7 gnu4.gnu
#8 hanging_side_comments1.def
#9 hanging_side_comments2.def
#10 hash1.def
#11 hashbang.def
#12 here1.def
#13 html1.def
#14 html1.html
#15 ident1.def
#16 if1.def
#17 iscl1.def
#18 iscl1.iscl
#19 label1.def
#20 lextest1.def
# To locate test #13 you can search for its name or the string '#13'
use strict;
use Test::More;
use Carp;
use Perl::Tidy;
my $rparams;
my $rsources;
my $rtests;
BEGIN {
###########################################
# BEGIN SECTION 1: Parameter combinations #
###########################################
$rparams = {
'def' => "",
'gnu' => "-gnu",
'html' => <<'----------',
-fmt="html"
-nts
----------
'iscl' => "-iscl",
};
############################
# BEGIN SECTION 2: Sources #
############################
$rsources = {
'gnu1' => <<'----------',
@common_sometimes = (
"aclocal.m4", "acconfig.h", "config.h.top", "config.h.bot",
"stamp-h.in", 'stamp-vti'
);
----------
'gnu2' => <<'----------',
$search_mb = $menu_bar->Menubutton(
'-text' => 'Search',
'-relief' => 'raised',
'-borderwidth' => 2,
)->pack(
'-side' => 'left',
'-padx' => 2
);
----------
'gnu3' => <<'----------',
$output_rules .= &file_contents_with_transform( 's/\@TEXI\@/' . $info_cursor . '/g; ' . 's/\@VTI\@/' . $vti . '/g; ' . 's/\@VTEXI\@/' . $vtexi . '/g;' . 's,\@MDDIR\@,' . $conf_pat . ',g;', 'texi-vers');
----------
'gnu4' => <<'----------',
my $mzef = Bio::Tools::MZEF->new( '-file' => Bio::Root::IO->catfile("t", "genomic-seq.mzef"));
----------
'hanging_side_comments1' => <<'----------',
$valuestr .= $value . " " ; # with a trailing space in case there are multiple values
# for this tag (allowed in GFF2 and .ace format)
----------
'hanging_side_comments2' => <<'----------',
# keep '=' lined up even with hanging side comments
$ax=1;# side comment
# hanging side comment
$boondoggle=5;# side comment
$beetle=5;# side comment
# hanging side comment
$d=3;
----------
'hash1' => <<'----------',
%TV=(flintstones=>{series=>"flintstones",nights=>[qw(monday thursday friday)],
members=>[{name=>"fred",role=>"lead",age=>36,},{name=>"wilma",role=>"wife",
age=>31,},{name=>"pebbles",role=>"kid",age=>4,},],},jetsons=>{series=>"jetsons",
nights=>[qw(wednesday saturday)],members=>[{name=>"george",role=>"lead",age=>41,
},{name=>"jane",role=>"wife",age=>39,},{name=>"elroy",role=>"kid",age=>9,},],},
simpsons=>{series=>"simpsons",nights=>[qw(monday)],members=>[{name=>"homer",
role=>"lead",age=>34,},{name=>"marge",role=>"wife",age=>37,},{name=>"bart",
role=>"kid",age=>11,},],},);
----------
'hashbang' => <<'----------',
#!/usr/bin/perl
----------
'here1' => <<'----------',
is( <<~`END`, "ok\n", '<<~`HEREDOC`' );
$Perl -le "print 'ok'"
END
----------
'html1' => <<'----------',
if ( $editlblk eq 1 ) { $editlblk = "on"; $editlblkchecked = "checked" }
else { $editlblk = "off"; $editlblkchecked = "unchecked" }
----------
'ident1' => <<'----------',
package A;
sub new {
print "A::new! $_[0] $_[1]\n";
return 1;
}
package main;
my $scanner = new A::() ;
$scanner = new A::;
$scanner = new A 'a';
----------
'if1' => <<'----------',
# one-line blocks
if ( $editlblk eq 1 ) { $editlblk = "on"; $editlblkchecked = "checked" }
else { $editlblk = "off"; $editlblkchecked = "unchecked" }
----------
'iscl1' => <<'----------',
# -iscl will not allow alignment of hanging side comments (currently)
$gsmatch = ( $sub >= 50 ) ? "equal" : "lequal"; # Force an equal match for
# dev, but be more forgiving
# for releases
----------
'label1' => <<'----------',
INIT : {
$a++;
print "looping with label INIT:, a=$a\n";
if ($a<10) {goto INIT}
}
package: {
print "hello!\n";
}
sub: {
print "hello!\n";
}
----------
'lextest1' => <<'----------',
$_= <<'EOL';
$url = new URI::URL "http://www/"; die if $url eq "xXx";
EOL
LOOP:{print(" digits"),redo LOOP if/\G\d+\b[,.;]?\s*/gc;print(" lowercase"),
redo LOOP if/\G[a-z]+\b[,.;]?\s*/gc;print(" UPPERCASE"), redo
LOOP if/\G[A-Z]+\b[,.;]?\s*/gc;print(" Capitalized"),
redo LOOP if/\G[A-Z][a-z]+\b[,.;]?\s*/gc;
print(" MiXeD"),redo LOOP if/\G[A-Za-z]+\b[,.;]?\s*/gc;print(
" alphanumeric"),redo LOOP if/\G[A-Za-z0-9]+\b[,.;]?\s*/gc;print(" line-noise"
),redo LOOP if/\G[^A-Za-z0-9]+/gc;print". That's all!\n";}
----------
};
####################################
# BEGIN SECTION 3: Expected output #
####################################
$rtests = {
'gnu1.gnu' => {
source => "gnu1",
params => "gnu",
expect => <<'#1...........',
@common_sometimes = (
"aclocal.m4", "acconfig.h",
"config.h.top", "config.h.bot",
"stamp-h.in", 'stamp-vti'
);
#1...........
},
'gnu2.def' => {
source => "gnu2",
params => "def",
expect => <<'#2...........',
$search_mb = $menu_bar->Menubutton(
'-text' => 'Search',
'-relief' => 'raised',
'-borderwidth' => 2,
)->pack(
'-side' => 'left',
'-padx' => 2
);
#2...........
},
'gnu2.gnu' => {
source => "gnu2",
params => "gnu",
expect => <<'#3...........',
$search_mb = $menu_bar->Menubutton(
'-text' => 'Search',
'-relief' => 'raised',
'-borderwidth' => 2,
)->pack('-side' => 'left',
'-padx' => 2);
#3...........
},
'gnu3.def' => {
source => "gnu3",
params => "def",
expect => <<'#4...........',
$output_rules .= &file_contents_with_transform(
's/\@TEXI\@/'
. $info_cursor . '/g; '
. 's/\@VTI\@/'
. $vti . '/g; '
. 's/\@VTEXI\@/'
. $vtexi . '/g;'
. 's,\@MDDIR\@,'
. $conf_pat . ',g;',
'texi-vers'
);
#4...........
},
'gnu3.gnu' => {
source => "gnu3",
params => "gnu",
expect => <<'#5...........',
$output_rules .=
&file_contents_with_transform(
's/\@TEXI\@/'
. $info_cursor . '/g; '
. 's/\@VTI\@/'
. $vti . '/g; '
. 's/\@VTEXI\@/'
. $vtexi . '/g;'
. 's,\@MDDIR\@,'
. $conf_pat . ',g;',
'texi-vers'
);
#5...........
},
'gnu4.def' => {
source => "gnu4",
params => "def",
expect => <<'#6...........',
my $mzef = Bio::Tools::MZEF->new(
'-file' => Bio::Root::IO->catfile( "t", "genomic-seq.mzef" ) );
#6...........
},
'gnu4.gnu' => {
source => "gnu4",
params => "gnu",
expect => <<'#7...........',
my $mzef = Bio::Tools::MZEF->new(
'-file' => Bio::Root::IO->catfile("t", "genomic-seq.mzef"));
#7...........
},
'hanging_side_comments1.def' => {
source => "hanging_side_comments1",
params => "def",
expect => <<'#8...........',
$valuestr .=
$value . " "; # with a trailing space in case there are multiple values
# for this tag (allowed in GFF2 and .ace format)
#8...........
},
'hanging_side_comments2.def' => {
source => "hanging_side_comments2",
params => "def",
expect => <<'#9...........',
# keep '=' lined up even with hanging side comments
$ax = 1; # side comment
# hanging side comment
$boondoggle = 5; # side comment
$beetle = 5; # side comment
# hanging side comment
$d = 3;
#9...........
},
'hash1.def' => {
source => "hash1",
params => "def",
expect => <<'#10...........',
%TV = (
flintstones => {
series => "flintstones",
nights => [qw(monday thursday friday)],
members => [
{ name => "fred", role => "lead", age => 36, },
{
name => "wilma",
role => "wife",
age => 31,
},
{ name => "pebbles", role => "kid", age => 4, },
],
},
jetsons => {
series => "jetsons",
nights => [qw(wednesday saturday)],
members => [
{
name => "george",
role => "lead",
age => 41,
},
{ name => "jane", role => "wife", age => 39, },
{ name => "elroy", role => "kid", age => 9, },
],
},
simpsons => {
series => "simpsons",
nights => [qw(monday)],
members => [
{
name => "homer",
role => "lead",
age => 34,
},
{ name => "marge", role => "wife", age => 37, },
{
name => "bart",
role => "kid",
age => 11,
},
],
},
);
#10...........
},
'hashbang.def' => {
source => "hashbang",
params => "def",
expect => <<'#11...........',
#!/usr/bin/perl
#11...........
},
'here1.def' => {
source => "here1",
params => "def",
expect => <<'#12...........',
is( <<~`END`, "ok\n", '<<~`HEREDOC`' );
$Perl -le "print 'ok'"
END
#12...........
},
'html1.def' => {
source => "html1",
params => "def",
expect => <<'#13...........',
if ( $editlblk eq 1 ) { $editlblk = "on"; $editlblkchecked = "checked" }
else { $editlblk = "off"; $editlblkchecked = "unchecked" }
#13...........
},
'html1.html' => {
source => "html1",
params => "html",
expect => <<'#14...........',
perltidy
perltidy
if ( $editlblk eq 1 ) { $editlblk = "on"; $editlblkchecked = "checked" }
else { $editlblk = "off"; $editlblkchecked = "unchecked" }
#14...........
},
'ident1.def' => {
source => "ident1",
params => "def",
expect => <<'#15...........',
package A;
sub new {
print "A::new! $_[0] $_[1]\n";
return 1;
}
package main;
my $scanner = new A::();
$scanner = new A::;
$scanner = new A 'a';
#15...........
},
'if1.def' => {
source => "if1",
params => "def",
expect => <<'#16...........',
# one-line blocks
if ( $editlblk eq 1 ) { $editlblk = "on"; $editlblkchecked = "checked" }
else { $editlblk = "off"; $editlblkchecked = "unchecked" }
#16...........
},
'iscl1.def' => {
source => "iscl1",
params => "def",
expect => <<'#17...........',
# -iscl will not allow alignment of hanging side comments (currently)
$gsmatch =
( $sub >= 50 ) ? "equal" : "lequal"; # Force an equal match for
# dev, but be more forgiving
# for releases
#17...........
},
'iscl1.iscl' => {
source => "iscl1",
params => "iscl",
expect => <<'#18...........',
# -iscl will not allow alignment of hanging side comments (currently)
$gsmatch = ( $sub >= 50 ) ? "equal" : "lequal"; # Force an equal match for
# dev, but be more forgiving
# for releases
#18...........
},
'label1.def' => {
source => "label1",
params => "def",
expect => <<'#19...........',
INIT: {
$a++;
print "looping with label INIT:, a=$a\n";
if ( $a < 10 ) { goto INIT }
}
package: {
print "hello!\n";
}
sub: {
print "hello!\n";
}
#19...........
},
'lextest1.def' => {
source => "lextest1",
params => "def",
expect => <<'#20...........',
$_ = <<'EOL';
$url = new URI::URL "http://www/"; die if $url eq "xXx";
EOL
LOOP: {
print(" digits"), redo LOOP if /\G\d+\b[,.;]?\s*/gc;
print(" lowercase"), redo LOOP if /\G[a-z]+\b[,.;]?\s*/gc;
print(" UPPERCASE"), redo LOOP if /\G[A-Z]+\b[,.;]?\s*/gc;
print(" Capitalized"), redo LOOP if /\G[A-Z][a-z]+\b[,.;]?\s*/gc;
print(" MiXeD"), redo LOOP if /\G[A-Za-z]+\b[,.;]?\s*/gc;
print(" alphanumeric"), redo LOOP if /\G[A-Za-z0-9]+\b[,.;]?\s*/gc;
print(" line-noise"), redo LOOP if /\G[^A-Za-z0-9]+/gc;
print ". That's all!\n";
}
#20...........
},
};
my $ntests = 0 + keys %{$rtests};
plan tests => $ntests;
}
###############
# EXECUTE TESTS
###############
foreach my $key ( sort keys %{$rtests} ) {
my $output;
my $sname = $rtests->{$key}->{source};
my $expect = $rtests->{$key}->{expect};
my $pname = $rtests->{$key}->{params};
my $source = $rsources->{$sname};
my $params = defined($pname) ? $rparams->{$pname} : "";
my $stderr_string;
my $errorfile_string;
my $err = Perl::Tidy::perltidy(
source => \$source,
destination => \$output,
perltidyrc => \$params,
argv => '', # for safety; hide any ARGV from perltidy
stderr => \$stderr_string,
errorfile => \$errorfile_string, # not used when -se flag is set
);
if ( $err || $stderr_string || $errorfile_string ) {
print STDERR "Error output received for test '$key'\n";
if ($err) {
print STDERR "An error flag '$err' was returned\n";
ok( !$err );
}
if ($stderr_string) {
print STDERR "---------------------\n";
print STDERR "<>\n$stderr_string\n";
print STDERR "---------------------\n";
ok( !$stderr_string );
}
if ($errorfile_string) {
print STDERR "---------------------\n";
print STDERR "<<.ERR file>>\n$errorfile_string\n";
print STDERR "---------------------\n";
ok( !$errorfile_string );
}
}
else {
if ( !is( $output, $expect, $key ) ) {
my $leno = length($output);
my $lene = length($expect);
if ( $leno == $lene ) {
print STDERR
"#> Test '$key' gave unexpected output. Strings differ but both have length $leno\n";
}
else {
print STDERR
"#> Test '$key' gave unexpected output. String lengths differ: output=$leno, expected=$lene\n";
}
}
}
}
Perl-Tidy-20210717/t/snippets1.t 0000644 0001750 0001750 00000037343 14072572630 015224 0 ustar steve steve # Created with: ./make_t.pl
# Contents:
#1 105484.def
#2 align1.def
#3 align2.def
#4 align3.def
#5 align4.def
#6 align5.def
#7 align6.def
#8 align7.def
#9 align8.def
#10 align9.def
#11 andor1.def
#12 andor10.def
#13 andor2.def
#14 andor3.def
#15 andor4.def
#16 andor5.def
#17 andor6.def
#18 andor7.def
#19 andor8.def
#20 andor9.def
# To locate test #13 you can search for its name or the string '#13'
use strict;
use Test::More;
use Carp;
use Perl::Tidy;
my $rparams;
my $rsources;
my $rtests;
BEGIN {
###########################################
# BEGIN SECTION 1: Parameter combinations #
###########################################
$rparams = { 'def' => "", };
############################
# BEGIN SECTION 2: Sources #
############################
$rsources = {
'105484' => <<'----------',
switch (1) {
case x { 2 } else { }
}
----------
'align1' => <<'----------',
return ( $fetch_key eq $fk
&& $store_key eq $sk
&& $fetch_value eq $fv
&& $store_value eq $sv
&& $_ eq 'original' );
----------
'align2' => <<'----------',
same =
( ( $aP eq $bP )
&& ( $aS eq $bS )
&& ( $aT eq $bT )
&& ( $a->{'title'} eq $b->{'title'} )
&& ( $a->{'href'} eq $b->{'href'} ) );
----------
'align3' => <<'----------',
# This greatly improved after dropping 'ne' and 'eq':
if (
$dir eq $updir and # if we have an updir
@collapsed and # and something to collapse
length $collapsed[-1] and # and its not the rootdir
$collapsed[-1] ne $updir and # nor another updir
$collapsed[-1] ne $curdir # nor the curdir
) { $bla}
----------
'align4' => <<'----------',
# removed 'eq' and '=~' from alignment tokens to get alignment of '?'s
my $salute =
$name eq $EMPTY_STR ? 'Customer'
: $name =~ m/\A((?:Sir|Dame) \s+ \S+) /xms ? $1
: $name =~ m/(.*), \s+ Ph[.]?D \z /xms ? "Dr $1"
: $name;
----------
'align5' => <<'----------',
# some lists
printline( "Broadcast", &bintodq($b), ( $b, $mask, $bcolor, 0 ) );
printline( "HostMin", &bintodq($hmin), ( $hmin, $mask, $bcolor, 0 ) );
printline( "HostMax", &bintodq($hmax), ( $hmax, $mask, $bcolor, 0 ) );
----------
'align6' => <<'----------',
# align opening parens
if ( ( index( $msg_line_lc, $nick1 ) != -1 ) ||
( index( $msg_line_lc, $nick2 ) != -1 ) ||
( index( $msg_line_lc, $nick3 ) != -1 ) ) {
do_something();
}
----------
'align7' => <<'----------',
# Alignment with two fat commas in second line
my $ct = Courriel::Header::ContentType->new(
mime_type => 'multipart/alternative',
attributes => { boundary => unique_boundary },
);
----------
'align8' => <<'----------',
# aligning '=' and padding 'if'
if ( $tag == 263 ) { $bbi->{"Info.Thresholding"} = $value }
elsif ( $tag == 264 ) { $bbi->{"Info.CellWidth"} = $value }
elsif ( $tag == 265 ) { $bbi->{"Info.CellLength"} = $value }
----------
'align9' => <<'----------',
# test of aligning ||
my $os =
( $ExtUtils::MM_Unix::Is_OS2 || 0 ) +
( $ExtUtils::MM_Unix::Is_Mac || 0 ) +
( $ExtUtils::MM_Unix::Is_Win32 || 0 ) +
( $ExtUtils::MM_Unix::Is_Dos || 0 ) +
( $ExtUtils::MM_Unix::Is_VMS || 0 );
----------
'andor1' => <<'----------',
return 1 if $det_a < 0 and $det_b > 0 or
$det_a > 0 and $det_b < 0;
----------
'andor10' => <<'----------',
if ( ( ($a) and ( $b == 13 ) and ( $c - 24 = 0 ) and ("test")
and ( $rudolph eq "reindeer" or $rudolph eq "red nosed" )
and $test
) or ( $nobody and ( $noone or $none ) )
)
{ $i++; }
----------
'andor2' => <<'----------',
# breaks at = or at && but not both
my $success = ( system("$Config{cc} -o $te $tc $libs $HIDE") == 0 ) && -e $te ? 1 : 0;
----------
'andor3' => <<'----------',
ok( ( $obj->name() eq $obj2->name() )
and ( $obj->version() eq $obj2->version() )
and ( $obj->help() eq $obj2->help() ) );
----------
'andor4' => <<'----------',
if ( !$verbose_error && ( !$options->{'log'}
&& ( ( $options->{'verbose'} & 8 ) || ( $options->{'verbose'} & 16 )
|| ( $options->{'verbose'} & 32 )
|| ( $options->{'verbose'} & 64 ) ) ) )
----------
'andor5' => <<'----------',
# two levels of && with side comments
if (
defined &syscopy
&& \&syscopy != \©
&& !$to_a_handle
&& !( $from_a_handle && $^O eq 'os2' ) # OS/2 cannot handle
&& !( $from_a_handle && $^O eq 'mpeix' ) # and neither can MPE/iX.
)
{
return syscopy( $from, $to );
}
----------
'andor6' => <<'----------',
# Example of nested ands and ors
sub is_miniwhile { # check for one-line loop (`foo() while $y--')
my $op = shift;
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" )
)
);
}
----------
'andor7' => <<'----------',
# original is single line:
$a = 1 if $l and !$r or !$l and $r;
----------
'andor8' => <<'----------',
# original is broken:
$a = 1
if $l and !$r or !$l and $r;
----------
'andor9' => <<'----------',
if ( ( ( $old_new and $old_new eq 'changed' )
and ( $db_new and $db_new eq 'changed' )
and ( not defined $old_db )
) or ( ( $old_new and $old_new eq 'changed' )
and ( $db_new and $db_new eq 'new' )
and ( $old_db and $old_db eq 'new' )
) or ( ( $old_new and $old_new eq 'new' )
and ( $db_new and $db_new eq 'new' )
and ( not defined $old_db )
) )
{
return "update";
}
----------
};
####################################
# BEGIN SECTION 3: Expected output #
####################################
$rtests = {
'105484.def' => {
source => "105484",
params => "def",
expect => <<'#1...........',
switch (1) {
case x { 2 } else { }
}
#1...........
},
'align1.def' => {
source => "align1",
params => "def",
expect => <<'#2...........',
return ( $fetch_key eq $fk
&& $store_key eq $sk
&& $fetch_value eq $fv
&& $store_value eq $sv
&& $_ eq 'original' );
#2...........
},
'align2.def' => {
source => "align2",
params => "def",
expect => <<'#3...........',
same =
( ( $aP eq $bP )
&& ( $aS eq $bS )
&& ( $aT eq $bT )
&& ( $a->{'title'} eq $b->{'title'} )
&& ( $a->{'href'} eq $b->{'href'} ) );
#3...........
},
'align3.def' => {
source => "align3",
params => "def",
expect => <<'#4...........',
# This greatly improved after dropping 'ne' and 'eq':
if (
$dir eq $updir and # if we have an updir
@collapsed and # and something to collapse
length $collapsed[-1] and # and its not the rootdir
$collapsed[-1] ne $updir and # nor another updir
$collapsed[-1] ne $curdir # nor the curdir
)
{
$bla;
}
#4...........
},
'align4.def' => {
source => "align4",
params => "def",
expect => <<'#5...........',
# removed 'eq' and '=~' from alignment tokens to get alignment of '?'s
my $salute =
$name eq $EMPTY_STR ? 'Customer'
: $name =~ m/\A((?:Sir|Dame) \s+ \S+) /xms ? $1
: $name =~ m/(.*), \s+ Ph[.]?D \z /xms ? "Dr $1"
: $name;
#5...........
},
'align5.def' => {
source => "align5",
params => "def",
expect => <<'#6...........',
# some lists
printline( "Broadcast", &bintodq($b), ( $b, $mask, $bcolor, 0 ) );
printline( "HostMin", &bintodq($hmin), ( $hmin, $mask, $bcolor, 0 ) );
printline( "HostMax", &bintodq($hmax), ( $hmax, $mask, $bcolor, 0 ) );
#6...........
},
'align6.def' => {
source => "align6",
params => "def",
expect => <<'#7...........',
# align opening parens
if ( ( index( $msg_line_lc, $nick1 ) != -1 )
|| ( index( $msg_line_lc, $nick2 ) != -1 )
|| ( index( $msg_line_lc, $nick3 ) != -1 ) )
{
do_something();
}
#7...........
},
'align7.def' => {
source => "align7",
params => "def",
expect => <<'#8...........',
# Alignment with two fat commas in second line
my $ct = Courriel::Header::ContentType->new(
mime_type => 'multipart/alternative',
attributes => { boundary => unique_boundary },
);
#8...........
},
'align8.def' => {
source => "align8",
params => "def",
expect => <<'#9...........',
# aligning '=' and padding 'if'
if ( $tag == 263 ) { $bbi->{"Info.Thresholding"} = $value }
elsif ( $tag == 264 ) { $bbi->{"Info.CellWidth"} = $value }
elsif ( $tag == 265 ) { $bbi->{"Info.CellLength"} = $value }
#9...........
},
'align9.def' => {
source => "align9",
params => "def",
expect => <<'#10...........',
# test of aligning ||
my $os =
( $ExtUtils::MM_Unix::Is_OS2 || 0 ) +
( $ExtUtils::MM_Unix::Is_Mac || 0 ) +
( $ExtUtils::MM_Unix::Is_Win32 || 0 ) +
( $ExtUtils::MM_Unix::Is_Dos || 0 ) +
( $ExtUtils::MM_Unix::Is_VMS || 0 );
#10...........
},
'andor1.def' => {
source => "andor1",
params => "def",
expect => <<'#11...........',
return 1
if $det_a < 0 and $det_b > 0
or $det_a > 0 and $det_b < 0;
#11...........
},
'andor10.def' => {
source => "andor10",
params => "def",
expect => <<'#12...........',
if (
(
($a)
and ( $b == 13 )
and ( $c - 24 = 0 )
and ("test")
and ( $rudolph eq "reindeer" or $rudolph eq "red nosed" )
and $test
)
or ( $nobody and ( $noone or $none ) )
)
{
$i++;
}
#12...........
},
'andor2.def' => {
source => "andor2",
params => "def",
expect => <<'#13...........',
# breaks at = or at && but not both
my $success =
( system("$Config{cc} -o $te $tc $libs $HIDE") == 0 ) && -e $te ? 1 : 0;
#13...........
},
'andor3.def' => {
source => "andor3",
params => "def",
expect => <<'#14...........',
ok( ( $obj->name() eq $obj2->name() )
and ( $obj->version() eq $obj2->version() )
and ( $obj->help() eq $obj2->help() ) );
#14...........
},
'andor4.def' => {
source => "andor4",
params => "def",
expect => <<'#15...........',
if (
!$verbose_error
&& (
!$options->{'log'}
&& ( ( $options->{'verbose'} & 8 )
|| ( $options->{'verbose'} & 16 )
|| ( $options->{'verbose'} & 32 )
|| ( $options->{'verbose'} & 64 ) )
)
)
#15...........
},
'andor5.def' => {
source => "andor5",
params => "def",
expect => <<'#16...........',
# two levels of && with side comments
if (
defined &syscopy
&& \&syscopy != \©
&& !$to_a_handle
&& !( $from_a_handle && $^O eq 'os2' ) # OS/2 cannot handle
&& !( $from_a_handle && $^O eq 'mpeix' ) # and neither can MPE/iX.
)
{
return syscopy( $from, $to );
}
#16...........
},
'andor6.def' => {
source => "andor6",
params => "def",
expect => <<'#17...........',
# Example of nested ands and ors
sub is_miniwhile { # check for one-line loop (`foo() while $y--')
my $op = shift;
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" )
)
);
}
#17...........
},
'andor7.def' => {
source => "andor7",
params => "def",
expect => <<'#18...........',
# original is single line:
$a = 1 if $l and !$r or !$l and $r;
#18...........
},
'andor8.def' => {
source => "andor8",
params => "def",
expect => <<'#19...........',
# original is broken:
$a = 1
if $l and !$r
or !$l and $r;
#19...........
},
'andor9.def' => {
source => "andor9",
params => "def",
expect => <<'#20...........',
if (
(
( $old_new and $old_new eq 'changed' )
and ( $db_new and $db_new eq 'changed' )
and ( not defined $old_db )
)
or ( ( $old_new and $old_new eq 'changed' )
and ( $db_new and $db_new eq 'new' )
and ( $old_db and $old_db eq 'new' ) )
or ( ( $old_new and $old_new eq 'new' )
and ( $db_new and $db_new eq 'new' )
and ( not defined $old_db ) )
)
{
return "update";
}
#20...........
},
};
my $ntests = 0 + keys %{$rtests};
plan tests => $ntests;
}
###############
# EXECUTE TESTS
###############
foreach my $key ( sort keys %{$rtests} ) {
my $output;
my $sname = $rtests->{$key}->{source};
my $expect = $rtests->{$key}->{expect};
my $pname = $rtests->{$key}->{params};
my $source = $rsources->{$sname};
my $params = defined($pname) ? $rparams->{$pname} : "";
my $stderr_string;
my $errorfile_string;
my $err = Perl::Tidy::perltidy(
source => \$source,
destination => \$output,
perltidyrc => \$params,
argv => '', # for safety; hide any ARGV from perltidy
stderr => \$stderr_string,
errorfile => \$errorfile_string, # not used when -se flag is set
);
if ( $err || $stderr_string || $errorfile_string ) {
print STDERR "Error output received for test '$key'\n";
if ($err) {
print STDERR "An error flag '$err' was returned\n";
ok( !$err );
}
if ($stderr_string) {
print STDERR "---------------------\n";
print STDERR "<>\n$stderr_string\n";
print STDERR "---------------------\n";
ok( !$stderr_string );
}
if ($errorfile_string) {
print STDERR "---------------------\n";
print STDERR "<<.ERR file>>\n$errorfile_string\n";
print STDERR "---------------------\n";
ok( !$errorfile_string );
}
}
else {
if ( !is( $output, $expect, $key ) ) {
my $leno = length($output);
my $lene = length($expect);
if ( $leno == $lene ) {
print STDERR
"#> Test '$key' gave unexpected output. Strings differ but both have length $leno\n";
}
else {
print STDERR
"#> Test '$key' gave unexpected output. String lengths differ: output=$leno, expected=$lene\n";
}
}
}
}
Perl-Tidy-20210717/t/testwide.pl.src 0000644 0001750 0001750 00000000373 12563255655 016065 0 ustar steve steve %pangrams=("Plain","ASCII",
"Zwölf große Boxkämpfer jagen Vik quer über den Sylter.","DE",
"Jeż wlókł gęś. Uf! Bądź choć przy nim, stań!","PL",
"ЛюбÑ, Ñъешь щипцы, — вздохнёт мÑÑ€, — кайф жгуч.","RU");
Perl-Tidy-20210717/t/snippets9.t 0000644 0001750 0001750 00000027071 14072572633 015234 0 ustar steve steve # Created with: ./make_t.pl
# Contents:
#1 rt70747.rt70747
#2 rt74856.def
#3 rt78156.def
#4 rt78764.def
#5 rt79813.def
#6 rt79947.def
#7 rt80645.def
#8 rt81852.def
#9 rt81852.rt81852
#10 rt81854.def
#11 rt87502.def
#12 rt93197.def
#13 rt94338.def
#14 rt95419.def
#15 rt95708.def
#16 rt96021.def
#17 rt96101.def
#18 rt98902.def
#19 rt98902.rt98902
#20 rt99961.def
# To locate test #13 you can search for its name or the string '#13'
use strict;
use Test::More;
use Carp;
use Perl::Tidy;
my $rparams;
my $rsources;
my $rtests;
BEGIN {
###########################################
# BEGIN SECTION 1: Parameter combinations #
###########################################
$rparams = {
'def' => "",
'rt70747' => "-i=2",
'rt81852' => <<'----------',
-wn
-act=2
----------
'rt98902' => "-boc",
};
############################
# BEGIN SECTION 2: Sources #
############################
$rsources = {
'rt70747' => <<'----------',
coerce Q2RawStatGroupArray, from ArrayRef [Q2StatGroup], via {
[ map {
my $g = $_->as_hash;
$g->{stats} = [ map { scalar $_->as_array } @{ $g->{stats} } ]; $g;
} @$_;
]
};
----------
'rt74856' => <<'----------',
{
my $foo = '1';
#<<<
my $bar = (test())
? 'some value'
: undef;
#>>>
my $baz = 'something else';
}
----------
'rt78156' => <<'----------',
package Some::Class 2.012;
----------
'rt78764' => <<'----------',
qr/3/ ~~ ['1234'] ? 1 : 0;
map { $_ ~~ [ '0', '1' ] ? 'x' : 'o' } @a;
----------
'rt79813' => <<'----------',
my %hash = ( a => { bbbbbbbbb => {
cccccccccc => 'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx',
}, },);
----------
'rt79947' => <<'----------',
try { croak "An Error!"; }
catch ($error) {
print STDERR $error . "\n";
}
----------
'rt80645' => <<'----------',
BEGIN { $^W = 1; }
use warnings;
use strict;
@$ = 'test';
print $#{$};
----------
'rt81852' => <<'----------',
do {
{
next if ( $n % 2 );
print $n, "\n";
}
} while ( $n++ < 10 );
----------
'rt81854' => <<'----------',
return "this is a descriptive error message"
if $res->is_error or not length $data;
----------
'rt87502' => <<'----------',
if ( @ARGV ~~ { map { $_ => 1 } qw(re restart reload) } ) {
# CODE
}
----------
'rt93197' => <<'----------',
$to = $to->{$_} ||= {} for @key; if (1) {2;} else {3;}
----------
'rt94338' => <<'----------',
# for-loop in a parenthesized block-map triggered an error message
map( { foreach my $item ( '0', '1' ) { print $item} } qw(a b c) );
----------
'rt95419' => <<'----------',
case "blah" => sub {
{ a => 1 }
};
----------
'rt95708' => <<'----------',
use strict;
use JSON;
my $ref = {
when => time(), message => 'abc' };
my $json = encode_json {
when => time(), message => 'abc' };
my $json2 = encode_json + {
when => time(), message => 'abc' };
----------
'rt96021' => <<'----------',
$a->@*;
$a->**;
$a->$*;
$a->&*;
$a->%*;
$a->$#*
----------
'rt96101' => <<'----------',
# Example for rt.cpan.org #96101; Perltidy not properly formatting subroutine
# references inside subroutine execution.
# closing brace of second sub should get outdented here
sub startup {
my $self = shift;
$self->plugin(
'authentication' => {
'autoload_user' => 1,
'session_key' => rand(),
'load_user' => sub {
return HaloVP::Users->load(@_);
},
'validate_user' => sub {
return HaloVP::Users->login(@_);
}
}
);
}
----------
'rt98902' => <<'----------',
my %foo = (
alpha => 1,
beta => 2, gamma => 3,
);
my @bar = map { {
number => $_,
character => chr $_,
padding => ( ' ' x $_ ),
} } ( 0 .. 32 );
----------
'rt99961' => <<'----------',
%thing = %{ print qq[blah1\n]; $b; };
----------
};
####################################
# BEGIN SECTION 3: Expected output #
####################################
$rtests = {
'rt70747.rt70747' => {
source => "rt70747",
params => "rt70747",
expect => <<'#1...........',
coerce Q2RawStatGroupArray, from ArrayRef [Q2StatGroup], via {
[
map {
my $g = $_->as_hash;
$g->{stats} = [ map { scalar $_->as_array } @{ $g->{stats} } ];
$g;
} @$_;
]
};
#1...........
},
'rt74856.def' => {
source => "rt74856",
params => "def",
expect => <<'#2...........',
{
my $foo = '1';
#<<<
my $bar = (test())
? 'some value'
: undef;
#>>>
my $baz = 'something else';
}
#2...........
},
'rt78156.def' => {
source => "rt78156",
params => "def",
expect => <<'#3...........',
package Some::Class 2.012;
#3...........
},
'rt78764.def' => {
source => "rt78764",
params => "def",
expect => <<'#4...........',
qr/3/ ~~ ['1234'] ? 1 : 0;
map { $_ ~~ [ '0', '1' ] ? 'x' : 'o' } @a;
#4...........
},
'rt79813.def' => {
source => "rt79813",
params => "def",
expect => <<'#5...........',
my %hash = (
a => {
bbbbbbbbb => {
cccccccccc => 'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx',
},
},
);
#5...........
},
'rt79947.def' => {
source => "rt79947",
params => "def",
expect => <<'#6...........',
try { croak "An Error!"; }
catch ($error) {
print STDERR $error . "\n";
}
#6...........
},
'rt80645.def' => {
source => "rt80645",
params => "def",
expect => <<'#7...........',
BEGIN { $^W = 1; }
use warnings;
use strict;
@$ = 'test';
print $#{$};
#7...........
},
'rt81852.def' => {
source => "rt81852",
params => "def",
expect => <<'#8...........',
do {
{
next if ( $n % 2 );
print $n, "\n";
}
} while ( $n++ < 10 );
#8...........
},
'rt81852.rt81852' => {
source => "rt81852",
params => "rt81852",
expect => <<'#9...........',
do {{
next if ($n % 2);
print $n, "\n";
}} while ($n++ < 10);
#9...........
},
'rt81854.def' => {
source => "rt81854",
params => "def",
expect => <<'#10...........',
return "this is a descriptive error message"
if $res->is_error or not length $data;
#10...........
},
'rt87502.def' => {
source => "rt87502",
params => "def",
expect => <<'#11...........',
if ( @ARGV ~~ { map { $_ => 1 } qw(re restart reload) } ) {
# CODE
}
#11...........
},
'rt93197.def' => {
source => "rt93197",
params => "def",
expect => <<'#12...........',
$to = $to->{$_} ||= {} for @key;
if (1) { 2; }
else { 3; }
#12...........
},
'rt94338.def' => {
source => "rt94338",
params => "def",
expect => <<'#13...........',
# for-loop in a parenthesized block-map triggered an error message
map( {
foreach my $item ( '0', '1' ) {
print $item;
}
} qw(a b c) );
#13...........
},
'rt95419.def' => {
source => "rt95419",
params => "def",
expect => <<'#14...........',
case "blah" => sub {
{ a => 1 }
};
#14...........
},
'rt95708.def' => {
source => "rt95708",
params => "def",
expect => <<'#15...........',
use strict;
use JSON;
my $ref = {
when => time(),
message => 'abc'
};
my $json = encode_json {
when => time(),
message => 'abc'
};
my $json2 = encode_json + {
when => time(),
message => 'abc'
};
#15...........
},
'rt96021.def' => {
source => "rt96021",
params => "def",
expect => <<'#16...........',
$a->@*;
$a->**;
$a->$*;
$a->&*;
$a->%*;
$a->$#*
#16...........
},
'rt96101.def' => {
source => "rt96101",
params => "def",
expect => <<'#17...........',
# Example for rt.cpan.org #96101; Perltidy not properly formatting subroutine
# references inside subroutine execution.
# closing brace of second sub should get outdented here
sub startup {
my $self = shift;
$self->plugin(
'authentication' => {
'autoload_user' => 1,
'session_key' => rand(),
'load_user' => sub {
return HaloVP::Users->load(@_);
},
'validate_user' => sub {
return HaloVP::Users->login(@_);
}
}
);
}
#17...........
},
'rt98902.def' => {
source => "rt98902",
params => "def",
expect => <<'#18...........',
my %foo = (
alpha => 1,
beta => 2,
gamma => 3,
);
my @bar =
map { { number => $_, character => chr $_, padding => ( ' ' x $_ ), } }
( 0 .. 32 );
#18...........
},
'rt98902.rt98902' => {
source => "rt98902",
params => "rt98902",
expect => <<'#19...........',
my %foo = (
alpha => 1,
beta => 2, gamma => 3,
);
my @bar = map {
{
number => $_,
character => chr $_,
padding => ( ' ' x $_ ),
}
} ( 0 .. 32 );
#19...........
},
'rt99961.def' => {
source => "rt99961",
params => "def",
expect => <<'#20...........',
%thing = %{
print qq[blah1\n];
$b;
};
#20...........
},
};
my $ntests = 0 + keys %{$rtests};
plan tests => $ntests;
}
###############
# EXECUTE TESTS
###############
foreach my $key ( sort keys %{$rtests} ) {
my $output;
my $sname = $rtests->{$key}->{source};
my $expect = $rtests->{$key}->{expect};
my $pname = $rtests->{$key}->{params};
my $source = $rsources->{$sname};
my $params = defined($pname) ? $rparams->{$pname} : "";
my $stderr_string;
my $errorfile_string;
my $err = Perl::Tidy::perltidy(
source => \$source,
destination => \$output,
perltidyrc => \$params,
argv => '', # for safety; hide any ARGV from perltidy
stderr => \$stderr_string,
errorfile => \$errorfile_string, # not used when -se flag is set
);
if ( $err || $stderr_string || $errorfile_string ) {
print STDERR "Error output received for test '$key'\n";
if ($err) {
print STDERR "An error flag '$err' was returned\n";
ok( !$err );
}
if ($stderr_string) {
print STDERR "---------------------\n";
print STDERR "<>\n$stderr_string\n";
print STDERR "---------------------\n";
ok( !$stderr_string );
}
if ($errorfile_string) {
print STDERR "---------------------\n";
print STDERR "<<.ERR file>>\n$errorfile_string\n";
print STDERR "---------------------\n";
ok( !$errorfile_string );
}
}
else {
if ( !is( $output, $expect, $key ) ) {
my $leno = length($output);
my $lene = length($expect);
if ( $leno == $lene ) {
print STDERR
"#> Test '$key' gave unexpected output. Strings differ but both have length $leno\n";
}
else {
print STDERR
"#> Test '$key' gave unexpected output. String lengths differ: output=$leno, expected=$lene\n";
}
}
}
}
Perl-Tidy-20210717/t/test-eol.t 0000644 0001750 0001750 00000007053 13721052601 015014 0 ustar steve steve use strict;
use File::Temp;
use Test;
use Carp;
BEGIN {plan tests => 4}
use Perl::Tidy;
#----------------------------------------------------------------------
## test string->string
#----------------------------------------------------------------------
my $source_template = <<'EOM';
%height=("letter",27.9, "legal",35.6, "arche",121.9, "archd",91.4, "archc",61,
"archb",45.7, "archa",30.5, "flsa",33, "flse",33, "halfletter",21.6,
"11x17",43.2, "ledger",27.9);
%width=("letter",21.6, "legal",21.6, "arche",91.4, "archd",61, "archc",45.7,
"archb",30.5, "archa",22.9, "flsa",21.6, "flse",21.6, "halfletter",14,
"11x17",27.9, "ledger",43.2);
EOM
my $perltidyrc;
my $expected_output_template=<<'EOM';
%height = (
"letter", 27.9, "legal", 35.6, "arche", 121.9,
"archd", 91.4, "archc", 61, "archb", 45.7,
"archa", 30.5, "flsa", 33, "flse", 33,
"halfletter", 21.6, "11x17", 43.2, "ledger", 27.9
);
%width = (
"letter", 21.6, "legal", 21.6, "arche", 91.4,
"archd", 61, "archc", 45.7, "archb", 30.5,
"archa", 22.9, "flsa", 21.6, "flse", 21.6,
"halfletter", 14, "11x17", 27.9, "ledger", 43.2
);
EOM
my $source;
my $output;
my $expected_output;
my $CR = chr(015);
my $LF = chr(012);
$perltidyrc = <<'EOM';
-gnu
--output-line-ending="unix" # use *nix LF EOLs
EOM
$source = $source_template;
$source =~ s/\n/$CR$LF/gmsx;
$expected_output = $expected_output_template;
$expected_output =~ s/\n/$LF/gmsx;
# my ($source_fh, $source_filename) = File::Temp::tempfile(); close $source_filename;
my ($output_fh, $output_filename) = File::Temp::tempfile(); close $output_filename;
# print STDERR "# source_filename = ", $source_filename, "\n";
# print STDERR "# output_filename = ", $output_filename, "\n";
# open $source_fh, ">", $source_filename;
# binmode $source_fh, ":raw";
# print $source_fh $source;
# close $source_fh;
# in-memory output (non-UTF8)
Perl::Tidy::perltidy(
source => \$source,
destination => \$output,
perltidyrc => \$perltidyrc,
argv => '',
);
ok($output, $expected_output, "in-memory EOLs (non-UTF8)");
# file output (non-UTF8)
Perl::Tidy::perltidy(
source => \$source,
destination => $output_filename,
perltidyrc => \$perltidyrc,
argv => '',
);
{# slurp entire file
local $/ = undef;
open $output_fh, "<", $output_filename;
binmode $output_fh, ":raw";
$output = <$output_fh>;
}
ok($output, $expected_output, "output file EOLs (non-UTF8)");
$perltidyrc = <<'EOM';
-gnu
--character-encoding="utf8" # treat files as UTF-8 (decode and encode)
--output-line-ending="unix" # use *nix LF EOLs
EOM
# in-memory (UTF8)
$source = $source_template;
$source =~ s/\n/$CR$LF/gmsx;
$expected_output = $expected_output_template;
$expected_output =~ s/\n/$LF/gmsx;
Perl::Tidy::perltidy(
source => \$source,
destination => \$output,
perltidyrc => \$perltidyrc,
argv => '',
);
ok($output, $expected_output, "in-memory EOLs (UTF8)");
# file output (UTF8)
Perl::Tidy::perltidy(
source => \$source,
destination => $output_filename,
perltidyrc => \$perltidyrc,
argv => '',
);
{# slurp entire file
local $/ = undef;
open $output_fh, "<", $output_filename;
binmode $output_fh, ":raw";
$output = <$output_fh>;
}
ok($output, $expected_output, "output file EOLs (UTF8)");
# Try to delete the tmpfile;
# Comment this out if it causes a failure at Appveyor
if ( -e $output_filename ) { unlink $output_filename }
Perl-Tidy-20210717/t/snippets11.t 0000644 0001750 0001750 00000035477 14072572630 015313 0 ustar steve steve # Created with: ./make_t.pl
# Contents:
#1 sub1.def
#2 sub2.def
#3 switch1.def
#4 syntax1.def
#5 syntax2.def
#6 ternary1.def
#7 ternary2.def
#8 tick1.def
#9 trim_quote.def
#10 tso1.def
#11 tso1.tso
#12 tutor.def
#13 undoci1.def
#14 use1.def
#15 use2.def
#16 version1.def
#17 version2.def
#18 vert.def
#19 vmll.def
#20 vmll.vmll
# To locate test #13 you can search for its name or the string '#13'
use strict;
use Test::More;
use Carp;
use Perl::Tidy;
my $rparams;
my $rsources;
my $rtests;
BEGIN {
###########################################
# BEGIN SECTION 1: Parameter combinations #
###########################################
$rparams = {
'def' => "",
'tso' => "-tso",
'vmll' => <<'----------',
-vmll
-bbt=2
-bt=2
-pt=2
-sbt=2
----------
};
############################
# BEGIN SECTION 2: Sources #
############################
$rsources = {
'sub1' => <<'----------',
my::doit();
join::doit();
for::doit();
sub::doit();
package::doit();
__END__::doit();
__DATA__::doit();
package my;
sub doit{print"Hello My\n";}package join;
sub doit{print"Hello Join\n";}package for;
sub doit{print"Hello for\n";}package package;
sub doit{print"Hello package\n";}package sub;
sub doit{print"Hello sub\n";}package __END__;
sub doit{print"Hello __END__\n";}package __DATA__;
sub doit{print"Hello __DATA__\n";}
----------
'sub2' => <<'----------',
my $selector;
# leading atrribute separator:
$a =
sub
: locked {
print "Hello, World!\n";
};
$a->();
# colon as both ?/: and attribute separator
$a = $selector
? sub : locked {
print "Hello, World!\n";
}
: sub : locked {
print "GOODBYE!\n";
};
$a->();
----------
'switch1' => <<'----------',
sub classify_digit ($digit)
{ switch($digit)
{ case 0 { return 'zero' } case [ 2, 4, 6, 8 ]{ return 'even' }
case [ 1, 3, 4, 7, 9 ]{ return 'odd' } case /[A-F]/i { return 'hex' } }
}
----------
'syntax1' => <<'----------',
# Caused trouble:
print $x **2;
----------
'syntax2' => <<'----------',
# ? was taken as pattern
my $case_flag = File::Spec->case_tolerant ? '(?i)' : '';
----------
'ternary1' => <<'----------',
my $flags =
( $_ & 1 ) ? ( $_ & 4 ) ? $THRf_DEAD : $THRf_ZOMBIE :
( $_ & 4 ) ? $THRf_R_DETACHED : $THRf_R_JOINABLE;
----------
'ternary2' => <<'----------',
my $a=($b) ? ($c) ? ($d) ? $d1
: $d2
: ($e) ? $e1
: $e2
: ($f) ? ($g) ? $g1
: $g2
: ($h) ? $h1
: $h2;
----------
'tick1' => <<'----------',
sub a'this { $p'u'a = "mooo\n"; print $p::u::a; }
a::this(); # print "mooo"
print $p'u'a; # print "mooo"
sub a::that {
$p't'u = "wwoo\n";
return sub { print $p't'u}
}
$a'that = a'that();
$a'that->(); # print "wwoo"
$a'that = a'that();
$p::t::u = "booo\n";
$a'that->(); # print "booo"
----------
'trim_quote' => <<'----------',
# space after quote will get trimmed
push @m, '
all :: pure_all manifypods
' . $self->{NOECHO} . '$(NOOP)
'
unless $self->{SKIPHASH}{'all'};
----------
'tso1' => <<'----------',
print 0+ '42 EUR'; # 42
----------
'tutor' => <<'----------',
#!/usr/bin/perl
$y=shift||5;for $i(1..10){$l[$i]="T";$w[$i]=999999;}while(1){print"Name:";$u=;$t=50;$a=time;for(0..9){$x="";for(1..$y){$x.=chr(int(rand(126-33)+33));}while($z ne $x){print"\r\n$x\r\n";$z=;chomp($z);$t-=5;}}$b=time;$t-=($b-$a)*2;$t=0-$t;$z=1;@q=@l;@p=@w;print "You scored $t points\r\nTopTen\r\n";for $i(1..10){if ($t<$p[$z]){$l[$i]=$u;chomp($l[$i]);$w[$i]=$t;$t=1000000}else{$l[$i]=$q[$z];$w[$i]=$p[$z];$z++;}print $l[$i],"\t",$w[$i],"\r\n";}}
----------
'undoci1' => <<'----------',
$rinfo{deleteStyle} = [
-fill => 'red',
-stipple => '@' . Tk->findINC('demos/images/grey.25'),
];
----------
'use1' => <<'----------',
# previously this caused an incorrect error message after '2.42'
use lib "$Common::global::gInstallRoot/lib";
use CGI 2.42 qw(fatalsToBrowser);
use RRDs 1.000101;
# the 0666 must expect an operator
use constant MODE => do { 0666 & ( 0777 & ~umask ) };
use IO::File ();
----------
'use2' => <<'----------',
# Keep the space before the '()' here:
use Foo::Bar ();
use Foo::Bar ();
use Foo::Bar 1.0 ();
use Foo::Bar qw(baz);
use Foo::Bar 1.0 qw(baz);
----------
'version1' => <<'----------',
# VERSION statement unbroken, no semicolon added;
our $VERSION = do { my @r = ( q$Revision: 2.2 $ =~ /\d+/g ); sprintf "%d." . "%02d" x $#r, @r }
----------
'version2' => <<'----------',
# On one line so MakeMaker will see it.
require Exporter; our $VERSION = $Exporter::VERSION;
----------
'vert' => <<'----------',
# if $w->vert is tokenized as type 'U' then the ? will start a quote
# and an error will occur.
sub vert {
}
sub Restore {
$w->vert ? $w->delta_width(0) : $w->delta_height(0);
}
----------
'vmll' => <<'----------',
# perltidy -act=2 -vmll will leave these intact and greater than 80 columns
# in length, which is what vmll does
BEGIN {is_deeply(\@init_metas_called, [1]) || diag(Dumper(\@init_metas_called))}
This has the comma on the next line
exception {Class::MOP::Class->initialize("NonExistent")->rebless_instance($foo)},
----------
};
####################################
# BEGIN SECTION 3: Expected output #
####################################
$rtests = {
'sub1.def' => {
source => "sub1",
params => "def",
expect => <<'#1...........',
my::doit();
join::doit();
for::doit();
sub::doit();
package::doit();
__END__::doit();
__DATA__::doit();
package my;
sub doit { print "Hello My\n"; }
package join;
sub doit { print "Hello Join\n"; }
package for;
sub doit { print "Hello for\n"; }
package package;
sub doit { print "Hello package\n"; }
package sub;
sub doit { print "Hello sub\n"; }
package __END__;
sub doit { print "Hello __END__\n"; }
package __DATA__;
sub doit { print "Hello __DATA__\n"; }
#1...........
},
'sub2.def' => {
source => "sub2",
params => "def",
expect => <<'#2...........',
my $selector;
# leading atrribute separator:
$a = sub
: locked {
print "Hello, World!\n";
};
$a->();
# colon as both ?/: and attribute separator
$a = $selector
? sub : locked {
print "Hello, World!\n";
}
: sub : locked {
print "GOODBYE!\n";
};
$a->();
#2...........
},
'switch1.def' => {
source => "switch1",
params => "def",
expect => <<'#3...........',
sub classify_digit ($digit) {
switch ($digit) {
case 0 { return 'zero' }
case [ 2, 4, 6, 8 ]{ return 'even' }
case [ 1, 3, 4, 7, 9 ]{ return 'odd' }
case /[A-F]/i { return 'hex' }
}
}
#3...........
},
'syntax1.def' => {
source => "syntax1",
params => "def",
expect => <<'#4...........',
# Caused trouble:
print $x **2;
#4...........
},
'syntax2.def' => {
source => "syntax2",
params => "def",
expect => <<'#5...........',
# ? was taken as pattern
my $case_flag = File::Spec->case_tolerant ? '(?i)' : '';
#5...........
},
'ternary1.def' => {
source => "ternary1",
params => "def",
expect => <<'#6...........',
my $flags =
( $_ & 1 )
? ( $_ & 4 )
? $THRf_DEAD
: $THRf_ZOMBIE
: ( $_ & 4 ) ? $THRf_R_DETACHED
: $THRf_R_JOINABLE;
#6...........
},
'ternary2.def' => {
source => "ternary2",
params => "def",
expect => <<'#7...........',
my $a =
($b)
? ($c)
? ($d)
? $d1
: $d2
: ($e) ? $e1
: $e2
: ($f) ? ($g)
? $g1
: $g2
: ($h) ? $h1
: $h2;
#7...........
},
'tick1.def' => {
source => "tick1",
params => "def",
expect => <<'#8...........',
sub a'this { $p'u'a = "mooo\n"; print $p::u::a; }
a::this(); # print "mooo"
print $p'u'a; # print "mooo"
sub a::that {
$p't'u = "wwoo\n";
return sub { print $p't'u}
}
$a'that = a'that();
$a'that->(); # print "wwoo"
$a'that = a'that();
$p::t::u = "booo\n";
$a'that->(); # print "booo"
#8...........
},
'trim_quote.def' => {
source => "trim_quote",
params => "def",
expect => <<'#9...........',
# space after quote will get trimmed
push @m, '
all :: pure_all manifypods
' . $self->{NOECHO} . '$(NOOP)
'
unless $self->{SKIPHASH}{'all'};
#9...........
},
'tso1.def' => {
source => "tso1",
params => "def",
expect => <<'#10...........',
print 0 + '42 EUR'; # 42
#10...........
},
'tso1.tso' => {
source => "tso1",
params => "tso",
expect => <<'#11...........',
print 0+ '42 EUR'; # 42
#11...........
},
'tutor.def' => {
source => "tutor",
params => "def",
expect => <<'#12...........',
#!/usr/bin/perl
$y = shift || 5;
for $i ( 1 .. 10 ) { $l[$i] = "T"; $w[$i] = 999999; }
while (1) {
print "Name:";
$u = ;
$t = 50;
$a = time;
for ( 0 .. 9 ) {
$x = "";
for ( 1 .. $y ) { $x .= chr( int( rand( 126 - 33 ) + 33 ) ); }
while ( $z ne $x ) {
print "\r\n$x\r\n";
$z = ;
chomp($z);
$t -= 5;
}
}
$b = time;
$t -= ( $b - $a ) * 2;
$t = 0 - $t;
$z = 1;
@q = @l;
@p = @w;
print "You scored $t points\r\nTopTen\r\n";
for $i ( 1 .. 10 ) {
if ( $t < $p[$z] ) {
$l[$i] = $u;
chomp( $l[$i] );
$w[$i] = $t;
$t = 1000000;
}
else { $l[$i] = $q[$z]; $w[$i] = $p[$z]; $z++; }
print $l[$i], "\t", $w[$i], "\r\n";
}
}
#12...........
},
'undoci1.def' => {
source => "undoci1",
params => "def",
expect => <<'#13...........',
$rinfo{deleteStyle} = [
-fill => 'red',
-stipple => '@' . Tk->findINC('demos/images/grey.25'),
];
#13...........
},
'use1.def' => {
source => "use1",
params => "def",
expect => <<'#14...........',
# previously this caused an incorrect error message after '2.42'
use lib "$Common::global::gInstallRoot/lib";
use CGI 2.42 qw(fatalsToBrowser);
use RRDs 1.000101;
# the 0666 must expect an operator
use constant MODE => do { 0666 & ( 0777 & ~umask ) };
use IO::File ();
#14...........
},
'use2.def' => {
source => "use2",
params => "def",
expect => <<'#15...........',
# Keep the space before the '()' here:
use Foo::Bar ();
use Foo::Bar ();
use Foo::Bar 1.0 ();
use Foo::Bar qw(baz);
use Foo::Bar 1.0 qw(baz);
#15...........
},
'version1.def' => {
source => "version1",
params => "def",
expect => <<'#16...........',
# VERSION statement unbroken, no semicolon added;
our $VERSION = do { my @r = ( q$Revision: 2.2 $ =~ /\d+/g ); sprintf "%d." . "%02d" x $#r, @r }
#16...........
},
'version2.def' => {
source => "version2",
params => "def",
expect => <<'#17...........',
# On one line so MakeMaker will see it.
require Exporter; our $VERSION = $Exporter::VERSION;
#17...........
},
'vert.def' => {
source => "vert",
params => "def",
expect => <<'#18...........',
# if $w->vert is tokenized as type 'U' then the ? will start a quote
# and an error will occur.
sub vert {
}
sub Restore {
$w->vert ? $w->delta_width(0) : $w->delta_height(0);
}
#18...........
},
'vmll.def' => {
source => "vmll",
params => "def",
expect => <<'#19...........',
# perltidy -act=2 -vmll will leave these intact and greater than 80 columns
# in length, which is what vmll does
BEGIN {
is_deeply( \@init_metas_called, [1] )
|| diag( Dumper( \@init_metas_called ) );
}
This has the comma on the next line exception {
Class::MOP::Class->initialize("NonExistent")->rebless_instance($foo)
},
#19...........
},
'vmll.vmll' => {
source => "vmll",
params => "vmll",
expect => <<'#20...........',
# perltidy -act=2 -vmll will leave these intact and greater than 80 columns
# in length, which is what vmll does
BEGIN {is_deeply(\@init_metas_called, [1]) || diag(Dumper(\@init_metas_called))}
This has the comma on the next line exception {
Class::MOP::Class->initialize("NonExistent")->rebless_instance($foo)
},
#20...........
},
};
my $ntests = 0 + keys %{$rtests};
plan tests => $ntests;
}
###############
# EXECUTE TESTS
###############
foreach my $key ( sort keys %{$rtests} ) {
my $output;
my $sname = $rtests->{$key}->{source};
my $expect = $rtests->{$key}->{expect};
my $pname = $rtests->{$key}->{params};
my $source = $rsources->{$sname};
my $params = defined($pname) ? $rparams->{$pname} : "";
my $stderr_string;
my $errorfile_string;
my $err = Perl::Tidy::perltidy(
source => \$source,
destination => \$output,
perltidyrc => \$params,
argv => '', # for safety; hide any ARGV from perltidy
stderr => \$stderr_string,
errorfile => \$errorfile_string, # not used when -se flag is set
);
if ( $err || $stderr_string || $errorfile_string ) {
print STDERR "Error output received for test '$key'\n";
if ($err) {
print STDERR "An error flag '$err' was returned\n";
ok( !$err );
}
if ($stderr_string) {
print STDERR "---------------------\n";
print STDERR "<>\n$stderr_string\n";
print STDERR "---------------------\n";
ok( !$stderr_string );
}
if ($errorfile_string) {
print STDERR "---------------------\n";
print STDERR "<<.ERR file>>\n$errorfile_string\n";
print STDERR "---------------------\n";
ok( !$errorfile_string );
}
}
else {
if ( !is( $output, $expect, $key ) ) {
my $leno = length($output);
my $lene = length($expect);
if ( $leno == $lene ) {
print STDERR
"#> Test '$key' gave unexpected output. Strings differ but both have length $leno\n";
}
else {
print STDERR
"#> Test '$key' gave unexpected output. String lengths differ: output=$leno, expected=$lene\n";
}
}
}
}
Perl-Tidy-20210717/t/testwide.t 0000755 0001750 0001750 00000004202 13720554242 015113 0 ustar steve steve use strict;
use utf8;
use Test;
use Carp;
use FindBin;
BEGIN {unshift @INC, "./"}
BEGIN {plan tests => 3}
use Perl::Tidy;
my $source = <<'EOM';
%pangrams=("Plain","ASCII",
"Zwölf große Boxkämpfer jagen Vik quer über den Sylter.","DE",
"Jeż wlókł gęś. Uf! Bądź choć przy nim, stań!","PL",
"ЛюбÑ, Ñъешь щипцы, — вздохнёт мÑÑ€, — кайф жгуч.","RU");
EOM
my $expected_output=<<'EOM';
%pangrams = (
"Plain", "ASCII",
"Zwölf große Boxkämpfer jagen Vik quer über den Sylter.", "DE",
"Jeż wlókł gęś. Uf! Bądź choć przy nim, stań!", "PL",
"ЛюбÑ, Ñъешь щипцы, — вздохнёт мÑÑ€, — кайф жгуч.", "RU"
);
EOM
my $perltidyrc = <<'EOM';
-gnu -enc=utf8
EOM
my $output;
Perl::Tidy::perltidy(
source => \$source,
destination => \$output,
perltidyrc => \$perltidyrc,
argv => '-nsyn',
);
ok($output, $expected_output);
Perl::Tidy::perltidy(
source => $FindBin::Bin . '/testwide.pl.src',
destination => \$output,
perltidyrc => \$perltidyrc,
argv => '-nsyn',
);
ok($output, $expected_output);
# Test writing encoded output to stdout with the -st flag
# References: RT #133166, RT #133171, git #35
$output = "";
do {
# Send STDOUT to a temporary file
use File::Temp ();
my $fh = new File::Temp();
my $tmpfile = $fh->filename;
# Note that we are not specifying an encoding here. Perltidy should do that.
local *STDOUT;
open STDOUT, '>', $tmpfile or die "Can't open tmpfile: $!";
Perl::Tidy::perltidy(
source => \$source,
##destination => ... we are using -st, so no destination is specified
perltidyrc => \$perltidyrc,
argv => '-nsyn -st', # added -st
);
close STDOUT;
# Read the temporary file back in. Note that here we need to specify
# the encoding.
open TMP, '<', $tmpfile;
binmode TMP, ":raw:encoding(UTF-8)";
while ( my $line = ) { $output .= $line }
};
ok($output, $expected_output);
Perl-Tidy-20210717/t/snippets20.t 0000644 0001750 0001750 00000047077 14072572631 015313 0 ustar steve steve # Created with: ./make_t.pl
# Contents:
#1 space6.def
#2 space6.space6
#3 sub3.def
#4 wc.def
#5 wc.wc1
#6 wc.wc2
#7 ce2.ce
#8 ce2.def
#9 gnu6.def
#10 gnu6.gnu
#11 git25.def
#12 git25.git25
#13 outdent.outdent2
#14 kpit.def
#15 kpit.kpit
#16 kpitl.def
#17 kpitl.kpitl
#18 hanging_side_comments3.def
#19 lop.def
# To locate test #13 you can search for its name or the string '#13'
use strict;
use Test::More;
use Carp;
use Perl::Tidy;
my $rparams;
my $rsources;
my $rtests;
BEGIN {
###########################################
# BEGIN SECTION 1: Parameter combinations #
###########################################
$rparams = {
'ce' => "-cuddled-blocks",
'def' => "",
'git25' => "-l=0",
'gnu' => "-gnu",
'kpit' => "-pt=2 -kpit=0",
'kpitl' => <<'----------',
-kpit=0 -kpitl='return factorial' -pt=2
----------
'outdent2' => <<'----------',
# test -okw and -okwl
-okw -okwl='next'
----------
'space6' => <<'----------',
-nwrs="+ - / *"
-nwls="+ - / *"
----------
'wc1' => "-wc=4",
'wc2' => "-wc=4 -wn",
};
############################
# BEGIN SECTION 2: Sources #
############################
$rsources = {
'ce2' => <<'----------',
# Previously, perltidy -ce would move a closing brace below a pod section to
# form '} else {'. No longer doing this because if you change back to -nce, the
# brace cannot go back to where it was.
if ($notty) {
$runnonstop = 1;
share($runnonstop);
}
=pod
If there is a TTY, we have to determine who it belongs to before we can
...
=cut
else {
# Is Perl being run from a slave editor or graphical debugger?
...
}
----------
'git25' => <<'----------',
# example for git #25; use -l=0; was losing alignment; sub 'fix_ragged_lists' was added to fix this
my $mapping = [
# ...
{ 'is_col' => 'dsstdat', 'cr_col' => 'enroll_isaric_date', 'trans' => 0, },
{ 'is_col' => 'corona_ieorres', 'cr_col' => '', 'trans' => 0, },
{ 'is_col' => 'symptoms_fever', 'cr_col' => 'elig_fever', 'trans' => 1, 'manually_reviewed' => '@TODO', 'map' => { '0' => '0', '1' => '1', '9' => '@TODO' }, },
{ 'is_col' => 'symptoms_cough', 'cr_col' => 'elig_cough', 'trans' => 1, 'manually_reviewed' => '@TODO', 'map' => { '0' => '0', '1' => '1', '9' => '@TODO' }, },
{ 'is_col' => 'symptoms_dys_tachy_noea', 'cr_col' => 'elig_dyspnea', 'trans' => 1, 'manually_reviewed' => '@TODO', 'map' => { '0' => '0', '1' => '1', '9' => '@TODO' }, },
{ 'is_col' => 'symptoms_clinical_susp', 'cr_col' => 'elig_ari', 'trans' => 0, },
{ 'is_col' => 'sex', 'cr_col' => 'sex', 'trans' => 1, 'manually_reviewed' => 1, 'map' => { '0' => '1', '1' => '2' }, },
{ 'is_col' => 'age', 'cr_col' => '', 'trans' => 0, },
{ 'is_col' => 'ageu', 'cr_col' => '', 'trans' => 0, },
# ...
];
----------
'gnu6' => <<'----------',
# the closing braces should have the same position for these two hashes with -gnu
$var1 = {
'foo10' => undef,
'foo72' => '
',
};
$var2 = {
'foo72' => '
',
'foo10' => undef,
};
----------
'hanging_side_comments3' => <<'----------',
if ( $var eq 'wastebasket' ) { # this sends a pure block
# of hanging side comments
#to the vertical aligner.
#It caused a crash in
#a test version of
#sub 'delete_unmatched_tokens'
#...
#}
}
elsif ( $var eq 'spacecommand' ) {
&die("No $val function") unless eval "defined &$val";
}
----------
'kpit' => <<'----------',
if ( seek(DATA, 0, 0) ) { ... }
# The foreach keyword may be separated from the next opening paren
foreach $req(@bgQueue) {
...
}
# This had trouble because a later padding operation removed the inside space
while ($CmdJob eq "" && @CmdQueue > 0 && $RunNightlyWhenIdle != 1
|| @CmdQueue > 0 && $RunNightlyWhenIdle == 2 && $bpc->isAdminJob($CmdQueue[0]->{host})) {
...
}
----------
'kpitl' => <<'----------',
return ( $r**$n ) * ( pi**( $n / 2 ) ) / ( sqrt(pi) * factorial( 2 * ( int( $n
/ 2 ) ) + 2 ) / factorial( int( $n / 2 ) + 1 ) / ( 4**( int( $n / 2 ) + 1 ) )
);
----------
'lop' => <<'----------',
# logical padding examples
$same =
( ( $aP eq $bP )
&& ( $aS eq $bS )
&& ( $aT eq $bT )
&& ( $a->{'title'} eq $b->{'title'} )
&& ( $a->{'href'} eq $b->{'href'} ) );
$bits =
$top > 0xffff ? 32
: $top > 0xff ? 16
: $top > 1 ? 8
: 1;
lc( $self->mime_attr('content-type')
|| $self->{MIH_DefaultType}
|| 'text/plain' );
# Padding can also remove spaces; here the space after the '(' is lost:
elsif ( $statement_type =~ /^sub\b/
|| $paren_type[$paren_depth] =~ /^sub\b/ )
----------
'outdent' => <<'----------',
my $i;
LOOP: while ( $i = ) {
chomp($i);
next unless $i;
fixit($i);
}
----------
'space6' => <<'----------',
# test some spacing rules at possible filehandles
my $z=$x/$y; # ok to change spaces around both sides of the /
print $x / $y; # do not remove space before or after / here
print $x/$y; # do not add a space before the / here
print $x+$y; # do not add a space before the + here
----------
'sub3' => <<'----------',
# keep these one-line blocks intact
my $aa = sub
#line 245 "Parse.yp"
{ n_stmtexp $_[1] };
my $bb = sub #
{ n_stmtexp $_[1] };
----------
'wc' => <<'----------',
{
my (@indices) =
sort {
$dir eq 'left' ? $cells[$a] <=> $cells[$b] : $cells[$b] <=> $cells[$a];
} (0 .. $#cells);
{{{{
if ( !$array[0] ) {
$array[0] =
&$CantProcessPartFunc( $entity->{'fields'}{
'content-type'} );
}
}}}}}
----------
};
####################################
# BEGIN SECTION 3: Expected output #
####################################
$rtests = {
'space6.def' => {
source => "space6",
params => "def",
expect => <<'#1...........',
# test some spacing rules at possible filehandles
my $z = $x / $y; # ok to change spaces around both sides of the /
print $x / $y; # do not remove space before or after / here
print $x/ $y; # do not add a space before the / here
print $x+ $y; # do not add a space before the + here
#1...........
},
'space6.space6' => {
source => "space6",
params => "space6",
expect => <<'#2...........',
# test some spacing rules at possible filehandles
my $z = $x/$y; # ok to change spaces around both sides of the /
print $x / $y; # do not remove space before or after / here
print $x/$y; # do not add a space before the / here
print $x+$y; # do not add a space before the + here
#2...........
},
'sub3.def' => {
source => "sub3",
params => "def",
expect => <<'#3...........',
# keep these one-line blocks intact
my $aa = sub
#line 245 "Parse.yp"
{ n_stmtexp $_[1] };
my $bb = sub #
{ n_stmtexp $_[1] };
#3...........
},
'wc.def' => {
source => "wc",
params => "def",
expect => <<'#4...........',
{
my (@indices) =
sort {
$dir eq 'left' ? $cells[$a] <=> $cells[$b] : $cells[$b] <=> $cells[$a];
} ( 0 .. $#cells );
{
{
{
{
if ( !$array[0] ) {
$array[0] =
&$CantProcessPartFunc(
$entity->{'fields'}{'content-type'} );
}
}
}
}
}
}
#4...........
},
'wc.wc1' => {
source => "wc",
params => "wc1",
expect => <<'#5...........',
{
my (@indices) =
sort {
$dir eq 'left' ? $cells[$a] <=> $cells[$b] : $cells[$b] <=> $cells[$a];
} ( 0 .. $#cells );
{
{
{
{
if ( !$array[0] ) {
$array[0] =
&$CantProcessPartFunc( $entity->{'fields'}{'content-type'} );
}
}
}
}
}
}
#5...........
},
'wc.wc2' => {
source => "wc",
params => "wc2",
expect => <<'#6...........',
{
my (@indices) =
sort {
$dir eq 'left' ? $cells[$a] <=> $cells[$b] : $cells[$b] <=> $cells[$a];
} ( 0 .. $#cells );
{ { { {
if ( !$array[0] ) {
$array[0] =
&$CantProcessPartFunc( $entity->{'fields'}{'content-type'} );
}
} } } }
}
#6...........
},
'ce2.ce' => {
source => "ce2",
params => "ce",
expect => <<'#7...........',
# Previously, perltidy -ce would move a closing brace below a pod section to
# form '} else {'. No longer doing this because if you change back to -nce, the
# brace cannot go back to where it was.
if ($notty) {
$runnonstop = 1;
share($runnonstop);
}
=pod
If there is a TTY, we have to determine who it belongs to before we can
...
=cut
else {
# Is Perl being run from a slave editor or graphical debugger?
...;
}
#7...........
},
'ce2.def' => {
source => "ce2",
params => "def",
expect => <<'#8...........',
# Previously, perltidy -ce would move a closing brace below a pod section to
# form '} else {'. No longer doing this because if you change back to -nce, the
# brace cannot go back to where it was.
if ($notty) {
$runnonstop = 1;
share($runnonstop);
}
=pod
If there is a TTY, we have to determine who it belongs to before we can
...
=cut
else {
# Is Perl being run from a slave editor or graphical debugger?
...;
}
#8...........
},
'gnu6.def' => {
source => "gnu6",
params => "def",
expect => <<'#9...........',
# the closing braces should have the same position for these two hashes with -gnu
$var1 = {
'foo10' => undef,
'foo72' => '
',
};
$var2 = {
'foo72' => '
',
'foo10' => undef,
};
#9...........
},
'gnu6.gnu' => {
source => "gnu6",
params => "gnu",
expect => <<'#10...........',
# the closing braces should have the same position for these two hashes with -gnu
$var1 = {
'foo10' => undef,
'foo72' => '
',
};
$var2 = {
'foo72' => '
',
'foo10' => undef,
};
#10...........
},
'git25.def' => {
source => "git25",
params => "def",
expect => <<'#11...........',
# example for git #25; use -l=0; was losing alignment; sub 'fix_ragged_lists' was added to fix this
my $mapping = [
# ...
{ 'is_col' => 'dsstdat', 'cr_col' => 'enroll_isaric_date', 'trans' => 0, },
{ 'is_col' => 'corona_ieorres', 'cr_col' => '', 'trans' => 0, },
{
'is_col' => 'symptoms_fever',
'cr_col' => 'elig_fever',
'trans' => 1,
'manually_reviewed' => '@TODO',
'map' => { '0' => '0', '1' => '1', '9' => '@TODO' },
},
{
'is_col' => 'symptoms_cough',
'cr_col' => 'elig_cough',
'trans' => 1,
'manually_reviewed' => '@TODO',
'map' => { '0' => '0', '1' => '1', '9' => '@TODO' },
},
{
'is_col' => 'symptoms_dys_tachy_noea',
'cr_col' => 'elig_dyspnea',
'trans' => 1,
'manually_reviewed' => '@TODO',
'map' => { '0' => '0', '1' => '1', '9' => '@TODO' },
},
{
'is_col' => 'symptoms_clinical_susp',
'cr_col' => 'elig_ari',
'trans' => 0,
},
{
'is_col' => 'sex',
'cr_col' => 'sex',
'trans' => 1,
'manually_reviewed' => 1,
'map' => { '0' => '1', '1' => '2' },
},
{ 'is_col' => 'age', 'cr_col' => '', 'trans' => 0, },
{ 'is_col' => 'ageu', 'cr_col' => '', 'trans' => 0, },
# ...
];
#11...........
},
'git25.git25' => {
source => "git25",
params => "git25",
expect => <<'#12...........',
# example for git #25; use -l=0; was losing alignment; sub 'fix_ragged_lists' was added to fix this
my $mapping = [
# ...
{ 'is_col' => 'dsstdat', 'cr_col' => 'enroll_isaric_date', 'trans' => 0, },
{ 'is_col' => 'corona_ieorres', 'cr_col' => '', 'trans' => 0, },
{ 'is_col' => 'symptoms_fever', 'cr_col' => 'elig_fever', 'trans' => 1, 'manually_reviewed' => '@TODO', 'map' => { '0' => '0', '1' => '1', '9' => '@TODO' }, },
{ 'is_col' => 'symptoms_cough', 'cr_col' => 'elig_cough', 'trans' => 1, 'manually_reviewed' => '@TODO', 'map' => { '0' => '0', '1' => '1', '9' => '@TODO' }, },
{ 'is_col' => 'symptoms_dys_tachy_noea', 'cr_col' => 'elig_dyspnea', 'trans' => 1, 'manually_reviewed' => '@TODO', 'map' => { '0' => '0', '1' => '1', '9' => '@TODO' }, },
{ 'is_col' => 'symptoms_clinical_susp', 'cr_col' => 'elig_ari', 'trans' => 0, },
{ 'is_col' => 'sex', 'cr_col' => 'sex', 'trans' => 1, 'manually_reviewed' => 1, 'map' => { '0' => '1', '1' => '2' }, },
{ 'is_col' => 'age', 'cr_col' => '', 'trans' => 0, },
{ 'is_col' => 'ageu', 'cr_col' => '', 'trans' => 0, },
# ...
];
#12...........
},
'outdent.outdent2' => {
source => "outdent",
params => "outdent2",
expect => <<'#13...........',
my $i;
LOOP: while ( $i = ) {
chomp($i);
next unless $i;
fixit($i);
}
#13...........
},
'kpit.def' => {
source => "kpit",
params => "def",
expect => <<'#14...........',
if ( seek( DATA, 0, 0 ) ) { ... }
# The foreach keyword may be separated from the next opening paren
foreach $req (@bgQueue) {
...;
}
# This had trouble because a later padding operation removed the inside space
while ($CmdJob eq "" && @CmdQueue > 0 && $RunNightlyWhenIdle != 1
|| @CmdQueue > 0
&& $RunNightlyWhenIdle == 2
&& $bpc->isAdminJob( $CmdQueue[0]->{host} ) )
{
...;
}
#14...........
},
'kpit.kpit' => {
source => "kpit",
params => "kpit",
expect => <<'#15...........',
if ( seek(DATA, 0, 0) ) { ... }
# The foreach keyword may be separated from the next opening paren
foreach $req ( @bgQueue ) {
...;
}
# This had trouble because a later padding operation removed the inside space
while ( $CmdJob eq "" && @CmdQueue > 0 && $RunNightlyWhenIdle != 1
|| @CmdQueue > 0
&& $RunNightlyWhenIdle == 2
&& $bpc->isAdminJob($CmdQueue[0]->{host}) )
{
...;
}
#15...........
},
'kpitl.def' => {
source => "kpitl",
params => "def",
expect => <<'#16...........',
return ( $r**$n ) *
( pi**( $n / 2 ) ) /
(
sqrt(pi) *
factorial( 2 * ( int( $n / 2 ) ) + 2 ) /
factorial( int( $n / 2 ) + 1 ) /
( 4**( int( $n / 2 ) + 1 ) ) );
#16...........
},
'kpitl.kpitl' => {
source => "kpitl",
params => "kpitl",
expect => <<'#17...........',
return ( $r**$n ) *
(pi**($n / 2)) /
(
sqrt(pi) *
factorial( 2 * (int($n / 2)) + 2 ) /
factorial( int($n / 2) + 1 ) /
(4**(int($n / 2) + 1)));
#17...........
},
'hanging_side_comments3.def' => {
source => "hanging_side_comments3",
params => "def",
expect => <<'#18...........',
if ( $var eq 'wastebasket' ) { # this sends a pure block
# of hanging side comments
#to the vertical aligner.
#It caused a crash in
#a test version of
#sub 'delete_unmatched_tokens'
#...
#}
}
elsif ( $var eq 'spacecommand' ) {
&die("No $val function") unless eval "defined &$val";
}
#18...........
},
'lop.def' => {
source => "lop",
params => "def",
expect => <<'#19...........',
# logical padding examples
$same =
( ( $aP eq $bP )
&& ( $aS eq $bS )
&& ( $aT eq $bT )
&& ( $a->{'title'} eq $b->{'title'} )
&& ( $a->{'href'} eq $b->{'href'} ) );
$bits =
$top > 0xffff ? 32
: $top > 0xff ? 16
: $top > 1 ? 8
: 1;
lc( $self->mime_attr('content-type')
|| $self->{MIH_DefaultType}
|| 'text/plain' );
# Padding can also remove spaces; here the space after the '(' is lost:
elsif ($statement_type =~ /^sub\b/
|| $paren_type[$paren_depth] =~ /^sub\b/ )
#19...........
},
};
my $ntests = 0 + keys %{$rtests};
plan tests => $ntests;
}
###############
# EXECUTE TESTS
###############
foreach my $key ( sort keys %{$rtests} ) {
my $output;
my $sname = $rtests->{$key}->{source};
my $expect = $rtests->{$key}->{expect};
my $pname = $rtests->{$key}->{params};
my $source = $rsources->{$sname};
my $params = defined($pname) ? $rparams->{$pname} : "";
my $stderr_string;
my $errorfile_string;
my $err = Perl::Tidy::perltidy(
source => \$source,
destination => \$output,
perltidyrc => \$params,
argv => '', # for safety; hide any ARGV from perltidy
stderr => \$stderr_string,
errorfile => \$errorfile_string, # not used when -se flag is set
);
if ( $err || $stderr_string || $errorfile_string ) {
print STDERR "Error output received for test '$key'\n";
if ($err) {
print STDERR "An error flag '$err' was returned\n";
ok( !$err );
}
if ($stderr_string) {
print STDERR "---------------------\n";
print STDERR "<>\n$stderr_string\n";
print STDERR "---------------------\n";
ok( !$stderr_string );
}
if ($errorfile_string) {
print STDERR "---------------------\n";
print STDERR "<<.ERR file>>\n$errorfile_string\n";
print STDERR "---------------------\n";
ok( !$errorfile_string );
}
}
else {
if ( !is( $output, $expect, $key ) ) {
my $leno = length($output);
my $lene = length($expect);
if ( $leno == $lene ) {
print STDERR
"#> Test '$key' gave unexpected output. Strings differ but both have length $leno\n";
}
else {
print STDERR
"#> Test '$key' gave unexpected output. String lengths differ: output=$leno, expected=$lene\n";
}
}
}
}
Perl-Tidy-20210717/t/testsa.t 0000644 0001750 0001750 00000003371 12563477536 014607 0 ustar steve steve use strict;
use Test;
use Carp;
BEGIN {plan tests => 1}
use Perl::Tidy;
#----------------------------------------------------------------------
## test string->array
# Also tests flags -ce and -l=60
# Note that we have to use -npro to avoid using local .perltidyrc
#----------------------------------------------------------------------
my $source = <<'EOM';
$seqno = $type_sequence[$i];
if ($seqno) {
if (tok =~/[\(\[\{]/) {
$indentation{$seqno} = indentation
}
}
elsif (tok =~/[\)\]\}]/) {
$min_indentation = $indentation{$seqno};
delete $indentation{$seqno};
if ($indentation < $min_indentation) {$indentation = $min_indentation}
}
EOM
my @tidy_output;
Perl::Tidy::perltidy(
source => \$source,
destination => \@tidy_output,
perltidyrc => undef,
argv => '-nsyn -ce -npro -l=60',
);
my @expected_output=;
my $ok=1;
if (@expected_output == @tidy_output) {
while ( $_ = pop @tidy_output ) {
s/\s+$//;
my $expect = pop @expected_output;
$expect=~s/\s+$//;
if ( $expect ne $_ ) {
print STDERR "got:$_";
print STDERR "---\n";
print STDERR "expected_output:$expect";
$ok=0;
last;
}
}
}
else {
print STDERR "Line Counts differ\n";
$ok=0;
}
ok ($ok,1);
# This is the expected result of 'perltidy -ce -l=60' on the above string:
__DATA__
$seqno = $type_sequence[$i];
if ($seqno) {
if ( tok =~ /[\(\[\{]/ ) {
$indentation{$seqno} = indentation;
}
} elsif ( tok =~ /[\)\]\}]/ ) {
$min_indentation = $indentation{$seqno};
delete $indentation{$seqno};
if ( $indentation < $min_indentation ) {
$indentation = $min_indentation;
}
}
Perl-Tidy-20210717/t/snippets3.t 0000644 0001750 0001750 00000045301 14072572632 015221 0 ustar steve steve # Created with: ./make_t.pl
# Contents:
#1 ce_wn1.ce_wn
#2 ce_wn1.def
#3 colin.colin
#4 colin.def
#5 essential.def
#6 essential.essential1
#7 essential.essential2
#8 extrude1.def
#9 extrude1.extrude
#10 extrude2.def
#11 extrude2.extrude
#12 extrude3.def
#13 extrude3.extrude
#14 extrude4.def
#15 extrude4.extrude
#16 fabrice_bug.def
#17 fabrice_bug.fabrice_bug
#18 format1.def
#19 given1.def
#20 gnu1.def
# To locate test #13 you can search for its name or the string '#13'
use strict;
use Test::More;
use Carp;
use Perl::Tidy;
my $rparams;
my $rsources;
my $rtests;
BEGIN {
###########################################
# BEGIN SECTION 1: Parameter combinations #
###########################################
$rparams = {
'ce_wn' => <<'----------',
-cuddled-blocks
-wn
----------
'colin' => <<'----------',
-l=0
-pt=2
-nsfs
-sbt=2
-ohbr
-opr
-osbr
-pvt=2
-schb
-scp
-scsb
-sohb
-sop
-sosb
----------
'def' => "",
'essential1' => <<'----------',
-syn
-i=0
-l=100000
-nasc
-naws
-dws
-nanl
-blbp=0
-blbs=0
-nbbb
-kbl=0
-mbl=0
----------
'essential2' => "-extrude",
'extrude' => "--extrude",
'fabrice_bug' => "-bt=0",
};
############################
# BEGIN SECTION 2: Sources #
############################
$rsources = {
'ce_wn1' => <<'----------',
if ($BOLD_MATH) {
(
$labels, $comment,
join( '', ' < B > ', &make_math( $mode, '', '', $_ ), ' < /B>' )
)
}
else {
(
&process_math_in_latex( $mode, $math_style, $slevel, "\\mbox{$text}" ),
$after
)
}
----------
'colin' => <<'----------',
env(0, 15, 0, 10, {
Xtitle => 'X-data',
Ytitle => 'Y-data',
Title => 'An example of errb and points',
Font => 'Italic'
});
----------
'essential' => <<'----------',
# Run with mangle to squeeze out the white space
# also run with extrude
# never combine two bare words or numbers
status and ::ok(1);
return ::spw(...);
for bla::bla:: abc;
# do not combine 'overload::' and 'and'
if $self->{bareStringify} and ref $_
and defined %overload:: and defined &{'overload::StrVal'};
# do not combine 'SINK' and 'if'
my $size=-s::SINK if $file;
# do not combine to make $inputeq"quit"
if ($input eq"quit");
# do not combine a number with a concatenation dot to get a float '78.'
$vt100_compatible ? "\e[0;0H" : ('-' x 78 . "\n");
# do not join a minus with a bare word, because you might form
# a file test operator. Here "z-i" would be taken as a file test.
if (CORE::abs($z - i) < $eps);
# '= -' should not become =- or you will get a warning
# and something like these could become ambiguous without space
# after the '-':
use constant III=>1;
$a = $b - III;
$a = - III;
# keep a space between a token ending in '$' and any word;
die @$ if $@;
# avoid combining tokens to create new meanings. Example:
# this must not become $a++$b
$a+ +$b;
# another example: do not combine these two &'s:
allow_options & &OPT_EXECCGI;
# Perl is sensitive to whitespace after the + here:
$b = xvals $a + 0.1 * yvals $a;
# keep paren separate here:
use Foo::Bar ();
# need space after foreach my; for example, this will fail in
# older versions of Perl:
foreach my$ft(@filetypes)...
# must retain space between grep and left paren; "grep(" may fail
my $match = grep (m/^-extrude$/, @list) ? 1 : 0;
# don't stick numbers next to left parens, as in:
use Mail::Internet 1.28 ();
# 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);
----------
'extrude1' => <<'----------',
# do not break before the ++
print $x++ . "\n";
----------
'extrude2' => <<'----------',
if (-l pid_filename()) {
return readlink(pid_filename());
}
----------
'extrude3' => <<'----------',
# Breaking before a ++ can cause perl to guess wrong
print( ( $i++ & 1 ) ? $_ : ( $change{$_} || $_ ) );
# Space between '&' and 'O_ACCMODE' is essential here
$opts{rdonly} = (($opts{mode} & O_ACCMODE) == O_RDONLY);
----------
'extrude4' => <<'----------',
# From Safe.pm caused trouble with extrude
use Opcode 1.01, qw(
opset opset_to_ops opmask_add
empty_opset full_opset invert_opset verify_opset
opdesc opcodes opmask define_optag opset_to_hex
);
----------
'fabrice_bug' => <<'----------',
# no space around ^variable with -bt=0
my $before = ${^PREMATCH};
my $after = ${PREMATCH};
----------
'format1' => <<'----------',
if (/^--list$/o) {
format =
@<<<<<<<<<<<<<<<<<<<<<<<< @<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
$_, $val
.
print "Available strips:\n";
for ( split ( /\|/, $known_strips ) ) {
$val = $defs{$_}{'name'};
write;
}
}
----------
'given1' => <<'----------',
given ([9,"a",11]) {
when (qr/\d/) {
given ($count) {
when (1) { ok($count==1) }
else { ok($count!=1) }
when ([5,6]) { ok(0) } else { ok(1) }
}
}
ok(1) when 11;
}
----------
'gnu1' => <<'----------',
@common_sometimes = (
"aclocal.m4", "acconfig.h", "config.h.top", "config.h.bot",
"stamp-h.in", 'stamp-vti'
);
----------
};
####################################
# BEGIN SECTION 3: Expected output #
####################################
$rtests = {
'ce_wn1.ce_wn' => {
source => "ce_wn1",
params => "ce_wn",
expect => <<'#1...........',
if ($BOLD_MATH) { (
$labels, $comment,
join( '', ' < B > ', &make_math( $mode, '', '', $_ ), ' < /B>' )
) } else { (
&process_math_in_latex( $mode, $math_style, $slevel, "\\mbox{$text}" ),
$after
) }
#1...........
},
'ce_wn1.def' => {
source => "ce_wn1",
params => "def",
expect => <<'#2...........',
if ($BOLD_MATH) {
(
$labels, $comment,
join( '', ' < B > ', &make_math( $mode, '', '', $_ ), ' < /B>' )
)
}
else {
(
&process_math_in_latex( $mode, $math_style, $slevel, "\\mbox{$text}" ),
$after
)
}
#2...........
},
'colin.colin' => {
source => "colin",
params => "colin",
expect => <<'#3...........',
env(0, 15, 0, 10, {
Xtitle => 'X-data',
Ytitle => 'Y-data',
Title => 'An example of errb and points',
Font => 'Italic'
});
#3...........
},
'colin.def' => {
source => "colin",
params => "def",
expect => <<'#4...........',
env(
0, 15, 0, 10,
{
Xtitle => 'X-data',
Ytitle => 'Y-data',
Title => 'An example of errb and points',
Font => 'Italic'
}
);
#4...........
},
'essential.def' => {
source => "essential",
params => "def",
expect => <<'#5...........',
# Run with mangle to squeeze out the white space
# also run with extrude
# never combine two bare words or numbers
status and ::ok(1);
return ::spw(...);
for bla::bla:: abc;
# do not combine 'overload::' and 'and'
if $self->{bareStringify}
and ref $_
and defined %overload::
and defined &{'overload::StrVal'};
# do not combine 'SINK' and 'if'
my $size = -s ::SINK if $file;
# do not combine to make $inputeq"quit"
if ( $input eq "quit" );
# do not combine a number with a concatenation dot to get a float '78.'
$vt100_compatible ? "\e[0;0H" : ( '-' x 78 . "\n" );
# do not join a minus with a bare word, because you might form
# a file test operator. Here "z-i" would be taken as a file test.
if ( CORE::abs( $z - i ) < $eps );
# '= -' should not become =- or you will get a warning
# and something like these could become ambiguous without space
# after the '-':
use constant III => 1;
$a = $b - III;
$a = - III;
# keep a space between a token ending in '$' and any word;
die @$ if $@;
# avoid combining tokens to create new meanings. Example:
# this must not become $a++$b
$a + +$b;
# another example: do not combine these two &'s:
allow_options & &OPT_EXECCGI;
# Perl is sensitive to whitespace after the + here:
$b = xvals $a + 0.1 * yvals $a;
# keep paren separate here:
use Foo::Bar ();
# need space after foreach my; for example, this will fail in
# older versions of Perl:
foreach my $ft (@filetypes) ...
# must retain space between grep and left paren; "grep(" may fail
my $match = grep ( m/^-extrude$/, @list ) ? 1 : 0;
# don't stick numbers next to left parens, as in:
use Mail::Internet 1.28 ();
# 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 );
#5...........
},
'essential.essential1' => {
source => "essential",
params => "essential1",
expect => <<'#6...........',
# Run with mangle to squeeze out the white space
# also run with extrude
# never combine two bare words or numbers
status and ::ok(1);
return ::spw(...);
for bla::bla:: abc;
# do not combine 'overload::' and 'and'
if$self->{bareStringify}and ref$_ and defined%overload:: and defined&{'overload::StrVal'};
# do not combine 'SINK' and 'if'
my$size=-s::SINK if$file;
# do not combine to make $inputeq"quit"
if($input eq"quit");
# do not combine a number with a concatenation dot to get a float '78.'
$vt100_compatible?"\e[0;0H":('-' x 78 ."\n");
# do not join a minus with a bare word, because you might form
# a file test operator. Here "z-i" would be taken as a file test.
if(CORE::abs($z- i)<$eps);
# '= -' should not become =- or you will get a warning
# and something like these could become ambiguous without space
# after the '-':
use constant III=>1;
$a=$b- III;
$a=- III;
# keep a space between a token ending in '$' and any word;
die@$ if$@;
# avoid combining tokens to create new meanings. Example:
# this must not become $a++$b
$a+ +$b;
# another example: do not combine these two &'s:
allow_options& &OPT_EXECCGI;
# Perl is sensitive to whitespace after the + here:
$b=xvals$a + 0.1*yvals$a;
# keep paren separate here:
use Foo::Bar ();
# need space after foreach my; for example, this will fail in
# older versions of Perl:
foreach my$ft(@filetypes)...
# must retain space between grep and left paren; "grep(" may fail
my$match=grep (m/^-extrude$/,@list)?1:0;
# don't stick numbers next to left parens, as in:
use Mail::Internet 1.28 ();
# 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);
#6...........
},
'essential.essential2' => {
source => "essential",
params => "essential2",
expect => <<'#7...........',
# Run with mangle to squeeze out the white space
# also run with extrude
# never combine two bare words or numbers
status
and
::ok(
1
)
;
return
::spw(
...
)
;
for
bla::bla::
abc
;
# do not combine 'overload::' and 'and'
if
$self
->
{bareStringify}
and
ref
$_
and
defined
%overload::
and
defined
&{
'overload::StrVal'
}
;
# do not combine 'SINK' and 'if'
my$size
=
-s::SINK
if
$file
;
# do not combine to make $inputeq"quit"
if
(
$input
eq
"quit"
)
;
# do not combine a number with a concatenation dot to get a float '78.'
$vt100_compatible?
"\e[0;0H"
:
(
'-'
x
78
.
"\n"
)
;
# do not join a minus with a bare word, because you might form
# a file test operator. Here "z-i" would be taken as a file test.
if
(
CORE::abs
(
$z
-
i
)
<
$eps
)
;
# '= -' should not become =- or you will get a warning
# and something like these could become ambiguous without space
# after the '-':
use
constant
III=>
1
;
$a
=
$b
-
III
;
$a
=
-
III
;
# keep a space between a token ending in '$' and any word;
die
@$
if
$@
;
# avoid combining tokens to create new meanings. Example:
# this must not become $a++$b
$a
+
+
$b
;
# another example: do not combine these two &'s:
allow_options
&
&OPT_EXECCGI
;
# Perl is sensitive to whitespace after the + here:
$b
=
xvals$a
+
0.1
*
yvals$a;
# keep paren separate here:
use
Foo::Bar (
)
;
# need space after foreach my; for example, this will fail in
# older versions of Perl:
foreach
my$ft
(
@filetypes
)
...
# must retain space between grep and left paren; "grep(" may fail
my$match
=
grep
(
m/^-extrude$/
,
@list
)
?
1
:
0
;
# don't stick numbers next to left parens, as in:
use
Mail::Internet
1.28
(
)
;
# 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
)
;
#7...........
},
'extrude1.def' => {
source => "extrude1",
params => "def",
expect => <<'#8...........',
# do not break before the ++
print $x++ . "\n";
#8...........
},
'extrude1.extrude' => {
source => "extrude1",
params => "extrude",
expect => <<'#9...........',
# do not break before the ++
print$x++
.
"\n"
;
#9...........
},
'extrude2.def' => {
source => "extrude2",
params => "def",
expect => <<'#10...........',
if ( -l pid_filename() ) {
return readlink( pid_filename() );
}
#10...........
},
'extrude2.extrude' => {
source => "extrude2",
params => "extrude",
expect => <<'#11...........',
if
(
-l pid_filename(
)
)
{
return
readlink
(
pid_filename(
)
)
;
}
#11...........
},
'extrude3.def' => {
source => "extrude3",
params => "def",
expect => <<'#12...........',
# Breaking before a ++ can cause perl to guess wrong
print( ( $i++ & 1 ) ? $_ : ( $change{$_} || $_ ) );
# Space between '&' and 'O_ACCMODE' is essential here
$opts{rdonly} = ( ( $opts{mode} & O_ACCMODE ) == O_RDONLY );
#12...........
},
'extrude3.extrude' => {
source => "extrude3",
params => "extrude",
expect => <<'#13...........',
# Breaking before a ++ can cause perl to guess wrong
print
(
(
$i++
&
1
)
?
$_
:
(
$change{
$_
}
||
$_
)
)
;
# Space between '&' and 'O_ACCMODE' is essential here
$opts{rdonly}
=
(
(
$opts{mode}
&
O_ACCMODE
)
==
O_RDONLY
)
;
#13...........
},
'extrude4.def' => {
source => "extrude4",
params => "def",
expect => <<'#14...........',
# From Safe.pm caused trouble with extrude
use Opcode 1.01, qw(
opset opset_to_ops opmask_add
empty_opset full_opset invert_opset verify_opset
opdesc opcodes opmask define_optag opset_to_hex
);
#14...........
},
'extrude4.extrude' => {
source => "extrude4",
params => "extrude",
expect => <<'#15...........',
# From Safe.pm caused trouble with extrude
use
Opcode
1.01
,
qw(
opset opset_to_ops opmask_add
empty_opset full_opset invert_opset verify_opset
opdesc opcodes opmask define_optag opset_to_hex
)
;
#15...........
},
'fabrice_bug.def' => {
source => "fabrice_bug",
params => "def",
expect => <<'#16...........',
# no space around ^variable with -bt=0
my $before = ${^PREMATCH};
my $after = ${PREMATCH};
#16...........
},
'fabrice_bug.fabrice_bug' => {
source => "fabrice_bug",
params => "fabrice_bug",
expect => <<'#17...........',
# no space around ^variable with -bt=0
my $before = ${^PREMATCH};
my $after = ${ PREMATCH };
#17...........
},
'format1.def' => {
source => "format1",
params => "def",
expect => <<'#18...........',
if (/^--list$/o) {
format =
@<<<<<<<<<<<<<<<<<<<<<<<< @<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
$_, $val
.
print "Available strips:\n";
for ( split( /\|/, $known_strips ) ) {
$val = $defs{$_}{'name'};
write;
}
}
#18...........
},
'given1.def' => {
source => "given1",
params => "def",
expect => <<'#19...........',
given ( [ 9, "a", 11 ] ) {
when (qr/\d/) {
given ($count) {
when (1) { ok( $count == 1 ) }
else { ok( $count != 1 ) }
when ( [ 5, 6 ] ) { ok(0) }
else { ok(1) }
}
}
ok(1) when 11;
}
#19...........
},
'gnu1.def' => {
source => "gnu1",
params => "def",
expect => <<'#20...........',
@common_sometimes = (
"aclocal.m4", "acconfig.h", "config.h.top", "config.h.bot",
"stamp-h.in", 'stamp-vti'
);
#20...........
},
};
my $ntests = 0 + keys %{$rtests};
plan tests => $ntests;
}
###############
# EXECUTE TESTS
###############
foreach my $key ( sort keys %{$rtests} ) {
my $output;
my $sname = $rtests->{$key}->{source};
my $expect = $rtests->{$key}->{expect};
my $pname = $rtests->{$key}->{params};
my $source = $rsources->{$sname};
my $params = defined($pname) ? $rparams->{$pname} : "";
my $stderr_string;
my $errorfile_string;
my $err = Perl::Tidy::perltidy(
source => \$source,
destination => \$output,
perltidyrc => \$params,
argv => '', # for safety; hide any ARGV from perltidy
stderr => \$stderr_string,
errorfile => \$errorfile_string, # not used when -se flag is set
);
if ( $err || $stderr_string || $errorfile_string ) {
print STDERR "Error output received for test '$key'\n";
if ($err) {
print STDERR "An error flag '$err' was returned\n";
ok( !$err );
}
if ($stderr_string) {
print STDERR "---------------------\n";
print STDERR "<>\n$stderr_string\n";
print STDERR "---------------------\n";
ok( !$stderr_string );
}
if ($errorfile_string) {
print STDERR "---------------------\n";
print STDERR "<<.ERR file>>\n$errorfile_string\n";
print STDERR "---------------------\n";
ok( !$errorfile_string );
}
}
else {
if ( !is( $output, $expect, $key ) ) {
my $leno = length($output);
my $lene = length($expect);
if ( $leno == $lene ) {
print STDERR
"#> Test '$key' gave unexpected output. Strings differ but both have length $leno\n";
}
else {
print STDERR
"#> Test '$key' gave unexpected output. String lengths differ: output=$leno, expected=$lene\n";
}
}
}
}
Perl-Tidy-20210717/t/snippets2.t 0000644 0001750 0001750 00000032314 14072572631 015217 0 ustar steve steve # Created with: ./make_t.pl
# Contents:
#1 angle.def
#2 arrows1.def
#3 arrows2.def
#4 attrib1.def
#5 attrib2.def
#6 attrib3.def
#7 bar1.bar
#8 bar1.def
#9 block1.def
#10 boc1.boc
#11 boc1.def
#12 boc2.boc
#13 boc2.def
#14 break1.def
#15 break2.def
#16 break3.def
#17 break4.def
#18 carat.def
#19 ce1.ce
#20 ce1.def
# To locate test #13 you can search for its name or the string '#13'
use strict;
use Test::More;
use Carp;
use Perl::Tidy;
my $rparams;
my $rsources;
my $rtests;
BEGIN {
###########################################
# BEGIN SECTION 1: Parameter combinations #
###########################################
$rparams = {
'bar' => "-bar",
'boc' => "-boc",
'ce' => "-cuddled-blocks",
'def' => "",
};
############################
# BEGIN SECTION 2: Sources #
############################
$rsources = {
'angle' => <<'----------',
# This is an angle operator:
@message_list =sort sort_algorithm < INDEX_FILE >;# angle operator
# Not an angle operator:
# Patched added in guess routine for this case:
if ( VERSION < 5.009 && $op->name eq 'aassign' ) {
}
----------
'arrows1' => <<'----------',
# remove spaces around arrows
my $obj = Bio::Variation::AAChange -> new;
my $termcap = Term::Cap -> Tgetent( { TERM => undef } );
----------
'arrows2' => <<'----------',
$_[ 0]-> Blue -> backColor(( $_[ 0]-> Blue -> backColor == cl::Blue ) ? cl::LightBlue : cl::Blue );
----------
'attrib1' => <<'----------',
sub be_careful () : locked method {
my $self = shift;
# ...
}
----------
'attrib2' => <<'----------',
sub
witch
() # prototype may be on new line, but cannot put line break within prototype
:
locked
{
print "and your little dog ";
}
----------
'attrib3' => <<'----------',
package Canine;
package Dog;
my Canine $spot : Watchful ;
package Felis;
my $cat : Nervous;
package X;
sub foo : locked ;
package X;
sub Y::x : locked { 1 }
package X;
sub foo { 1 }
package Y;
BEGIN { *bar = \&X::foo; }
package Z;
sub Y::bar : locked ;
----------
'bar1' => <<'----------',
if ($bigwasteofspace1 && $bigwasteofspace2 || $bigwasteofspace3 && $bigwasteofspace4) { }
----------
'block1' => <<'----------',
# Some block tests
print "start main running\n";
die "main now dying\n";
END {$a=6; print "1st end, a=$a\n"}
CHECK {$a=8; print "1st check, a=$a\n"}
INIT {$a=10; print "1st init, a=$a\n"}
END {$a=12; print "2nd end, a=$a\n"}
BEGIN {$a=14; print "1st begin, a=$a\n"}
INIT {$a=16; print "2nd init, a=$a\n"}
BEGIN {$a=18; print "2nd begin, a=$a\n"}
CHECK {$a=20; print "2nd check, a=$a\n"}
END {$a=23; print "3rd end, a=$a\n"}
----------
'boc1' => <<'----------',
# RT#98902
# Running with -boc (break-at-old-comma-breakpoints) should not
# allow forming a single line
my @bar = map { {
number => $_,
character => chr $_,
padding => (' ' x $_),
} } ( 0 .. 32 );
----------
'boc2' => <<'----------',
my @list = (
1,
1, 1,
1, 2, 1,
1, 3, 3, 1,
1, 4, 6, 4, 1,);
----------
'break1' => <<'----------',
# break at ;
$self->__print("*** Type 'p' now to show start up log\n") ; # XXX add to banner?
----------
'break2' => <<'----------',
# break before the '->'
( $current_feature_item->children )[0]->set( $current_feature->primary_tag );
$sth->{'Database'}->{'xbase_tables'}->{ $parsed_sql->{'table'}[0] }->field_type($_);
----------
'break3' => <<'----------',
# keep the anonymous hash block together:
my $red_color = $widget->window->get_colormap->color_alloc( { red => 65000, green => 0, blue => 0 } );
----------
'break4' => <<'----------',
spawn( "$LINTIAN_ROOT/unpack/list-binpkg", "$LINTIAN_LAB/info/binary-packages", $v ) == 0 or fail("cannot create binary package list");
----------
'carat' => <<'----------',
my $a=${^WARNING_BITS};
@{^HOWDY_PARDNER}=(101,102);
${^W} = 1;
$bb[$^]] = "bubba";
----------
'ce1' => <<'----------',
# test -ce with blank lines and comments between blocks
if($value[0] =~ /^(\#)/){ # skip any comment line
last SWITCH;
}
elsif($value[0] =~ /^(o)$/ or $value[0] =~ /^(os)$/){
$os=$value[1];
last SWITCH;
}
elsif($value[0] =~ /^(b)$/ or $value[0] =~ /^(dbfile)$/)
# comment
{
$dbfile=$value[1];
last SWITCH;
# Add the additional site
}else{
$rebase_hash{$name} .= " $site";
}
----------
};
####################################
# BEGIN SECTION 3: Expected output #
####################################
$rtests = {
'angle.def' => {
source => "angle",
params => "def",
expect => <<'#1...........',
# This is an angle operator:
@message_list = sort sort_algorithm < INDEX_FILE >; # angle operator
# Not an angle operator:
# Patched added in guess routine for this case:
if ( VERSION < 5.009 && $op->name eq 'aassign' ) {
}
#1...........
},
'arrows1.def' => {
source => "arrows1",
params => "def",
expect => <<'#2...........',
# remove spaces around arrows
my $obj = Bio::Variation::AAChange->new;
my $termcap = Term::Cap->Tgetent( { TERM => undef } );
#2...........
},
'arrows2.def' => {
source => "arrows2",
params => "def",
expect => <<'#3...........',
$_[0]->Blue->backColor(
( $_[0]->Blue->backColor == cl::Blue ) ? cl::LightBlue : cl::Blue );
#3...........
},
'attrib1.def' => {
source => "attrib1",
params => "def",
expect => <<'#4...........',
sub be_careful () : locked method {
my $self = shift;
# ...
}
#4...........
},
'attrib2.def' => {
source => "attrib2",
params => "def",
expect => <<'#5...........',
sub witch
() # prototype may be on new line, but cannot put line break within prototype
: locked {
print "and your little dog ";
}
#5...........
},
'attrib3.def' => {
source => "attrib3",
params => "def",
expect => <<'#6...........',
package Canine;
package Dog;
my Canine $spot : Watchful;
package Felis;
my $cat : Nervous;
package X;
sub foo : locked;
package X;
sub Y::x : locked { 1 }
package X;
sub foo { 1 }
package Y;
BEGIN { *bar = \&X::foo; }
package Z;
sub Y::bar : locked;
#6...........
},
'bar1.bar' => {
source => "bar1",
params => "bar",
expect => <<'#7...........',
if ( $bigwasteofspace1 && $bigwasteofspace2
|| $bigwasteofspace3 && $bigwasteofspace4 ) {
}
#7...........
},
'bar1.def' => {
source => "bar1",
params => "def",
expect => <<'#8...........',
if ( $bigwasteofspace1 && $bigwasteofspace2
|| $bigwasteofspace3 && $bigwasteofspace4 )
{
}
#8...........
},
'block1.def' => {
source => "block1",
params => "def",
expect => <<'#9...........',
# Some block tests
print "start main running\n";
die "main now dying\n";
END { $a = 6; print "1st end, a=$a\n" }
CHECK { $a = 8; print "1st check, a=$a\n" }
INIT { $a = 10; print "1st init, a=$a\n" }
END { $a = 12; print "2nd end, a=$a\n" }
BEGIN { $a = 14; print "1st begin, a=$a\n" }
INIT { $a = 16; print "2nd init, a=$a\n" }
BEGIN { $a = 18; print "2nd begin, a=$a\n" }
CHECK { $a = 20; print "2nd check, a=$a\n" }
END { $a = 23; print "3rd end, a=$a\n" }
#9...........
},
'boc1.boc' => {
source => "boc1",
params => "boc",
expect => <<'#10...........',
# RT#98902
# Running with -boc (break-at-old-comma-breakpoints) should not
# allow forming a single line
my @bar = map {
{
number => $_,
character => chr $_,
padding => ( ' ' x $_ ),
}
} ( 0 .. 32 );
#10...........
},
'boc1.def' => {
source => "boc1",
params => "def",
expect => <<'#11...........',
# RT#98902
# Running with -boc (break-at-old-comma-breakpoints) should not
# allow forming a single line
my @bar =
map { { number => $_, character => chr $_, padding => ( ' ' x $_ ), } }
( 0 .. 32 );
#11...........
},
'boc2.boc' => {
source => "boc2",
params => "boc",
expect => <<'#12...........',
my @list = (
1,
1, 1,
1, 2, 1,
1, 3, 3, 1,
1, 4, 6, 4, 1,
);
#12...........
},
'boc2.def' => {
source => "boc2",
params => "def",
expect => <<'#13...........',
my @list = ( 1, 1, 1, 1, 2, 1, 1, 3, 3, 1, 1, 4, 6, 4, 1, );
#13...........
},
'break1.def' => {
source => "break1",
params => "def",
expect => <<'#14...........',
# break at ;
$self->__print("*** Type 'p' now to show start up log\n")
; # XXX add to banner?
#14...........
},
'break2.def' => {
source => "break2",
params => "def",
expect => <<'#15...........',
# break before the '->'
( $current_feature_item->children )[0]
->set( $current_feature->primary_tag );
$sth->{'Database'}->{'xbase_tables'}->{ $parsed_sql->{'table'}[0] }
->field_type($_);
#15...........
},
'break3.def' => {
source => "break3",
params => "def",
expect => <<'#16...........',
# keep the anonymous hash block together:
my $red_color = $widget->window->get_colormap->color_alloc(
{ red => 65000, green => 0, blue => 0 } );
#16...........
},
'break4.def' => {
source => "break4",
params => "def",
expect => <<'#17...........',
spawn( "$LINTIAN_ROOT/unpack/list-binpkg",
"$LINTIAN_LAB/info/binary-packages", $v ) == 0
or fail("cannot create binary package list");
#17...........
},
'carat.def' => {
source => "carat",
params => "def",
expect => <<'#18...........',
my $a = ${^WARNING_BITS};
@{^HOWDY_PARDNER} = ( 101, 102 );
${^W} = 1;
$bb[$^]] = "bubba";
#18...........
},
'ce1.ce' => {
source => "ce1",
params => "ce",
expect => <<'#19...........',
# test -ce with blank lines and comments between blocks
if ( $value[0] =~ /^(\#)/ ) { # skip any comment line
last SWITCH;
} elsif ( $value[0] =~ /^(o)$/ or $value[0] =~ /^(os)$/ ) {
$os = $value[1];
last SWITCH;
} elsif ( $value[0] =~ /^(b)$/ or $value[0] =~ /^(dbfile)$/ )
# comment
{
$dbfile = $value[1];
last SWITCH;
# Add the additional site
} else {
$rebase_hash{$name} .= " $site";
}
#19...........
},
'ce1.def' => {
source => "ce1",
params => "def",
expect => <<'#20...........',
# test -ce with blank lines and comments between blocks
if ( $value[0] =~ /^(\#)/ ) { # skip any comment line
last SWITCH;
}
elsif ( $value[0] =~ /^(o)$/ or $value[0] =~ /^(os)$/ ) {
$os = $value[1];
last SWITCH;
}
elsif ( $value[0] =~ /^(b)$/ or $value[0] =~ /^(dbfile)$/ )
# comment
{
$dbfile = $value[1];
last SWITCH;
# Add the additional site
}
else {
$rebase_hash{$name} .= " $site";
}
#20...........
},
};
my $ntests = 0 + keys %{$rtests};
plan tests => $ntests;
}
###############
# EXECUTE TESTS
###############
foreach my $key ( sort keys %{$rtests} ) {
my $output;
my $sname = $rtests->{$key}->{source};
my $expect = $rtests->{$key}->{expect};
my $pname = $rtests->{$key}->{params};
my $source = $rsources->{$sname};
my $params = defined($pname) ? $rparams->{$pname} : "";
my $stderr_string;
my $errorfile_string;
my $err = Perl::Tidy::perltidy(
source => \$source,
destination => \$output,
perltidyrc => \$params,
argv => '', # for safety; hide any ARGV from perltidy
stderr => \$stderr_string,
errorfile => \$errorfile_string, # not used when -se flag is set
);
if ( $err || $stderr_string || $errorfile_string ) {
print STDERR "Error output received for test '$key'\n";
if ($err) {
print STDERR "An error flag '$err' was returned\n";
ok( !$err );
}
if ($stderr_string) {
print STDERR "---------------------\n";
print STDERR "<>\n$stderr_string\n";
print STDERR "---------------------\n";
ok( !$stderr_string );
}
if ($errorfile_string) {
print STDERR "---------------------\n";
print STDERR "<<.ERR file>>\n$errorfile_string\n";
print STDERR "---------------------\n";
ok( !$errorfile_string );
}
}
else {
if ( !is( $output, $expect, $key ) ) {
my $leno = length($output);
my $lene = length($expect);
if ( $leno == $lene ) {
print STDERR
"#> Test '$key' gave unexpected output. Strings differ but both have length $leno\n";
}
else {
print STDERR
"#> Test '$key' gave unexpected output. String lengths differ: output=$leno, expected=$lene\n";
}
}
}
}
Perl-Tidy-20210717/t/snippets6.t 0000644 0001750 0001750 00000030421 14072572632 015221 0 ustar steve steve # Created with: ./make_t.pl
# Contents:
#1 otr1.otr
#2 pbp1.def
#3 pbp1.pbp
#4 pbp2.def
#5 pbp2.pbp
#6 pbp3.def
#7 pbp3.pbp
#8 pbp4.def
#9 pbp4.pbp
#10 pbp5.def
#11 pbp5.pbp
#12 print1.def
#13 q1.def
#14 q2.def
#15 recombine1.def
#16 recombine2.def
#17 recombine3.def
#18 recombine4.def
#19 rt101547.def
#20 rt102371.def
# To locate test #13 you can search for its name or the string '#13'
use strict;
use Test::More;
use Carp;
use Perl::Tidy;
my $rparams;
my $rsources;
my $rtests;
BEGIN {
###########################################
# BEGIN SECTION 1: Parameter combinations #
###########################################
$rparams = {
'def' => "",
'otr' => <<'----------',
-ohbr
-opr
-osbr
----------
'pbp' => "-pbp -nst -nse",
};
############################
# BEGIN SECTION 2: Sources #
############################
$rsources = {
'otr1' => <<'----------',
return $pdl->slice(
join ',',
(
map {
$_ eq "X" ? ":"
: ref $_ eq "ARRAY" ? join ':', @$_
: !ref $_ ? $_
: die "INVALID SLICE DEF $_"
} @_
)
);
----------
'pbp1' => <<'----------',
# break after '+' if default, before + if pbp
my $min_gnu_indentation = $standard_increment +
$gnu_stack[$max_gnu_stack_index]->get_SPACES();
----------
'pbp2' => <<'----------',
$tmp = $day - 32075 + 1461 * ( $year + 4800 - ( 14 - $month ) / 12 ) / 4 + 367 * ( $month - 2 + ( ( 14 - $month ) / 12 ) * 12 ) / 12 - 3 * ( ( $year + 4900 - ( 14 - $month ) / 12 ) / 100 ) / 4;
----------
'pbp3' => <<'----------',
return $sec + $SecOff + ( SECS_PER_MINUTE * $min ) + ( SECS_PER_HOUR * $hour ) + ( SECS_PER_DAY * $days );
----------
'pbp4' => <<'----------',
# with defaults perltidy will break after the '=' here
my @host_seq = $level eq "easy" ?
@reordered : 0..$last; # reordered has CDROM up front
----------
'pbp5' => <<'----------',
# illustates problem with -pbp: -ci should not equal -i
say 'ok_200_24_hours.value '.average({'$and'=>[{time=>{'$gt',$time-60*60*24}},{status=>200}]});
----------
'print1' => <<'----------',
# same text twice. Has uncontained commas; -- leave as is
print "conformability (Not the same dimension)\n",
"\t",
$have, " is ",
text_unit($hu), "\n", "\t", $want, " is ", text_unit($wu), "\n",;
print
"conformability (Not the same dimension)\n",
"\t", $have, " is ", text_unit($hu), "\n",
"\t", $want, " is ", text_unit($wu), "\n",
;
----------
'q1' => <<'----------',
print qq(You are in zone $thisTZ
Difference with respect to GMT is ), $offset / 3600, qq( hours
And local time is $hour hours $min minutes $sec seconds
);
----------
'q2' => <<'----------',
$a=qq
XHello World\nX;
print "$a";
----------
'recombine1' => <<'----------',
# recombine '= [' here:
$retarray =
[ &{ $sth->{'xbase_parsed_sql'}{'selectfn'} }
( $xbase, $values, $sth->{'xbase_bind_values'} ) ]
if defined $values;
----------
'recombine2' => <<'----------',
# recombine = unless old break there
$a = [ length( $self->{fb}[-1] ), $#{ $self->{fb} } ] ; # set cursor at end of buffer and print this cursor
----------
'recombine3' => <<'----------',
# recombine final line
$command = (
($catpage =~ m:\.gz:)
? $ZCAT
: $CAT
)
. " < $catpage";
----------
'recombine4' => <<'----------',
# do not recombine into two lines after a comma if
# the term is complex (has parens) or changes level
$delta_time = sprintf "%.4f", ( ( $done[0] + ( $done[1] / 1e6 ) ) - ( $start[0] + ( $start[1] / 1e6 ) ) );
----------
'rt101547' => <<'----------',
{ source_host => MM::Config->instance->host // q{}, }
----------
'rt102371' => <<'----------',
state $b //= ccc();
----------
};
####################################
# BEGIN SECTION 3: Expected output #
####################################
$rtests = {
'otr1.otr' => {
source => "otr1",
params => "otr",
expect => <<'#1...........',
return $pdl->slice(
join ',', (
map {
$_ eq "X" ? ":"
: ref $_ eq "ARRAY" ? join ':', @$_
: !ref $_ ? $_
: die "INVALID SLICE DEF $_"
} @_
)
);
#1...........
},
'pbp1.def' => {
source => "pbp1",
params => "def",
expect => <<'#2...........',
# break after '+' if default, before + if pbp
my $min_gnu_indentation = $standard_increment +
$gnu_stack[$max_gnu_stack_index]->get_SPACES();
#2...........
},
'pbp1.pbp' => {
source => "pbp1",
params => "pbp",
expect => <<'#3...........',
# break after '+' if default, before + if pbp
my $min_gnu_indentation = $standard_increment
+ $gnu_stack[$max_gnu_stack_index]->get_SPACES();
#3...........
},
'pbp2.def' => {
source => "pbp2",
params => "def",
expect => <<'#4...........',
$tmp =
$day - 32075 +
1461 * ( $year + 4800 - ( 14 - $month ) / 12 ) / 4 +
367 * ( $month - 2 + ( ( 14 - $month ) / 12 ) * 12 ) / 12 -
3 * ( ( $year + 4900 - ( 14 - $month ) / 12 ) / 100 ) / 4;
#4...........
},
'pbp2.pbp' => {
source => "pbp2",
params => "pbp",
expect => <<'#5...........',
$tmp
= $day - 32075
+ 1461 * ( $year + 4800 - ( 14 - $month ) / 12 ) / 4
+ 367 * ( $month - 2 + ( ( 14 - $month ) / 12 ) * 12 ) / 12
- 3 * ( ( $year + 4900 - ( 14 - $month ) / 12 ) / 100 ) / 4;
#5...........
},
'pbp3.def' => {
source => "pbp3",
params => "def",
expect => <<'#6...........',
return $sec + $SecOff +
( SECS_PER_MINUTE * $min ) +
( SECS_PER_HOUR * $hour ) +
( SECS_PER_DAY * $days );
#6...........
},
'pbp3.pbp' => {
source => "pbp3",
params => "pbp",
expect => <<'#7...........',
return
$sec + $SecOff
+ ( SECS_PER_MINUTE * $min )
+ ( SECS_PER_HOUR * $hour )
+ ( SECS_PER_DAY * $days );
#7...........
},
'pbp4.def' => {
source => "pbp4",
params => "def",
expect => <<'#8...........',
# with defaults perltidy will break after the '=' here
my @host_seq =
$level eq "easy" ? @reordered : 0 .. $last; # reordered has CDROM up front
#8...........
},
'pbp4.pbp' => {
source => "pbp4",
params => "pbp",
expect => <<'#9...........',
# with defaults perltidy will break after the '=' here
my @host_seq
= $level eq "easy"
? @reordered
: 0 .. $last; # reordered has CDROM up front
#9...........
},
'pbp5.def' => {
source => "pbp5",
params => "def",
expect => <<'#10...........',
# illustates problem with -pbp: -ci should not equal -i
say 'ok_200_24_hours.value '
. average(
{
'$and' =>
[ { time => { '$gt', $time - 60 * 60 * 24 } }, { status => 200 } ]
}
);
#10...........
},
'pbp5.pbp' => {
source => "pbp5",
params => "pbp",
expect => <<'#11...........',
# illustates problem with -pbp: -ci should not equal -i
say 'ok_200_24_hours.value '
. average(
{ '$and' => [
{ time => { '$gt', $time - 60 * 60 * 24 } }, { status => 200 }
]
}
);
#11...........
},
'print1.def' => {
source => "print1",
params => "def",
expect => <<'#12...........',
# same text twice. Has uncontained commas; -- leave as is
print "conformability (Not the same dimension)\n",
"\t",
$have, " is ",
text_unit($hu), "\n", "\t", $want, " is ", text_unit($wu), "\n",;
print
"conformability (Not the same dimension)\n",
"\t", $have, " is ", text_unit($hu), "\n",
"\t", $want, " is ", text_unit($wu), "\n",
;
#12...........
},
'q1.def' => {
source => "q1",
params => "def",
expect => <<'#13...........',
print qq(You are in zone $thisTZ
Difference with respect to GMT is ), $offset / 3600, qq( hours
And local time is $hour hours $min minutes $sec seconds
);
#13...........
},
'q2.def' => {
source => "q2",
params => "def",
expect => <<'#14...........',
$a = qq
XHello World\nX;
print "$a";
#14...........
},
'recombine1.def' => {
source => "recombine1",
params => "def",
expect => <<'#15...........',
# recombine '= [' here:
$retarray =
[ &{ $sth->{'xbase_parsed_sql'}{'selectfn'} }
( $xbase, $values, $sth->{'xbase_bind_values'} ) ]
if defined $values;
#15...........
},
'recombine2.def' => {
source => "recombine2",
params => "def",
expect => <<'#16...........',
# recombine = unless old break there
$a = [ length( $self->{fb}[-1] ), $#{ $self->{fb} } ]
; # set cursor at end of buffer and print this cursor
#16...........
},
'recombine3.def' => {
source => "recombine3",
params => "def",
expect => <<'#17...........',
# recombine final line
$command = (
( $catpage =~ m:\.gz: )
? $ZCAT
: $CAT
) . " < $catpage";
#17...........
},
'recombine4.def' => {
source => "recombine4",
params => "def",
expect => <<'#18...........',
# do not recombine into two lines after a comma if
# the term is complex (has parens) or changes level
$delta_time = sprintf "%.4f",
( ( $done[0] + ( $done[1] / 1e6 ) ) -
( $start[0] + ( $start[1] / 1e6 ) ) );
#18...........
},
'rt101547.def' => {
source => "rt101547",
params => "def",
expect => <<'#19...........',
{ source_host => MM::Config->instance->host // q{}, }
#19...........
},
'rt102371.def' => {
source => "rt102371",
params => "def",
expect => <<'#20...........',
state $b //= ccc();
#20...........
},
};
my $ntests = 0 + keys %{$rtests};
plan tests => $ntests;
}
###############
# EXECUTE TESTS
###############
foreach my $key ( sort keys %{$rtests} ) {
my $output;
my $sname = $rtests->{$key}->{source};
my $expect = $rtests->{$key}->{expect};
my $pname = $rtests->{$key}->{params};
my $source = $rsources->{$sname};
my $params = defined($pname) ? $rparams->{$pname} : "";
my $stderr_string;
my $errorfile_string;
my $err = Perl::Tidy::perltidy(
source => \$source,
destination => \$output,
perltidyrc => \$params,
argv => '', # for safety; hide any ARGV from perltidy
stderr => \$stderr_string,
errorfile => \$errorfile_string, # not used when -se flag is set
);
if ( $err || $stderr_string || $errorfile_string ) {
print STDERR "Error output received for test '$key'\n";
if ($err) {
print STDERR "An error flag '$err' was returned\n";
ok( !$err );
}
if ($stderr_string) {
print STDERR "---------------------\n";
print STDERR "<>\n$stderr_string\n";
print STDERR "---------------------\n";
ok( !$stderr_string );
}
if ($errorfile_string) {
print STDERR "---------------------\n";
print STDERR "<<.ERR file>>\n$errorfile_string\n";
print STDERR "---------------------\n";
ok( !$errorfile_string );
}
}
else {
if ( !is( $output, $expect, $key ) ) {
my $leno = length($output);
my $lene = length($expect);
if ( $leno == $lene ) {
print STDERR
"#> Test '$key' gave unexpected output. Strings differ but both have length $leno\n";
}
else {
print STDERR
"#> Test '$key' gave unexpected output. String lengths differ: output=$leno, expected=$lene\n";
}
}
}
}
Perl-Tidy-20210717/t/testss.t 0000644 0001750 0001750 00000002621 10441455207 014606 0 ustar steve steve use strict;
use Test;
use Carp;
BEGIN {plan tests => 1}
use Perl::Tidy;
#----------------------------------------------------------------------
## test string->string
#----------------------------------------------------------------------
my $source = <<'EOM';
%height=("letter",27.9, "legal",35.6, "arche",121.9, "archd",91.4, "archc",61,
"archb",45.7, "archa",30.5, "flsa",33, "flse",33, "halfletter",21.6,
"11x17",43.2, "ledger",27.9);
%width=("letter",21.6, "legal",21.6, "arche",91.4, "archd",61, "archc",45.7,
"archb",30.5, "archa",22.9, "flsa",21.6, "flse",21.6, "halfletter",14,
"11x17",27.9, "ledger",43.2);
EOM
my $perltidyrc = <<'EOM';
-gnu
EOM
my $output;
Perl::Tidy::perltidy(
source => \$source,
destination => \$output,
perltidyrc => \$perltidyrc,
argv => '-nsyn',
);
my $expected_output=<<'EOM';
%height = (
"letter", 27.9, "legal", 35.6, "arche", 121.9,
"archd", 91.4, "archc", 61, "archb", 45.7,
"archa", 30.5, "flsa", 33, "flse", 33,
"halfletter", 21.6, "11x17", 43.2, "ledger", 27.9
);
%width = (
"letter", 21.6, "legal", 21.6, "arche", 91.4,
"archd", 61, "archc", 45.7, "archb", 30.5,
"archa", 22.9, "flsa", 21.6, "flse", 21.6,
"halfletter", 14, "11x17", 27.9, "ledger", 43.2
);
EOM
ok($output, $expected_output);
Perl-Tidy-20210717/t/atee.t 0000644 0001750 0001750 00000004220 13653026577 014210 0 ustar steve steve use strict;
use Test;
use Carp;
use Perl::Tidy;
BEGIN {
plan tests => 2;
}
my $sname = 'atee.t';
my $source = <<'EOM';
# block comment
=pod
some pod
=cut
print "hello world\n";
$xx++; # side comment
EOM
my $expect = <<'EOM';
print "hello world\n";
$xx++;
EOM
my $teefile_expect = <<'EOM';
# block comment
=pod
some pod
=cut
$xx++; # side comment
EOM
# Test capturing the .LOG, .DEBUG, .TEE outputs to strings.
# In this test we delete all comments and pod in the test script and send them
# to a .TEE file also save .DEBUG and .LOG output
my $params = "-dac -tac -D -g";
# Verify correctness of the formatted output and the .TEE output
# (.DEBUG and .LOG have been verified to work but are not checked here because
# they may change over time, making work for maintaining this test file)
my $output;
my $teefile;
my $debugfile;
my $stderr_string;
my $errorfile_string;
my $logfile_string;
my $debugfile_string;
my $err = Perl::Tidy::perltidy(
source => \$source,
destination => \$output,
perltidyrc => \$params,
argv => '', # for safety; hide any ARGV from perltidy
stderr => \$stderr_string,
errorfile => \$errorfile_string, # not used when -se flag is set
teefile => \$teefile,
debugfile => \$debugfile_string,
logfile => \$logfile_string,
);
if ( $err || $stderr_string || $errorfile_string ) {
if ($err) {
print STDERR "This error received calling Perl::Tidy with '$sname'\n";
ok( !$err );
}
if ($stderr_string) {
print STDERR "---------------------\n";
print STDERR "<>\n$stderr_string\n";
print STDERR "---------------------\n";
print STDERR "This error received calling Perl::Tidy with '$sname''\n";
ok( !$stderr_string );
}
if ($errorfile_string) {
print STDERR "---------------------\n";
print STDERR "<<.ERR file>>\n$errorfile_string\n";
print STDERR "---------------------\n";
print STDERR "This error received calling Perl::Tidy with '$sname''\n";
ok( !$errorfile_string );
}
}
else {
ok( $output, $expect );
ok( $teefile, $teefile_expect );
}
Perl-Tidy-20210717/t/snippets22.t 0000644 0001750 0001750 00000036360 14072572631 015306 0 ustar steve steve # Created with: ./make_t.pl
# Contents:
#1 here_long.here_long
#2 bbhb.bbhb2
#3 bbhb.bbhb3
#4 bbhb.def
#5 bbhb.bbhb4
#6 bbhb.bbhb5
#7 braces.braces7
#8 xci.def
#9 xci.xci1
#10 xci.xci2
#11 mangle4.def
#12 mangle4.mangle
#13 extrude5.def
#14 extrude5.extrude
#15 kba1.def
#16 kba1.kba1
#17 git45.def
#18 git45.git45
#19 boa.boa
# To locate test #13 you can search for its name or the string '#13'
use strict;
use Test::More;
use Carp;
use Perl::Tidy;
my $rparams;
my $rsources;
my $rtests;
BEGIN {
###########################################
# BEGIN SECTION 1: Parameter combinations #
###########################################
$rparams = {
'bbhb2' => "-bbhb=2 -bbp=2",
'bbhb3' => "-bbhb=3 -bbp=3",
'bbhb4' => "-bbhb=3 -bbp=3 -bbhbi=2 -bbpi=2",
'bbhb5' => "-bbhb=3 -bbp=3 -bbhbi=1 -bbpi=1",
'boa' => <<'----------',
# -boa is default so we test nboa
-nboa
----------
'braces7' => <<'----------',
-bli -blil='*'
----------
'def' => "",
'extrude' => "--extrude",
'git45' => "-vtc=1 -wn",
'here_long' => "-l=33",
'kba1' => <<'----------',
-kbb='=> ,' -kba='=>'
----------
'mangle' => "--mangle",
'xci1' => "-xci",
'xci2' => "-pbp -nst -nse -xci",
};
############################
# BEGIN SECTION 2: Sources #
############################
$rsources = {
'bbhb' => <<'----------',
my %temp =
(
supsup => 123,
nested => {
asdf => 456,
yarg => 'yarp',
}, );
----------
'boa' => <<'----------',
my @field
: field
: Default(1)
: Get('Name' => 'foo')
: Set('Name');
----------
'braces' => <<'----------',
sub message {
if ( !defined( $_[0] ) ) {
print("Hello, World\n");
}
else {
print( $_[0], "\n" );
}
}
$myfun = sub {
print("Hello, World\n");
};
eval {
my $app = App::perlbrew->new( "install-patchperl", "-q" );
$app->run();
} or do {
$error = $@;
$produced_error = 1;
};
Mojo::IOLoop->next_tick(
sub {
$ua->get(
'/' => sub {
push @kept_alive, pop->kept_alive;
Mojo::IOLoop->next_tick( sub { Mojo::IOLoop->stop } );
}
);
}
);
$r = do {
sswitch( $words[ rand @words ] ) {
case $words[0]:
case $words[1]:
case $words[2]:
case $words[3]: { 'ok' }
default: { 'wtf' }
}
};
try {
die;
}
catch {
die;
};
----------
'extrude5' => <<'----------',
use perl6-alpha;
$var{-y} = 1;
----------
'git45' => <<'----------',
# git#45 -vtc=n and -wn were not working together
if (
$self->_add_fqdn_host(
name => $name,
realm => $realm
)
)
{
...;
}
# do not stack )->pack(
my $hlist = $control::control->Scrolled(
'HList',
drawbranch => 1,
width => 20,
-scrollbars => 'w'
)->pack(
-side => 'bottom',
-expand => 1
);
----------
'here_long' => <<'----------',
# must not break after here target regardless of maximum-line-length
$sth= $dbh->prepare (<<"END_OF_SELECT") or die "Couldn't prepare SQL" ;
SELECT COUNT(duration),SUM(duration)
FROM logins WHERE username='$user'
END_OF_SELECT
----------
'kba1' => <<'----------',
$this_env = join("", $before, $closures
, $contents
, ($defenv ? '': &balance_tags())
, $reopens ); $_ = $after;
method 'foo1'
=> [ Int, Int ]
=> sub {
my ( $self, $x, $y ) = ( shift, @_ );
...;
};
method 'foo2'=>
[ Int, Int ]=>
sub {
my ( $self, $x, $y ) = ( shift, @_ );
...;
};
----------
'mangle4' => <<'----------',
# a useful parsing test from 'signatures.t'
use feature "signatures";
no warnings "experimental::signatures";
sub t086
( #foo)))
$ #foo)))
a #foo)))
, #foo)))
, #foo)))
$ #foo)))
b #foo)))
= #foo)))
333 #foo)))
, #foo)))
, #foo)))
) #foo)))
{ $a.$b }
----------
'xci' => <<'----------',
$self->{_text} = (
!$section ? ''
: $type eq 'item' ? "the $section entry"
: "the section on $section"
)
. (
$page
? ( $section ? ' in ' : '' ) . "the $page$page_ext manpage"
: ' elsewhere in this document'
);
my $otherHashRef =
$condition
? {
'a' => 'a value',
'b' => 'b value',
'c' => {
'd' => 'd value',
'e' => 'e value'
}
}
: undef;
my @globlist = ( grep { defined } @opt{qw( l q S t )} )
? do {
local *DIR;
opendir DIR, './' or die "can't opendir './': $!";
my @a = grep { not /^\.+$/ } readdir DIR;
closedir DIR;
@a;
}
: ();
----------
};
####################################
# BEGIN SECTION 3: Expected output #
####################################
$rtests = {
'here_long.here_long' => {
source => "here_long",
params => "here_long",
expect => <<'#1...........',
# must not break after here target regardless of maximum-line-length
$sth = $dbh->prepare(
<<"END_OF_SELECT") or die "Couldn't prepare SQL";
SELECT COUNT(duration),SUM(duration)
FROM logins WHERE username='$user'
END_OF_SELECT
#1...........
},
'bbhb.bbhb2' => {
source => "bbhb",
params => "bbhb2",
expect => <<'#2...........',
my %temp =
(
supsup => 123,
nested =>
{
asdf => 456,
yarg => 'yarp',
},
);
#2...........
},
'bbhb.bbhb3' => {
source => "bbhb",
params => "bbhb3",
expect => <<'#3...........',
my %temp =
(
supsup => 123,
nested =>
{
asdf => 456,
yarg => 'yarp',
},
);
#3...........
},
'bbhb.def' => {
source => "bbhb",
params => "def",
expect => <<'#4...........',
my %temp = (
supsup => 123,
nested => {
asdf => 456,
yarg => 'yarp',
},
);
#4...........
},
'bbhb.bbhb4' => {
source => "bbhb",
params => "bbhb4",
expect => <<'#5...........',
my %temp =
(
supsup => 123,
nested =>
{
asdf => 456,
yarg => 'yarp',
},
);
#5...........
},
'bbhb.bbhb5' => {
source => "bbhb",
params => "bbhb5",
expect => <<'#6...........',
my %temp =
(
supsup => 123,
nested =>
{
asdf => 456,
yarg => 'yarp',
},
);
#6...........
},
'braces.braces7' => {
source => "braces",
params => "braces7",
expect => <<'#7...........',
sub message
{
if ( !defined( $_[0] ) )
{
print("Hello, World\n");
}
else
{
print( $_[0], "\n" );
}
}
$myfun = sub
{
print("Hello, World\n");
};
eval
{
my $app = App::perlbrew->new( "install-patchperl", "-q" );
$app->run();
} or do
{
$error = $@;
$produced_error = 1;
};
Mojo::IOLoop->next_tick(
sub
{
$ua->get(
'/' => sub
{
push @kept_alive, pop->kept_alive;
Mojo::IOLoop->next_tick( sub { Mojo::IOLoop->stop } );
}
);
}
);
$r = do
{
sswitch( $words[ rand @words ] )
{
case $words[0]:
case $words[1]:
case $words[2]:
case $words[3]: { 'ok' }
default: { 'wtf' }
}
};
try
{
die;
}
catch
{
die;
};
#7...........
},
'xci.def' => {
source => "xci",
params => "def",
expect => <<'#8...........',
$self->{_text} = (
!$section ? ''
: $type eq 'item' ? "the $section entry"
: "the section on $section"
)
. (
$page
? ( $section ? ' in ' : '' ) . "the $page$page_ext manpage"
: ' elsewhere in this document'
);
my $otherHashRef =
$condition
? {
'a' => 'a value',
'b' => 'b value',
'c' => {
'd' => 'd value',
'e' => 'e value'
}
}
: undef;
my @globlist = ( grep { defined } @opt{qw( l q S t )} )
? do {
local *DIR;
opendir DIR, './' or die "can't opendir './': $!";
my @a = grep { not /^\.+$/ } readdir DIR;
closedir DIR;
@a;
}
: ();
#8...........
},
'xci.xci1' => {
source => "xci",
params => "xci1",
expect => <<'#9...........',
$self->{_text} = (
!$section ? ''
: $type eq 'item' ? "the $section entry"
: "the section on $section"
)
. (
$page
? ( $section ? ' in ' : '' ) . "the $page$page_ext manpage"
: ' elsewhere in this document'
);
my $otherHashRef =
$condition
? {
'a' => 'a value',
'b' => 'b value',
'c' => {
'd' => 'd value',
'e' => 'e value'
}
}
: undef;
my @globlist = ( grep { defined } @opt{qw( l q S t )} )
? do {
local *DIR;
opendir DIR, './' or die "can't opendir './': $!";
my @a = grep { not /^\.+$/ } readdir DIR;
closedir DIR;
@a;
}
: ();
#9...........
},
'xci.xci2' => {
source => "xci",
params => "xci2",
expect => <<'#10...........',
$self->{_text} = (
!$section ? ''
: $type eq 'item' ? "the $section entry"
: "the section on $section"
)
. ( $page
? ( $section ? ' in ' : '' ) . "the $page$page_ext manpage"
: ' elsewhere in this document'
);
my $otherHashRef
= $condition
? { 'a' => 'a value',
'b' => 'b value',
'c' => {
'd' => 'd value',
'e' => 'e value'
}
}
: undef;
my @globlist = ( grep {defined} @opt{qw( l q S t )} )
? do {
local *DIR;
opendir DIR, './' or die "can't opendir './': $!";
my @a = grep { not /^\.+$/ } readdir DIR;
closedir DIR;
@a;
}
: ();
#10...........
},
'mangle4.def' => {
source => "mangle4",
params => "def",
expect => <<'#11...........',
# a useful parsing test from 'signatures.t'
use feature "signatures";
no warnings "experimental::signatures";
sub t086 ( #foo)))
$ #foo)))
a #foo)))
, #foo)))
, #foo)))
$ #foo)))
b #foo)))
= #foo)))
333 #foo)))
, #foo)))
, #foo)))
) #foo)))
{ $a . $b }
#11...........
},
'mangle4.mangle' => {
source => "mangle4",
params => "mangle",
expect => <<'#12...........',
# a useful parsing test from 'signatures.t'
use feature "signatures";
no warnings "experimental::signatures";
sub t086(#foo)))
$ #foo)))
a#foo)))
,#foo)))
,#foo)))
$ #foo)))
b#foo)))
=#foo)))
333#foo)))
,#foo)))
,#foo)))
)#foo)))
{$a.$b}
#12...........
},
'extrude5.def' => {
source => "extrude5",
params => "def",
expect => <<'#13...........',
use perl6-alpha;
$var{-y} = 1;
#13...........
},
'extrude5.extrude' => {
source => "extrude5",
params => "extrude",
expect => <<'#14...........',
use
perl6-alpha
;
$var{-y}
=
1
;
#14...........
},
'kba1.def' => {
source => "kba1",
params => "def",
expect => <<'#15...........',
$this_env = join( "",
$before, $closures, $contents, ( $defenv ? '' : &balance_tags() ),
$reopens );
$_ = $after;
method 'foo1' => [ Int, Int ] => sub {
my ( $self, $x, $y ) = ( shift, @_ );
...;
};
method 'foo2' => [ Int, Int ] => sub {
my ( $self, $x, $y ) = ( shift, @_ );
...;
};
#15...........
},
'kba1.kba1' => {
source => "kba1",
params => "kba1",
expect => <<'#16...........',
$this_env = join(
"", $before, $closures
, $contents
, ( $defenv ? '' : &balance_tags() )
, $reopens
);
$_ = $after;
method 'foo1'
=> [ Int, Int ]
=> sub {
my ( $self, $x, $y ) = ( shift, @_ );
...;
};
method 'foo2' =>
[ Int, Int ] =>
sub {
my ( $self, $x, $y ) = ( shift, @_ );
...;
};
#16...........
},
'git45.def' => {
source => "git45",
params => "def",
expect => <<'#17...........',
# git#45 -vtc=n and -wn were not working together
if (
$self->_add_fqdn_host(
name => $name,
realm => $realm
)
)
{
...;
}
# do not stack )->pack(
my $hlist = $control::control->Scrolled(
'HList',
drawbranch => 1,
width => 20,
-scrollbars => 'w'
)->pack(
-side => 'bottom',
-expand => 1
);
#17...........
},
'git45.git45' => {
source => "git45",
params => "git45",
expect => <<'#18...........',
# git#45 -vtc=n and -wn were not working together
if ( $self->_add_fqdn_host(
name => $name,
realm => $realm ) )
{
...;
}
# do not stack )->pack(
my $hlist = $control::control->Scrolled(
'HList',
drawbranch => 1,
width => 20,
-scrollbars => 'w'
)->pack(
-side => 'bottom',
-expand => 1 );
#18...........
},
'boa.boa' => {
source => "boa",
params => "boa",
expect => <<'#19...........',
my @field : field : Default(1) : Get('Name' => 'foo') : Set('Name');
#19...........
},
};
my $ntests = 0 + keys %{$rtests};
plan tests => $ntests;
}
###############
# EXECUTE TESTS
###############
foreach my $key ( sort keys %{$rtests} ) {
my $output;
my $sname = $rtests->{$key}->{source};
my $expect = $rtests->{$key}->{expect};
my $pname = $rtests->{$key}->{params};
my $source = $rsources->{$sname};
my $params = defined($pname) ? $rparams->{$pname} : "";
my $stderr_string;
my $errorfile_string;
my $err = Perl::Tidy::perltidy(
source => \$source,
destination => \$output,
perltidyrc => \$params,
argv => '', # for safety; hide any ARGV from perltidy
stderr => \$stderr_string,
errorfile => \$errorfile_string, # not used when -se flag is set
);
if ( $err || $stderr_string || $errorfile_string ) {
print STDERR "Error output received for test '$key'\n";
if ($err) {
print STDERR "An error flag '$err' was returned\n";
ok( !$err );
}
if ($stderr_string) {
print STDERR "---------------------\n";
print STDERR "<>\n$stderr_string\n";
print STDERR "---------------------\n";
ok( !$stderr_string );
}
if ($errorfile_string) {
print STDERR "---------------------\n";
print STDERR "<<.ERR file>>\n$errorfile_string\n";
print STDERR "---------------------\n";
ok( !$errorfile_string );
}
}
else {
if ( !is( $output, $expect, $key ) ) {
my $leno = length($output);
my $lene = length($expect);
if ( $leno == $lene ) {
print STDERR
"#> Test '$key' gave unexpected output. Strings differ but both have length $leno\n";
}
else {
print STDERR
"#> Test '$key' gave unexpected output. String lengths differ: output=$leno, expected=$lene\n";
}
}
}
}
Perl-Tidy-20210717/t/snippets23.t 0000644 0001750 0001750 00000041527 14072572632 015311 0 ustar steve steve # Created with: ./make_t.pl
# Contents:
#1 boa.def
#2 bol.bol
#3 bol.def
#4 bot.bot
#5 bot.def
#6 hash_bang.def
#7 hash_bang.hash_bang
#8 listop1.listop1
#9 sbcp.def
#10 sbcp.sbcp1
#11 wnxl.def
#12 wnxl.wnxl1
#13 wnxl.wnxl2
#14 wnxl.wnxl3
#15 wnxl.wnxl4
#16 align34.def
#17 git47.def
#18 git47.git47
#19 qw.def
# To locate test #13 you can search for its name or the string '#13'
use strict;
use Test::More;
use Carp;
use Perl::Tidy;
my $rparams;
my $rsources;
my $rtests;
BEGIN {
###########################################
# BEGIN SECTION 1: Parameter combinations #
###########################################
$rparams = {
'bol' => <<'----------',
# -bol is default, so test -nbol
-nbol
----------
'bot' => <<'----------',
# -bot is default so we test -nbot
-nbot
----------
'def' => "",
'git47' => <<'----------',
# perltidyrc from git #47
-pbp # Start with Perl Best Practices
-w # Show all warnings
-iob # Ignore old breakpoints
-l=120 # 120 characters per line
-mbl=2 # No more than 2 blank lines
-i=2 # Indentation is 2 columns
-ci=2 # Continuation indentation is 2 columns
-vt=0 # Less vertical tightness
-pt=2 # High parenthesis tightness
-bt=2 # High brace tightness
-sbt=2 # High square bracket tightness
-wn # Weld nested containers
-isbc # Don't indent comments without leading space
-nst # Don't output to STDOUT
----------
'hash_bang' => "-x",
'listop1' => <<'----------',
# -bok is default so we test nbok
-nbok
----------
'sbcp1' => <<'----------',
-sbc -sbcp='#x#'
----------
'wnxl1' => <<'----------',
# only weld parens, and only if leading keyword
-wn -wnxl='^K( [ { q'
----------
'wnxl2' => <<'----------',
# do not weld leading '['
-wn -wnxl='^['
----------
'wnxl3' => <<'----------',
# do not weld interior or ending '{' without a keyword
-wn -wnxl='.K{'
----------
'wnxl4' => <<'----------',
# do not weld except parens or trailing brace with keyword
-wn -wnxl='.K{ ^{ ['
----------
};
############################
# BEGIN SECTION 2: Sources #
############################
$rsources = {
'align34' => <<'----------',
# align all '{' and runs of '='
if ( $line =~ /^NAME>(.*)/i ) { $Cookies{'name'} = $1; }
elsif ( $line =~ /^EMAIL>(.*)/i ) { $email = $1; }
elsif ( $line =~ /^IP_ADDRESS>(.*)/i ) { $ipaddress = $1; }
elsif ( $line =~ /^/i ) { $remoteuser = $1; }
elsif ( $line =~ /^PASSWORD>(.*)/i ) { next; }
elsif ( $line =~ /^IMAGE>(.*)/i ) { $image_url = $1; }
elsif ( $line =~ /^LINKNAME>(.*)/i ) { $linkname = $1; }
elsif ( $line =~ /^LINKURL>(.*)/i ) { $linkurl = $1; }
else { $body .= $line; }
----------
'boa' => <<'----------',
my @field
: field
: Default(1)
: Get('Name' => 'foo')
: Set('Name');
----------
'bol' => <<'----------',
return unless $cmd = $cmd || ($dot
&& $Last_Shell) || &prompt('|');
----------
'bot' => <<'----------',
$foo =
$condition
? undef
: 1;
----------
'git47' => <<'----------',
# cannot weld here
$promises[$i]->then(
sub { $all->resolve(@_); () },
sub {
$results->[$i] = [@_];
$all->reject(@$results) if --$remaining <= 0;
return ();
}
);
sub _absolutize { [
map { _is_scoped($_) ? $_ : [ [ [ 'pc', 'scope' ] ], ' ', @$_ ] }
@{ shift() } ] }
$c->helpers->log->debug( sub {
my $req = $c->req;
my $method = $req->method;
my $path = $req->url->path->to_abs_string;
$c->helpers->timing->begin('mojo.timer');
return qq{$method "$path"};
} ) unless $stash->{'mojo.static'};
# A single signature var can weld
return Mojo::Promise->resolve($query_params)->then(&_reveal_event)->then(
sub ($code) {
return $c->render( text => '', status => $code );
}
);
----------
'hash_bang' => <<'----------',
# above spaces will be retained with -x but not by default
#!/usr/bin/perl
my $date = localtime();
----------
'listop1' => <<'----------',
my @sorted = map { $_->[0] }
sort { $a->[1] <=> $b->[1] }
map { [ $_, rand ] } @list;
----------
'qw' => <<'----------',
# do not outdent ending ) more than initial 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
) );
}
# outdent ')' even if opening is not '('
@EXPORT = (
qw)
i Re Im rho theta arg
sqrt log ln
log10 logn cbrt root
cplx cplxe
),
@trig
);
# outdent '>' like ')'
@EXPORT = (
qw<
i Re Im rho theta arg
sqrt log ln
log10 logn cbrt root
cplx cplxe
>,
@trig
);
# but ';' not outdented
@EXPORT = (
qw;
i Re Im rho theta arg
sqrt log ln
log10 logn cbrt root
cplx cplxe
;,
@trig
);
----------
'sbcp' => <<'----------',
@month_of_year = (
'Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun', 'Jul', 'Aug', 'Sep', 'Oct',
#x# 'Dec', 'Nov'
## 'Dec', 'Nov'
'Nov', 'Dec'
);
----------
'wnxl' => <<'----------',
if ( $PLATFORM eq 'aix' ) {
skip_symbols(
[ qw(
Perl_dump_fds
Perl_ErrorNo
Perl_GetVars
PL_sys_intern
) ]
);
}
if ( _add_fqdn_host(
name => ...,
fqdn => ...
) )
{
...;
}
do {{
next if ($n % 2);
print $n, "\n";
}} while ($n++ < 10);
threads->create( sub {
my (%hash3);
share(%hash3);
$hash2{hash} = \%hash3;
$hash3{"thread"} = "yes";
} )->join();
----------
};
####################################
# BEGIN SECTION 3: Expected output #
####################################
$rtests = {
'boa.def' => {
source => "boa",
params => "def",
expect => <<'#1...........',
my @field
: field
: Default(1)
: Get('Name' => 'foo')
: Set('Name');
#1...........
},
'bol.bol' => {
source => "bol",
params => "bol",
expect => <<'#2...........',
return unless $cmd = $cmd || ( $dot && $Last_Shell ) || &prompt('|');
#2...........
},
'bol.def' => {
source => "bol",
params => "def",
expect => <<'#3...........',
return
unless $cmd = $cmd
|| ( $dot
&& $Last_Shell )
|| &prompt('|');
#3...........
},
'bot.bot' => {
source => "bot",
params => "bot",
expect => <<'#4...........',
$foo = $condition ? undef : 1;
#4...........
},
'bot.def' => {
source => "bot",
params => "def",
expect => <<'#5...........',
$foo =
$condition
? undef
: 1;
#5...........
},
'hash_bang.def' => {
source => "hash_bang",
params => "def",
expect => <<'#6...........',
# above spaces will be retained with -x but not by default
#!/usr/bin/perl
my $date = localtime();
#6...........
},
'hash_bang.hash_bang' => {
source => "hash_bang",
params => "hash_bang",
expect => <<'#7...........',
# above spaces will be retained with -x but not by default
#!/usr/bin/perl
my $date = localtime();
#7...........
},
'listop1.listop1' => {
source => "listop1",
params => "listop1",
expect => <<'#8...........',
my @sorted =
map { $_->[0] } sort { $a->[1] <=> $b->[1] } map { [ $_, rand ] } @list;
#8...........
},
'sbcp.def' => {
source => "sbcp",
params => "def",
expect => <<'#9...........',
@month_of_year = (
'Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun', 'Jul', 'Aug', 'Sep', 'Oct',
#x# 'Dec', 'Nov'
## 'Dec', 'Nov'
'Nov', 'Dec'
);
#9...........
},
'sbcp.sbcp1' => {
source => "sbcp",
params => "sbcp1",
expect => <<'#10...........',
@month_of_year = (
'Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun', 'Jul', 'Aug', 'Sep', 'Oct',
#x# 'Dec', 'Nov'
## 'Dec', 'Nov'
'Nov', 'Dec'
);
#10...........
},
'wnxl.def' => {
source => "wnxl",
params => "def",
expect => <<'#11...........',
if ( $PLATFORM eq 'aix' ) {
skip_symbols(
[
qw(
Perl_dump_fds
Perl_ErrorNo
Perl_GetVars
PL_sys_intern
)
]
);
}
if (
_add_fqdn_host(
name => ...,
fqdn => ...
)
)
{
...;
}
do {
{
next if ( $n % 2 );
print $n, "\n";
}
} while ( $n++ < 10 );
threads->create(
sub {
my (%hash3);
share(%hash3);
$hash2{hash} = \%hash3;
$hash3{"thread"} = "yes";
}
)->join();
#11...........
},
'wnxl.wnxl1' => {
source => "wnxl",
params => "wnxl1",
expect => <<'#12...........',
if ( $PLATFORM eq 'aix' ) {
skip_symbols(
[
qw(
Perl_dump_fds
Perl_ErrorNo
Perl_GetVars
PL_sys_intern
)
]
);
}
if ( _add_fqdn_host(
name => ...,
fqdn => ...
) )
{
...;
}
do {
{
next if ( $n % 2 );
print $n, "\n";
}
} while ( $n++ < 10 );
threads->create(
sub {
my (%hash3);
share(%hash3);
$hash2{hash} = \%hash3;
$hash3{"thread"} = "yes";
}
)->join();
#12...........
},
'wnxl.wnxl2' => {
source => "wnxl",
params => "wnxl2",
expect => <<'#13...........',
if ( $PLATFORM eq 'aix' ) {
skip_symbols( [ qw(
Perl_dump_fds
Perl_ErrorNo
Perl_GetVars
PL_sys_intern
) ] );
}
if ( _add_fqdn_host(
name => ...,
fqdn => ...
) )
{
...;
}
do { {
next if ( $n % 2 );
print $n, "\n";
} } while ( $n++ < 10 );
threads->create( sub {
my (%hash3);
share(%hash3);
$hash2{hash} = \%hash3;
$hash3{"thread"} = "yes";
} )->join();
#13...........
},
'wnxl.wnxl3' => {
source => "wnxl",
params => "wnxl3",
expect => <<'#14...........',
if ( $PLATFORM eq 'aix' ) {
skip_symbols( [ qw(
Perl_dump_fds
Perl_ErrorNo
Perl_GetVars
PL_sys_intern
) ] );
}
if ( _add_fqdn_host(
name => ...,
fqdn => ...
) )
{
...;
}
do {
{
next if ( $n % 2 );
print $n, "\n";
}
} while ( $n++ < 10 );
threads->create( sub {
my (%hash3);
share(%hash3);
$hash2{hash} = \%hash3;
$hash3{"thread"} = "yes";
} )->join();
#14...........
},
'wnxl.wnxl4' => {
source => "wnxl",
params => "wnxl4",
expect => <<'#15...........',
if ( $PLATFORM eq 'aix' ) {
skip_symbols(
[
qw(
Perl_dump_fds
Perl_ErrorNo
Perl_GetVars
PL_sys_intern
)
]
);
}
if ( _add_fqdn_host(
name => ...,
fqdn => ...
) )
{
...;
}
do {
{
next if ( $n % 2 );
print $n, "\n";
}
} while ( $n++ < 10 );
threads->create( sub {
my (%hash3);
share(%hash3);
$hash2{hash} = \%hash3;
$hash3{"thread"} = "yes";
} )->join();
#15...........
},
'align34.def' => {
source => "align34",
params => "def",
expect => <<'#16...........',
# align all '{' and runs of '='
if ( $line =~ /^NAME>(.*)/i ) { $Cookies{'name'} = $1; }
elsif ( $line =~ /^EMAIL>(.*)/i ) { $email = $1; }
elsif ( $line =~ /^IP_ADDRESS>(.*)/i ) { $ipaddress = $1; }
elsif ( $line =~ /^/i ) { $remoteuser = $1; }
elsif ( $line =~ /^PASSWORD>(.*)/i ) { next; }
elsif ( $line =~ /^IMAGE>(.*)/i ) { $image_url = $1; }
elsif ( $line =~ /^LINKNAME>(.*)/i ) { $linkname = $1; }
elsif ( $line =~ /^LINKURL>(.*)/i ) { $linkurl = $1; }
else { $body .= $line; }
#16...........
},
'git47.def' => {
source => "git47",
params => "def",
expect => <<'#17...........',
# cannot weld here
$promises[$i]->then(
sub { $all->resolve(@_); () },
sub {
$results->[$i] = [@_];
$all->reject(@$results) if --$remaining <= 0;
return ();
}
);
sub _absolutize {
[ map { _is_scoped($_) ? $_ : [ [ [ 'pc', 'scope' ] ], ' ', @$_ ] }
@{ shift() } ]
}
$c->helpers->log->debug(
sub {
my $req = $c->req;
my $method = $req->method;
my $path = $req->url->path->to_abs_string;
$c->helpers->timing->begin('mojo.timer');
return qq{$method "$path"};
}
) unless $stash->{'mojo.static'};
# A single signature var can weld
return Mojo::Promise->resolve($query_params)->then(&_reveal_event)->then(
sub ($code) {
return $c->render( text => '', status => $code );
}
);
#17...........
},
'git47.git47' => {
source => "git47",
params => "git47",
expect => <<'#18...........',
# cannot weld here
$promises[$i]->then(
sub { $all->resolve(@_); () },
sub {
$results->[$i] = [@_];
$all->reject(@$results) if --$remaining <= 0;
return ();
}
);
sub _absolutize { [map { _is_scoped($_) ? $_ : [[['pc', 'scope']], ' ', @$_] } @{shift()}] }
$c->helpers->log->debug(sub {
my $req = $c->req;
my $method = $req->method;
my $path = $req->url->path->to_abs_string;
$c->helpers->timing->begin('mojo.timer');
return qq{$method "$path"};
}) unless $stash->{'mojo.static'};
# A single signature var can weld
return Mojo::Promise->resolve($query_params)->then(&_reveal_event)->then(sub ($code) {
return $c->render(text => '', status => $code);
});
#18...........
},
'qw.def' => {
source => "qw",
params => "def",
expect => <<'#19...........',
# do not outdent ending ) more than initial 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
) );
}
# outdent ')' even if opening is not '('
@EXPORT = (
qw)
i Re Im rho theta arg
sqrt log ln
log10 logn cbrt root
cplx cplxe
),
@trig
);
# outdent '>' like ')'
@EXPORT = (
qw<
i Re Im rho theta arg
sqrt log ln
log10 logn cbrt root
cplx cplxe
>,
@trig
);
# but ';' not outdented
@EXPORT = (
qw;
i Re Im rho theta arg
sqrt log ln
log10 logn cbrt root
cplx cplxe
;,
@trig
);
#19...........
},
};
my $ntests = 0 + keys %{$rtests};
plan tests => $ntests;
}
###############
# EXECUTE TESTS
###############
foreach my $key ( sort keys %{$rtests} ) {
my $output;
my $sname = $rtests->{$key}->{source};
my $expect = $rtests->{$key}->{expect};
my $pname = $rtests->{$key}->{params};
my $source = $rsources->{$sname};
my $params = defined($pname) ? $rparams->{$pname} : "";
my $stderr_string;
my $errorfile_string;
my $err = Perl::Tidy::perltidy(
source => \$source,
destination => \$output,
perltidyrc => \$params,
argv => '', # for safety; hide any ARGV from perltidy
stderr => \$stderr_string,
errorfile => \$errorfile_string, # not used when -se flag is set
);
if ( $err || $stderr_string || $errorfile_string ) {
print STDERR "Error output received for test '$key'\n";
if ($err) {
print STDERR "An error flag '$err' was returned\n";
ok( !$err );
}
if ($stderr_string) {
print STDERR "---------------------\n";
print STDERR "<>\n$stderr_string\n";
print STDERR "---------------------\n";
ok( !$stderr_string );
}
if ($errorfile_string) {
print STDERR "---------------------\n";
print STDERR "<<.ERR file>>\n$errorfile_string\n";
print STDERR "---------------------\n";
ok( !$errorfile_string );
}
}
else {
if ( !is( $output, $expect, $key ) ) {
my $leno = length($output);
my $lene = length($expect);
if ( $leno == $lene ) {
print STDERR
"#> Test '$key' gave unexpected output. Strings differ but both have length $leno\n";
}
else {
print STDERR
"#> Test '$key' gave unexpected output. String lengths differ: output=$leno, expected=$lene\n";
}
}
}
}
Perl-Tidy-20210717/t/snippets18.t 0000644 0001750 0001750 00000052460 14072572631 015312 0 ustar steve steve # Created with: ./make_t.pl
# Contents:
#1 wn7.wn
#2 wn8.def
#3 wn8.wn
#4 comments.comments5
#5 braces.braces1
#6 braces.braces2
#7 braces.braces3
#8 braces.def
#9 csc.csc1
#10 csc.csc2
#11 csc.def
#12 iob.def
#13 iob.iob
#14 kis.def
#15 kis.kis
#16 maths.def
#17 maths.maths1
#18 maths.maths2
#19 misc_tests.def
# To locate test #13 you can search for its name or the string '#13'
use strict;
use Test::More;
use Carp;
use Perl::Tidy;
my $rparams;
my $rsources;
my $rtests;
BEGIN {
###########################################
# BEGIN SECTION 1: Parameter combinations #
###########################################
$rparams = {
'braces1' => "-bl -asbl",
'braces2' => "-sbl",
'braces3' => "-bli -bbvt=1",
'comments5' => <<'----------',
# testing --delete-side-comments and --nostatic-block-comments
-dsc -nsbc
----------
'csc1' => "-csc -csci=2 -ncscb",
'csc2' => "-dcsc",
'def' => "",
'iob' => "-iob",
'kis' => "-kis",
'maths1' => <<'----------',
# testing -break-before-all-operators and no spaces around math operators
-bbao -nwls="= + - / *" -nwrs="= + - / *"
----------
'maths2' => <<'----------',
# testing -break-after-all-operators and no spaces around math operators
-baao -nwls="= + - / *" -nwrs="= + - / *"
----------
'wn' => "-wn",
};
############################
# BEGIN SECTION 2: Sources #
############################
$rsources = {
'braces' => <<'----------',
sub message {
if ( !defined( $_[0] ) ) {
print("Hello, World\n");
}
else {
print( $_[0], "\n" );
}
}
$myfun = sub {
print("Hello, World\n");
};
eval {
my $app = App::perlbrew->new( "install-patchperl", "-q" );
$app->run();
} or do {
$error = $@;
$produced_error = 1;
};
Mojo::IOLoop->next_tick(
sub {
$ua->get(
'/' => sub {
push @kept_alive, pop->kept_alive;
Mojo::IOLoop->next_tick( sub { Mojo::IOLoop->stop } );
}
);
}
);
$r = do {
sswitch( $words[ rand @words ] ) {
case $words[0]:
case $words[1]:
case $words[2]:
case $words[3]: { 'ok' }
default: { 'wtf' }
}
};
try {
die;
}
catch {
die;
};
----------
'comments' => <<'----------',
#!/usr/bin/perl -w
# an initial hash bang line cannot be deleted with -dp
#<<< format skipping of first code can cause an error message in perltidy v20210625
my $rvar = [ [ 1, 2, 3 ], [ 4, 5, 6 ] ];
#>>>
sub length { return length($_[0]) } # side comment
# hanging side comment
# very longgggggggggggggggggggggggggggggggggggggggggggggggggggg hanging side comment
# a blank will be inserted to prevent forming a hanging side comment
sub macro_get_names { #
#
# %name = macro_get_names(); (key=macrohandle, value=macroname)
#
##local(%name); # a static block comment without indentation
local(%name)=(); ## a static side comment to test -ssc
# a spaced block comment to test -isbc
for (0..$#mac_ver) {
# a very long comment for testing the parameter --nooutdent-long-comments (or -nolc)
$name{$_} = $mac_ext[$idx{$mac_exti[$_]}];
$vmsfile =~ s/;[\d\-]*$//; # very long side comment; Clip off version number; we can use a newer version as well
}
%name;
}
@month_of_year = (
'Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun', 'Jul', 'Aug', 'Sep', 'Oct',
## 'Dec', 'Nov' [a static block comment with indentation]
'Nov', 'Dec');
{ # this side comment will not align
my $IGNORE = 0; # This is a side comment
# This is a hanging side comment
# And so is this
# A blank line interrupts the hsc's; this is a block comment
}
# side comments at different indentation levels should not normally be aligned
{ { { { { ${msg} = "Hello World!"; print "My message: ${msg}\n"; } } #end level 4
} # end level 3
} # end level 2
} # end level 1
#<<< do not let perltidy touch this unless -nfs is set
my @list = (1,
1, 1,
1, 2, 1,
1, 3, 3, 1,
1, 4, 6, 4, 1,);
#>>>
#<< test alternate format skipping string
my @list = (1,
1, 1,
1, 2, 1,
1, 3, 3, 1,
1, 4, 6, 4, 1,);
#>>
# some blank lines follow
=pod
Some pod before __END__ to delete with -dp
=cut
__END__
# text following __END__, not a comment
=pod
Some pod after __END__ to delete with -dp and trim with -trp
=cut
----------
'csc' => <<'----------',
sub message {
if ( !defined( $_[0] ) ) {
print("Hello, World\n");
}
else {
print( $_[0], "\n" );
}
} ## end sub message
----------
'iob' => <<'----------',
return "this is a descriptive error message"
if $res->is_error
or not length $data;
----------
'kis' => <<'----------',
dbmclose(%verb_delim); undef %verb_delim;
dbmclose(%expanded); undef %expanded;
----------
'maths' => <<'----------',
$tmp = $day - 32075 + 1461 * ( $year + 4800 - ( 14 - $month ) / 12 ) / 4 + 367
* ( $month - 2 + ( ( 14 - $month ) / 12 ) * 12 ) / 12 - 3 * ( ( $year + 4900 -
( 14 - $month ) / 12 ) / 100 ) / 4;
return ( $r**$n ) * ( pi**( $n / 2 ) ) / ( sqrt(pi) * factorial( 2 * ( int( $n
/ 2 ) ) + 2 ) / factorial( int( $n / 2 ) + 1 ) / ( 4**( int( $n / 2 ) + 1 ) )
);
$root=-$b+sqrt($b*$b-4.*$a*$c)/(2.*$a);
----------
'misc_tests' => <<'----------',
for ( @a = @$ap, $u = shift @a; @a; $u = $v ) { ... } # test -sfs
$i = 1 ; # test -sts
$i = 0; ## =1; test -ssc
;;;; # test -ndsm
my ( $a, $b, $c ) = @_; # test -nsak="my for"
----------
'wn7' => <<'----------',
# do not weld paren to opening one-line non-paren container
$Self->_Add($SortOrderDisplay{$Field->GenerateFieldForSelectSQL()});
# this will not get welded with -wn
f(
do { 1; !!(my $x = bless []); }
);
----------
'wn8' => <<'----------',
# Former -wn blinkers, which oscillated between two states
# fixed RULE 1 only applies to '('
my $res = eval { { $die_on_fetch, 0 } };
my $res = eval {
{ $die_on_fetch, 0 }
};
# fixed RULE 2 applies to any inner opening token; this is a stable
# state with -wn
$app->FORM->{'appbar1'}->set_status(
_("Cannot delete zone $name: sub-zones or appellations exist.")
);
# OLD: fixed RULE 1: this is now a stable state with -wn
# NEW (30 jan 2021): do not weld if one interior token
$app->FORM->{'appbar1'}->set_status(_(
"Cannot delete zone $name: sub-zones or appellations exist."));
----------
};
####################################
# BEGIN SECTION 3: Expected output #
####################################
$rtests = {
'wn7.wn' => {
source => "wn7",
params => "wn",
expect => <<'#1...........',
# do not weld paren to opening one-line non-paren container
$Self->_Add(
$SortOrderDisplay{
$Field->GenerateFieldForSelectSQL()
}
);
# this will not get welded with -wn
f(
do { 1; !!( my $x = bless [] ); }
);
#1...........
},
'wn8.def' => {
source => "wn8",
params => "def",
expect => <<'#2...........',
# Former -wn blinkers, which oscillated between two states
# fixed RULE 1 only applies to '('
my $res = eval {
{ $die_on_fetch, 0 }
};
my $res = eval {
{ $die_on_fetch, 0 }
};
# fixed RULE 2 applies to any inner opening token; this is a stable
# state with -wn
$app->FORM->{'appbar1'}->set_status(
_("Cannot delete zone $name: sub-zones or appellations exist.")
);
# OLD: fixed RULE 1: this is now a stable state with -wn
# NEW (30 jan 2021): do not weld if one interior token
$app->FORM->{'appbar1'}->set_status(
_("Cannot delete zone $name: sub-zones or appellations exist.")
);
#2...........
},
'wn8.wn' => {
source => "wn8",
params => "wn",
expect => <<'#3...........',
# Former -wn blinkers, which oscillated between two states
# fixed RULE 1 only applies to '('
my $res = eval { { $die_on_fetch, 0 } };
my $res = eval {
{ $die_on_fetch, 0 }
};
# fixed RULE 2 applies to any inner opening token; this is a stable
# state with -wn
$app->FORM->{'appbar1'}->set_status(
_("Cannot delete zone $name: sub-zones or appellations exist.")
);
# OLD: fixed RULE 1: this is now a stable state with -wn
# NEW (30 jan 2021): do not weld if one interior token
$app->FORM->{'appbar1'}->set_status(
_("Cannot delete zone $name: sub-zones or appellations exist.")
);
#3...........
},
'comments.comments5' => {
source => "comments",
params => "comments5",
expect => <<'#4...........',
#!/usr/bin/perl -w
# an initial hash bang line cannot be deleted with -dp
#<<< format skipping of first code can cause an error message in perltidy v20210625
my $rvar = [ [ 1, 2, 3 ], [ 4, 5, 6 ] ];
#>>>
sub length { return length( $_[0] ) }
# a blank will be inserted to prevent forming a hanging side comment
sub macro_get_names {
#
# %name = macro_get_names(); (key=macrohandle, value=macroname)
#
##local(%name); # a static block comment without indentation
local (%name) = ();
# a spaced block comment to test -isbc
for ( 0 .. $#mac_ver ) {
# a very long comment for testing the parameter --nooutdent-long-comments (or -nolc)
$name{$_} = $mac_ext[ $idx{ $mac_exti[$_] } ];
$vmsfile =~ s/;[\d\-]*$//;
}
%name;
}
@month_of_year = (
'Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun', 'Jul', 'Aug', 'Sep', 'Oct',
## 'Dec', 'Nov' [a static block comment with indentation]
'Nov', 'Dec'
);
{
my $IGNORE = 0;
# A blank line interrupts the hsc's; this is a block comment
}
# side comments at different indentation levels should not normally be aligned
{
{
{
{
{ ${msg} = "Hello World!"; print "My message: ${msg}\n"; }
}
}
}
}
#<<< do not let perltidy touch this unless -nfs is set
my @list = (1,
1, 1,
1, 2, 1,
1, 3, 3, 1,
1, 4, 6, 4, 1,);
#>>>
#<< test alternate format skipping string
my @list = ( 1, 1, 1, 1, 2, 1, 1, 3, 3, 1, 1, 4, 6, 4, 1, );
#>>
# some blank lines follow
=pod
Some pod before __END__ to delete with -dp
=cut
__END__
# text following __END__, not a comment
=pod
Some pod after __END__ to delete with -dp and trim with -trp
=cut
#4...........
},
'braces.braces1' => {
source => "braces",
params => "braces1",
expect => <<'#5...........',
sub message
{
if ( !defined( $_[0] ) )
{
print("Hello, World\n");
}
else
{
print( $_[0], "\n" );
}
}
$myfun = sub
{
print("Hello, World\n");
};
eval {
my $app = App::perlbrew->new( "install-patchperl", "-q" );
$app->run();
} or do
{
$error = $@;
$produced_error = 1;
};
Mojo::IOLoop->next_tick(
sub
{
$ua->get(
'/' => sub
{
push @kept_alive, pop->kept_alive;
Mojo::IOLoop->next_tick( sub { Mojo::IOLoop->stop } );
}
);
}
);
$r = do
{
sswitch( $words[ rand @words ] )
{
case $words[0]:
case $words[1]:
case $words[2]:
case $words[3]: { 'ok' }
default: { 'wtf' }
}
};
try
{
die;
}
catch
{
die;
};
#5...........
},
'braces.braces2' => {
source => "braces",
params => "braces2",
expect => <<'#6...........',
sub message
{
if ( !defined( $_[0] ) ) {
print("Hello, World\n");
}
else {
print( $_[0], "\n" );
}
}
$myfun = sub {
print("Hello, World\n");
};
eval {
my $app = App::perlbrew->new( "install-patchperl", "-q" );
$app->run();
} or do {
$error = $@;
$produced_error = 1;
};
Mojo::IOLoop->next_tick(
sub {
$ua->get(
'/' => sub {
push @kept_alive, pop->kept_alive;
Mojo::IOLoop->next_tick( sub { Mojo::IOLoop->stop } );
}
);
}
);
$r = do {
sswitch( $words[ rand @words ] ) {
case $words[0]:
case $words[1]:
case $words[2]:
case $words[3]: { 'ok' }
default: { 'wtf' }
}
};
try {
die;
}
catch {
die;
};
#6...........
},
'braces.braces3' => {
source => "braces",
params => "braces3",
expect => <<'#7...........',
sub message
{ if ( !defined( $_[0] ) )
{ print("Hello, World\n");
}
else
{ print( $_[0], "\n" );
}
}
$myfun = sub {
print("Hello, World\n");
};
eval {
my $app = App::perlbrew->new( "install-patchperl", "-q" );
$app->run();
} or do
{ $error = $@;
$produced_error = 1;
};
Mojo::IOLoop->next_tick(
sub {
$ua->get(
'/' => sub {
push @kept_alive, pop->kept_alive;
Mojo::IOLoop->next_tick( sub { Mojo::IOLoop->stop } );
}
);
}
);
$r = do
{ sswitch( $words[ rand @words ] )
{
case $words[0]:
case $words[1]:
case $words[2]:
case $words[3]: { 'ok' }
default: { 'wtf' }
}
};
try
{
die;
}
catch
{
die;
};
#7...........
},
'braces.def' => {
source => "braces",
params => "def",
expect => <<'#8...........',
sub message {
if ( !defined( $_[0] ) ) {
print("Hello, World\n");
}
else {
print( $_[0], "\n" );
}
}
$myfun = sub {
print("Hello, World\n");
};
eval {
my $app = App::perlbrew->new( "install-patchperl", "-q" );
$app->run();
} or do {
$error = $@;
$produced_error = 1;
};
Mojo::IOLoop->next_tick(
sub {
$ua->get(
'/' => sub {
push @kept_alive, pop->kept_alive;
Mojo::IOLoop->next_tick( sub { Mojo::IOLoop->stop } );
}
);
}
);
$r = do {
sswitch( $words[ rand @words ] ) {
case $words[0]:
case $words[1]:
case $words[2]:
case $words[3]: { 'ok' }
default: { 'wtf' }
}
};
try {
die;
}
catch {
die;
};
#8...........
},
'csc.csc1' => {
source => "csc",
params => "csc1",
expect => <<'#9...........',
sub message {
if ( !defined( $_[0] ) ) {
print("Hello, World\n");
} ## end if ( !defined( $_[0] ))
else {
print( $_[0], "\n" );
} ## end else [ if ( !defined( $_[0] ))
} ## end sub message
#9...........
},
'csc.csc2' => {
source => "csc",
params => "csc2",
expect => <<'#10...........',
sub message {
if ( !defined( $_[0] ) ) {
print("Hello, World\n");
}
else {
print( $_[0], "\n" );
}
}
#10...........
},
'csc.def' => {
source => "csc",
params => "def",
expect => <<'#11...........',
sub message {
if ( !defined( $_[0] ) ) {
print("Hello, World\n");
}
else {
print( $_[0], "\n" );
}
} ## end sub message
#11...........
},
'iob.def' => {
source => "iob",
params => "def",
expect => <<'#12...........',
return "this is a descriptive error message"
if $res->is_error
or not length $data;
#12...........
},
'iob.iob' => {
source => "iob",
params => "iob",
expect => <<'#13...........',
return "this is a descriptive error message"
if $res->is_error or not length $data;
#13...........
},
'kis.def' => {
source => "kis",
params => "def",
expect => <<'#14...........',
dbmclose(%verb_delim);
undef %verb_delim;
dbmclose(%expanded);
undef %expanded;
#14...........
},
'kis.kis' => {
source => "kis",
params => "kis",
expect => <<'#15...........',
dbmclose(%verb_delim); undef %verb_delim;
dbmclose(%expanded); undef %expanded;
#15...........
},
'maths.def' => {
source => "maths",
params => "def",
expect => <<'#16...........',
$tmp =
$day - 32075 +
1461 * ( $year + 4800 - ( 14 - $month ) / 12 ) / 4 +
367 * ( $month - 2 + ( ( 14 - $month ) / 12 ) * 12 ) / 12 -
3 * ( ( $year + 4900 - ( 14 - $month ) / 12 ) / 100 ) / 4;
return ( $r**$n ) *
( pi**( $n / 2 ) ) /
(
sqrt(pi) *
factorial( 2 * ( int( $n / 2 ) ) + 2 ) /
factorial( int( $n / 2 ) + 1 ) /
( 4**( int( $n / 2 ) + 1 ) ) );
$root = -$b + sqrt( $b * $b - 4. * $a * $c ) / ( 2. * $a );
#16...........
},
'maths.maths1' => {
source => "maths",
params => "maths1",
expect => <<'#17...........',
$tmp
=$day-32075
+1461*( $year+4800-( 14-$month )/12 )/4
+367*( $month-2+( ( 14-$month )/12 )*12 )/12
-3*( ( $year+4900-( 14-$month )/12 )/100 )/4;
return ( $r**$n )
*( pi**( $n/2 ) )
/(
sqrt(pi)
*factorial( 2*( int( $n/2 ) )+2 )
/factorial( int( $n/2 )+1 )
/( 4**( int( $n/2 )+1 ) ) );
$root=-$b+sqrt( $b*$b-4.*$a*$c )/( 2.*$a );
#17...........
},
'maths.maths2' => {
source => "maths",
params => "maths2",
expect => <<'#18...........',
$tmp=
$day-32075+
1461*( $year+4800-( 14-$month )/12 )/4+
367*( $month-2+( ( 14-$month )/12 )*12 )/12-
3*( ( $year+4900-( 14-$month )/12 )/100 )/4;
return ( $r**$n )*
( pi**( $n/2 ) )/
(
sqrt(pi)*
factorial( 2*( int( $n/2 ) )+2 )/
factorial( int( $n/2 )+1 )/
( 4**( int( $n/2 )+1 ) ) );
$root=-$b+sqrt( $b*$b-4.*$a*$c )/( 2.*$a );
#18...........
},
'misc_tests.def' => {
source => "misc_tests",
params => "def",
expect => <<'#19...........',
for ( @a = @$ap, $u = shift @a ; @a ; $u = $v ) { ... } # test -sfs
$i = 1; # test -sts
$i = 0; ## =1; test -ssc
; # test -ndsm
my ( $a, $b, $c ) = @_; # test -nsak="my for"
#19...........
},
};
my $ntests = 0 + keys %{$rtests};
plan tests => $ntests;
}
###############
# EXECUTE TESTS
###############
foreach my $key ( sort keys %{$rtests} ) {
my $output;
my $sname = $rtests->{$key}->{source};
my $expect = $rtests->{$key}->{expect};
my $pname = $rtests->{$key}->{params};
my $source = $rsources->{$sname};
my $params = defined($pname) ? $rparams->{$pname} : "";
my $stderr_string;
my $errorfile_string;
my $err = Perl::Tidy::perltidy(
source => \$source,
destination => \$output,
perltidyrc => \$params,
argv => '', # for safety; hide any ARGV from perltidy
stderr => \$stderr_string,
errorfile => \$errorfile_string, # not used when -se flag is set
);
if ( $err || $stderr_string || $errorfile_string ) {
print STDERR "Error output received for test '$key'\n";
if ($err) {
print STDERR "An error flag '$err' was returned\n";
ok( !$err );
}
if ($stderr_string) {
print STDERR "---------------------\n";
print STDERR "<>\n$stderr_string\n";
print STDERR "---------------------\n";
ok( !$stderr_string );
}
if ($errorfile_string) {
print STDERR "---------------------\n";
print STDERR "<<.ERR file>>\n$errorfile_string\n";
print STDERR "---------------------\n";
ok( !$errorfile_string );
}
}
else {
if ( !is( $output, $expect, $key ) ) {
my $leno = length($output);
my $lene = length($expect);
if ( $leno == $lene ) {
print STDERR
"#> Test '$key' gave unexpected output. Strings differ but both have length $leno\n";
}
else {
print STDERR
"#> Test '$key' gave unexpected output. String lengths differ: output=$leno, expected=$lene\n";
}
}
}
}
Perl-Tidy-20210717/t/snippets17.t 0000644 0001750 0001750 00000073470 14072572631 015315 0 ustar steve steve # Created with: ./make_t.pl
# Contents:
#1 align32.def
#2 bos.bos
#3 bos.def
#4 comments.comments1
#5 comments.comments2
#6 comments.comments3
#7 comments.comments4
#8 comments.def
#9 long_line.def
#10 long_line.long_line
#11 pbp6.def
#12 pbp6.pbp
#13 rperl.def
#14 rperl.rperl
#15 rt132059.def
#16 rt132059.rt132059
#17 signature.def
#18 ternary4.def
#19 wn7.def
# To locate test #13 you can search for its name or the string '#13'
use strict;
use Test::More;
use Carp;
use Perl::Tidy;
my $rparams;
my $rsources;
my $rtests;
BEGIN {
###########################################
# BEGIN SECTION 1: Parameter combinations #
###########################################
$rparams = {
'bos' => "-bos",
'comments1' => <<'----------',
# testing --fixed-position-side-comment=40,
# --ignore-side-comment-lengths,
# --noindent-block-comments,
# --nohanging-side-comments
# --static-side-comments
# --trim-pod
-fpsc=40 -iscl -nibc -nhsc -ssc -trp
----------
'comments2' => <<'----------',
# testing --minimum-space-to-comment=10, --delete-block-comments, --delete-pod
-msc=10 -dbc -dp
----------
'comments3' => <<'----------',
# testing --maximum-consecutive-blank-lines=2 and --indent-spaced-block-comments --no-format-skipping
-mbl=2 -isbc -nfs
----------
'comments4' => <<'----------',
# testing --keep-old-blank-lines=2 [=all] and
# --nooutdent-long-comments and
# --outdent-static-block-comments
# --format-skipping-begin and --format-skipping-end
-kbl=2 -nolc -osbc -fsb='#<{2,}' -fse='#>{2,}'
----------
'def' => "",
'long_line' => "-l=0",
'pbp' => "-pbp -nst -nse",
'rperl' =>
"-pbp -nst --ignore-side-comment-lengths --converge -l=0 -q",
'rt132059' => "-dac",
};
############################
# BEGIN SECTION 2: Sources #
############################
$rsources = {
'align32' => <<'----------',
# should not get alignment here:
my $c_sub_khwnd = WindowFromId $k_hwnd, 0x8008; # FID_CLIENT
ok $c_sub_khwnd, 'have kids client window';
ok IsWindow($c_sub_khwnd), 'IsWindow works on the client';
----------
'bos' => <<'----------',
$top_label->set_text( gettext("check permissions.") )
;
----------
'comments' => <<'----------',
#!/usr/bin/perl -w
# an initial hash bang line cannot be deleted with -dp
#<<< format skipping of first code can cause an error message in perltidy v20210625
my $rvar = [ [ 1, 2, 3 ], [ 4, 5, 6 ] ];
#>>>
sub length { return length($_[0]) } # side comment
# hanging side comment
# very longgggggggggggggggggggggggggggggggggggggggggggggggggggg hanging side comment
# a blank will be inserted to prevent forming a hanging side comment
sub macro_get_names { #
#
# %name = macro_get_names(); (key=macrohandle, value=macroname)
#
##local(%name); # a static block comment without indentation
local(%name)=(); ## a static side comment to test -ssc
# a spaced block comment to test -isbc
for (0..$#mac_ver) {
# a very long comment for testing the parameter --nooutdent-long-comments (or -nolc)
$name{$_} = $mac_ext[$idx{$mac_exti[$_]}];
$vmsfile =~ s/;[\d\-]*$//; # very long side comment; Clip off version number; we can use a newer version as well
}
%name;
}
@month_of_year = (
'Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun', 'Jul', 'Aug', 'Sep', 'Oct',
## 'Dec', 'Nov' [a static block comment with indentation]
'Nov', 'Dec');
{ # this side comment will not align
my $IGNORE = 0; # This is a side comment
# This is a hanging side comment
# And so is this
# A blank line interrupts the hsc's; this is a block comment
}
# side comments at different indentation levels should not normally be aligned
{ { { { { ${msg} = "Hello World!"; print "My message: ${msg}\n"; } } #end level 4
} # end level 3
} # end level 2
} # end level 1
#<<< do not let perltidy touch this unless -nfs is set
my @list = (1,
1, 1,
1, 2, 1,
1, 3, 3, 1,
1, 4, 6, 4, 1,);
#>>>
#<< test alternate format skipping string
my @list = (1,
1, 1,
1, 2, 1,
1, 3, 3, 1,
1, 4, 6, 4, 1,);
#>>
# some blank lines follow
=pod
Some pod before __END__ to delete with -dp
=cut
__END__
# text following __END__, not a comment
=pod
Some pod after __END__ to delete with -dp and trim with -trp
=cut
----------
'long_line' => <<'----------',
# This single line should break into multiple lines, even with -l=0
# sub 'tight_paren_follows' should break the do block
$body = SOAP::Data->name('~V:Fault')->attr( { 'xmlns' => $SOAP::Constants::NS_ENV } )->value( \SOAP::Data->set_value( SOAP::Data->name( faultcode => qualify( $self->namespace => shift(@parameters) ) ), SOAP::Data->name( faultstring => shift(@parameters) ), @parameters ? SOAP::Data->name( detail => do { my $detail = shift(@parameters); ref $detail ? \$detail : $detail } ) : (), @parameters ? SOAP::Data->name( faultactor => shift(@parameters) ) : (), ) );
----------
'pbp6' => <<'----------',
# These formerly blinked with -pbp
return $width1*$common_length*(
$W*atan2(1,$W)
+ $H*atan2(1,$H)
- $RTHSQPWSQ*atan2(1,$RTHSQPWSQ)
+ 0.25*log(
($WSQP1*$HSQP1)/(1+$WSQ+$HSQ)
*($WSQ*(1+$WSQ+$HSQ)/($WSQP1*$HSQPWSQ))**$WSQ
*($HSQ*(1+$WSQ+$HSQ)/($HSQP1*$HSQPWSQ))**$HSQ
)
)/($W*$pi);
my $oldSec = ( 60 * $session->{originalStartHour} + $session->{originalStartMin} ) * 60;
----------
'rperl' => <<'----------',
# Some test cases for RPerl, https://github.com/wbraswell/rperl/
# These must not remain as single lines with default formatting and long lines
sub multiply_return_F { { my number $RETURN_TYPE }; ( my integer $multiplicand, my number $multiplier ) = @ARG; return $multiplicand * $multiplier; }
sub empty_method { { my void::method $RETURN_TYPE }; return 2; }
sub foo_subroutine_in_main { { my void $RETURN_TYPE }; print 'Howdy from foo_subroutine_in_main()...', "\n"; return; }
----------
'rt132059' => <<'----------',
# Test deleting comments and pod
$1=2;
sub f { # a side comment
# a hanging side comment
# a block comment
}
=pod
bonjour!
=cut
$i++;
----------
'signature' => <<'----------',
# git22: Preserve function signature on a single line
# This behavior is controlled by 'sub weld_signature_parens'
sub foo($x, $y="abcd") {
$x.$y;
}
# do not break after closing do brace
sub foo($x, $y=do{{}}, $z=42, $w=do{"abcd"}) {
$x.$y.$z;
}
# This signature should get put back on one line
sub t022 (
$p = do { $z += 10; 222 }, $a = do { $z++; 333 }
) { "$p/$a" }
# anonymous sub with signature
my $subref = sub ( $cat, $id = do { state $auto_id = 0; $auto_id++ } ) {
...;
};
# signature and prototype and attribute
sub foo1 ( $x, $y ) : prototype ( $$ ) : shared { }
sub foo11 ( $thing, % ) { print $thing }
sub animal4 ( $cat, $ = ) { } # second argument is optional
*share = sub
( \[$@%] ) { };
# extruded test
sub foo2
(
$
first
,
$
,
$
third
)
{
return
"first=$first, third=$third"
;
}
# valid attributes
sub fnord (&\%) : switch(10,foo(7,3)) : expensive;
sub plugh () : Ugly('\(") : Bad;
----------
'ternary4' => <<'----------',
# some side comments
*{"${callpkg}::$sym"} =
$type eq '&' ? \&{"${pkg}::$sym"} #
: $type eq '$' ? \${"${pkg}::$sym"} #
: $type eq '@' ? \@{"${pkg}::$sym"}
: $type eq '%' ? \%{"${pkg}::$sym"} # side comment
: $type eq '*' ? *{"${pkg}::$sym"} #
: do { require Carp; Carp::croak("Can't export symbol: $type$sym") };
----------
'wn7' => <<'----------',
# do not weld paren to opening one-line non-paren container
$Self->_Add($SortOrderDisplay{$Field->GenerateFieldForSelectSQL()});
# this will not get welded with -wn
f(
do { 1; !!(my $x = bless []); }
);
----------
};
####################################
# BEGIN SECTION 3: Expected output #
####################################
$rtests = {
'align32.def' => {
source => "align32",
params => "def",
expect => <<'#1...........',
# should not get alignment here:
my $c_sub_khwnd = WindowFromId $k_hwnd, 0x8008; # FID_CLIENT
ok $c_sub_khwnd, 'have kids client window';
ok IsWindow($c_sub_khwnd), 'IsWindow works on the client';
#1...........
},
'bos.bos' => {
source => "bos",
params => "bos",
expect => <<'#2...........',
$top_label->set_text( gettext("check permissions.") )
;
#2...........
},
'bos.def' => {
source => "bos",
params => "def",
expect => <<'#3...........',
$top_label->set_text( gettext("check permissions.") );
#3...........
},
'comments.comments1' => {
source => "comments",
params => "comments1",
expect => <<'#4...........',
#!/usr/bin/perl -w
# an initial hash bang line cannot be deleted with -dp
#<<< format skipping of first code can cause an error message in perltidy v20210625
my $rvar = [ [ 1, 2, 3 ], [ 4, 5, 6 ] ];
#>>>
sub length { return length( $_[0] ) } # side comment
# hanging side comment
# very longgggggggggggggggggggggggggggggggggggggggggggggggggggg hanging side comment
# a blank will be inserted to prevent forming a hanging side comment
sub macro_get_names { #
#
# %name = macro_get_names(); (key=macrohandle, value=macroname)
#
##local(%name); # a static block comment without indentation
local (%name) = (); ## a static side comment to test -ssc
# a spaced block comment to test -isbc
for ( 0 .. $#mac_ver ) {
# a very long comment for testing the parameter --nooutdent-long-comments (or -nolc)
$name{$_} = $mac_ext[ $idx{ $mac_exti[$_] } ];
$vmsfile =~ s/;[\d\-]*$//; # very long side comment; Clip off version number; we can use a newer version as well
}
%name;
}
@month_of_year = (
'Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun', 'Jul', 'Aug', 'Sep', 'Oct',
## 'Dec', 'Nov' [a static block comment with indentation]
'Nov', 'Dec'
);
{ # this side comment will not align
my $IGNORE = 0; # This is a side comment
# This is a hanging side comment
# And so is this
# A blank line interrupts the hsc's; this is a block comment
}
# side comments at different indentation levels should not normally be aligned
{
{
{
{
{ ${msg} = "Hello World!"; print "My message: ${msg}\n"; }
} #end level 4
} # end level 3
} # end level 2
} # end level 1
#<<< do not let perltidy touch this unless -nfs is set
my @list = (1,
1, 1,
1, 2, 1,
1, 3, 3, 1,
1, 4, 6, 4, 1,);
#>>>
#<< test alternate format skipping string
my @list = ( 1, 1, 1, 1, 2, 1, 1, 3, 3, 1, 1, 4, 6, 4, 1, );
#>>
# some blank lines follow
=pod
Some pod before __END__ to delete with -dp
=cut
__END__
# text following __END__, not a comment
=pod
Some pod after __END__ to delete with -dp and trim with -trp
=cut
#4...........
},
'comments.comments2' => {
source => "comments",
params => "comments2",
expect => <<'#5...........',
#!/usr/bin/perl -w
#<<< format skipping of first code can cause an error message in perltidy v20210625
my $rvar = [ [ 1, 2, 3 ], [ 4, 5, 6 ] ];
#>>>
sub length { return length( $_[0] ) } # side comment
# hanging side comment
# very longgggggggggggggggggggggggggggggggggggggggggggggggggggg hanging side comment
sub macro_get_names { #
local (%name) = (); ## a static side comment to test -ssc
for ( 0 .. $#mac_ver ) {
$name{$_} = $mac_ext[ $idx{ $mac_exti[$_] } ];
$vmsfile =~ s/;[\d\-]*$//
; # very long side comment; Clip off version number; we can use a newer version as well
}
%name;
}
@month_of_year = (
'Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun', 'Jul', 'Aug', 'Sep', 'Oct',
'Nov', 'Dec'
);
{ # this side comment will not align
my $IGNORE = 0; # This is a side comment
# This is a hanging side comment
# And so is this
}
{
{
{
{
{ ${msg} = "Hello World!"; print "My message: ${msg}\n"; }
} #end level 4
} # end level 3
} # end level 2
} # end level 1
#<<< do not let perltidy touch this unless -nfs is set
my @list = (1,
1, 1,
1, 2, 1,
1, 3, 3, 1,
1, 4, 6, 4, 1,);
#>>>
my @list = ( 1, 1, 1, 1, 2, 1, 1, 3, 3, 1, 1, 4, 6, 4, 1, );
__END__
# text following __END__, not a comment
#5...........
},
'comments.comments3' => {
source => "comments",
params => "comments3",
expect => <<'#6...........',
#!/usr/bin/perl -w
# an initial hash bang line cannot be deleted with -dp
#<<< format skipping of first code can cause an error message in perltidy v20210625
my $rvar = [ [ 1, 2, 3 ], [ 4, 5, 6 ] ];
#>>>
sub length { return length( $_[0] ) } # side comment
# hanging side comment
# very longgggggggggggggggggggggggggggggggggggggggggggggggggggg hanging side comment
# a blank will be inserted to prevent forming a hanging side comment
sub macro_get_names { #
#
# %name = macro_get_names(); (key=macrohandle, value=macroname)
#
##local(%name); # a static block comment without indentation
local (%name) = (); ## a static side comment to test -ssc
# a spaced block comment to test -isbc
for ( 0 .. $#mac_ver ) {
# a very long comment for testing the parameter --nooutdent-long-comments (or -nolc)
$name{$_} = $mac_ext[ $idx{ $mac_exti[$_] } ];
$vmsfile =~ s/;[\d\-]*$//
; # very long side comment; Clip off version number; we can use a newer version as well
}
%name;
}
@month_of_year = (
'Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun', 'Jul', 'Aug', 'Sep', 'Oct',
## 'Dec', 'Nov' [a static block comment with indentation]
'Nov', 'Dec'
);
{ # this side comment will not align
my $IGNORE = 0; # This is a side comment
# This is a hanging side comment
# And so is this
# A blank line interrupts the hsc's; this is a block comment
}
# side comments at different indentation levels should not normally be aligned
{
{
{
{
{ ${msg} = "Hello World!"; print "My message: ${msg}\n"; }
} #end level 4
} # end level 3
} # end level 2
} # end level 1
#<<< do not let perltidy touch this unless -nfs is set
my @list = ( 1, 1, 1, 1, 2, 1, 1, 3, 3, 1, 1, 4, 6, 4, 1, );
#>>>
#<< test alternate format skipping string
my @list = ( 1, 1, 1, 1, 2, 1, 1, 3, 3, 1, 1, 4, 6, 4, 1, );
#>>
# some blank lines follow
=pod
Some pod before __END__ to delete with -dp
=cut
__END__
# text following __END__, not a comment
=pod
Some pod after __END__ to delete with -dp and trim with -trp
=cut
#6...........
},
'comments.comments4' => {
source => "comments",
params => "comments4",
expect => <<'#7...........',
#!/usr/bin/perl -w
# an initial hash bang line cannot be deleted with -dp
#<<< format skipping of first code can cause an error message in perltidy v20210625
my $rvar = [ [ 1, 2, 3 ], [ 4, 5, 6 ] ];
#>>>
sub length { return length( $_[0] ) } # side comment
# hanging side comment
# very longgggggggggggggggggggggggggggggggggggggggggggggggggggg hanging side comment
# a blank will be inserted to prevent forming a hanging side comment
sub macro_get_names { #
#
# %name = macro_get_names(); (key=macrohandle, value=macroname)
#
##local(%name); # a static block comment without indentation
local (%name) = (); ## a static side comment to test -ssc
# a spaced block comment to test -isbc
for ( 0 .. $#mac_ver ) {
# a very long comment for testing the parameter --nooutdent-long-comments (or -nolc)
$name{$_} = $mac_ext[ $idx{ $mac_exti[$_] } ];
$vmsfile =~ s/;[\d\-]*$//
; # very long side comment; Clip off version number; we can use a newer version as well
}
%name;
}
@month_of_year = (
'Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun', 'Jul', 'Aug', 'Sep', 'Oct',
## 'Dec', 'Nov' [a static block comment with indentation]
'Nov', 'Dec'
);
{ # this side comment will not align
my $IGNORE = 0; # This is a side comment
# This is a hanging side comment
# And so is this
# A blank line interrupts the hsc's; this is a block comment
}
# side comments at different indentation levels should not normally be aligned
{
{
{
{
{ ${msg} = "Hello World!"; print "My message: ${msg}\n"; }
} #end level 4
} # end level 3
} # end level 2
} # end level 1
#<<< do not let perltidy touch this unless -nfs is set
my @list = (1,
1, 1,
1, 2, 1,
1, 3, 3, 1,
1, 4, 6, 4, 1,);
#>>>
#<< test alternate format skipping string
my @list = (1,
1, 1,
1, 2, 1,
1, 3, 3, 1,
1, 4, 6, 4, 1,);
#>>
# some blank lines follow
=pod
Some pod before __END__ to delete with -dp
=cut
__END__
# text following __END__, not a comment
=pod
Some pod after __END__ to delete with -dp and trim with -trp
=cut
#7...........
},
'comments.def' => {
source => "comments",
params => "def",
expect => <<'#8...........',
#!/usr/bin/perl -w
# an initial hash bang line cannot be deleted with -dp
#<<< format skipping of first code can cause an error message in perltidy v20210625
my $rvar = [ [ 1, 2, 3 ], [ 4, 5, 6 ] ];
#>>>
sub length { return length( $_[0] ) } # side comment
# hanging side comment
# very longgggggggggggggggggggggggggggggggggggggggggggggggggggg hanging side comment
# a blank will be inserted to prevent forming a hanging side comment
sub macro_get_names { #
#
# %name = macro_get_names(); (key=macrohandle, value=macroname)
#
##local(%name); # a static block comment without indentation
local (%name) = (); ## a static side comment to test -ssc
# a spaced block comment to test -isbc
for ( 0 .. $#mac_ver ) {
# a very long comment for testing the parameter --nooutdent-long-comments (or -nolc)
$name{$_} = $mac_ext[ $idx{ $mac_exti[$_] } ];
$vmsfile =~ s/;[\d\-]*$//
; # very long side comment; Clip off version number; we can use a newer version as well
}
%name;
}
@month_of_year = (
'Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun', 'Jul', 'Aug', 'Sep', 'Oct',
## 'Dec', 'Nov' [a static block comment with indentation]
'Nov', 'Dec'
);
{ # this side comment will not align
my $IGNORE = 0; # This is a side comment
# This is a hanging side comment
# And so is this
# A blank line interrupts the hsc's; this is a block comment
}
# side comments at different indentation levels should not normally be aligned
{
{
{
{
{ ${msg} = "Hello World!"; print "My message: ${msg}\n"; }
} #end level 4
} # end level 3
} # end level 2
} # end level 1
#<<< do not let perltidy touch this unless -nfs is set
my @list = (1,
1, 1,
1, 2, 1,
1, 3, 3, 1,
1, 4, 6, 4, 1,);
#>>>
#<< test alternate format skipping string
my @list = ( 1, 1, 1, 1, 2, 1, 1, 3, 3, 1, 1, 4, 6, 4, 1, );
#>>
# some blank lines follow
=pod
Some pod before __END__ to delete with -dp
=cut
__END__
# text following __END__, not a comment
=pod
Some pod after __END__ to delete with -dp and trim with -trp
=cut
#8...........
},
'long_line.def' => {
source => "long_line",
params => "def",
expect => <<'#9...........',
# This single line should break into multiple lines, even with -l=0
# sub 'tight_paren_follows' should break the do block
$body =
SOAP::Data->name('~V:Fault')->attr( { 'xmlns' => $SOAP::Constants::NS_ENV } )
->value(
\SOAP::Data->set_value(
SOAP::Data->name(
faultcode => qualify( $self->namespace => shift(@parameters) )
),
SOAP::Data->name( faultstring => shift(@parameters) ),
@parameters
? SOAP::Data->name(
detail => do {
my $detail = shift(@parameters);
ref $detail ? \$detail : $detail;
}
)
: (),
@parameters ? SOAP::Data->name( faultactor => shift(@parameters) ) : (),
)
);
#9...........
},
'long_line.long_line' => {
source => "long_line",
params => "long_line",
expect => <<'#10...........',
# This single line should break into multiple lines, even with -l=0
# sub 'tight_paren_follows' should break the do block
$body = SOAP::Data->name('~V:Fault')->attr( { 'xmlns' => $SOAP::Constants::NS_ENV } )->value(
\SOAP::Data->set_value(
SOAP::Data->name( faultcode => qualify( $self->namespace => shift(@parameters) ) ),
SOAP::Data->name( faultstring => shift(@parameters) ),
@parameters
? SOAP::Data->name(
detail => do { my $detail = shift(@parameters); ref $detail ? \$detail : $detail }
)
: (),
@parameters ? SOAP::Data->name( faultactor => shift(@parameters) ) : (),
)
);
#10...........
},
'pbp6.def' => {
source => "pbp6",
params => "def",
expect => <<'#11...........',
# These formerly blinked with -pbp
return $width1 *
$common_length *
(
$W * atan2( 1, $W ) +
$H * atan2( 1, $H ) -
$RTHSQPWSQ * atan2( 1, $RTHSQPWSQ ) +
0.25 * log(
( $WSQP1 * $HSQP1 ) /
( 1 + $WSQ + $HSQ ) *
( $WSQ * ( 1 + $WSQ + $HSQ ) / ( $WSQP1 * $HSQPWSQ ) )
**$WSQ *
( $HSQ * ( 1 + $WSQ + $HSQ ) / ( $HSQP1 * $HSQPWSQ ) )**$HSQ
)
) /
( $W * $pi );
my $oldSec =
( 60 * $session->{originalStartHour} + $session->{originalStartMin} )
* 60;
#11...........
},
'pbp6.pbp' => {
source => "pbp6",
params => "pbp",
expect => <<'#12...........',
# These formerly blinked with -pbp
return
$width1 * $common_length
* (
$W * atan2( 1, $W )
+ $H * atan2( 1, $H )
- $RTHSQPWSQ * atan2( 1, $RTHSQPWSQ )
+ 0.25 * log(
( $WSQP1 * $HSQP1 )
/ ( 1 + $WSQ + $HSQ )
* ( $WSQ * ( 1 + $WSQ + $HSQ ) / ( $WSQP1 * $HSQPWSQ ) )
**$WSQ
* ( $HSQ * ( 1 + $WSQ + $HSQ ) / ( $HSQP1 * $HSQPWSQ ) )
**$HSQ
)
)
/ ( $W * $pi );
my $oldSec
= ( 60 * $session->{originalStartHour}
+ $session->{originalStartMin} )
* 60;
#12...........
},
'rperl.def' => {
source => "rperl",
params => "def",
expect => <<'#13...........',
# Some test cases for RPerl, https://github.com/wbraswell/rperl/
# These must not remain as single lines with default formatting and long lines
sub multiply_return_F {
{ my number $RETURN_TYPE };
( my integer $multiplicand, my number $multiplier ) = @ARG;
return $multiplicand * $multiplier;
}
sub empty_method {
{ my void::method $RETURN_TYPE };
return 2;
}
sub foo_subroutine_in_main {
{ my void $RETURN_TYPE };
print 'Howdy from foo_subroutine_in_main()...', "\n";
return;
}
#13...........
},
'rperl.rperl' => {
source => "rperl",
params => "rperl",
expect => <<'#14...........',
# Some test cases for RPerl, https://github.com/wbraswell/rperl/
# These must not remain as single lines with default formatting and long lines
sub multiply_return_F {
{ my number $RETURN_TYPE };
( my integer $multiplicand, my number $multiplier ) = @ARG;
return $multiplicand * $multiplier;
}
sub empty_method {
{ my void::method $RETURN_TYPE };
return 2;
}
sub foo_subroutine_in_main {
{ my void $RETURN_TYPE };
print 'Howdy from foo_subroutine_in_main()...', "\n";
return;
}
#14...........
},
'rt132059.def' => {
source => "rt132059",
params => "def",
expect => <<'#15...........',
# Test deleting comments and pod
$1 = 2;
sub f { # a side comment
# a hanging side comment
# a block comment
}
=pod
bonjour!
=cut
$i++;
#15...........
},
'rt132059.rt132059' => {
source => "rt132059",
params => "rt132059",
expect => <<'#16...........',
$1 = 2;
sub f {
}
$i++;
#16...........
},
'signature.def' => {
source => "signature",
params => "def",
expect => <<'#17...........',
# git22: Preserve function signature on a single line
# This behavior is controlled by 'sub weld_signature_parens'
sub foo ( $x, $y = "abcd" ) {
$x . $y;
}
# do not break after closing do brace
sub foo ( $x, $y = do { {} }, $z = 42, $w = do { "abcd" } ) {
$x . $y . $z;
}
# This signature should get put back on one line
sub t022 ( $p = do { $z += 10; 222 }, $a = do { $z++; 333 } ) { "$p/$a" }
# anonymous sub with signature
my $subref = sub ( $cat, $id = do { state $auto_id = 0; $auto_id++ } ) {
...;
};
# signature and prototype and attribute
sub foo1 ( $x, $y ) : prototype ( $$ ) : shared { }
sub foo11 ( $thing, % ) { print $thing }
sub animal4 ( $cat, $ = ) { } # second argument is optional
*share = sub ( \[$@%] ) { };
# extruded test
sub foo2 ( $first, $, $third ) {
return "first=$first, third=$third";
}
# valid attributes
sub fnord (&\%) : switch(10,foo(7,3)) : expensive;
sub plugh () : Ugly('\(") : Bad;
#17...........
},
'ternary4.def' => {
source => "ternary4",
params => "def",
expect => <<'#18...........',
# some side comments
*{"${callpkg}::$sym"} = $type eq '&' ? \&{"${pkg}::$sym"} #
: $type eq '$' ? \${"${pkg}::$sym"} #
: $type eq '@' ? \@{"${pkg}::$sym"}
: $type eq '%' ? \%{"${pkg}::$sym"} # side comment
: $type eq '*' ? *{"${pkg}::$sym"} #
: do { require Carp; Carp::croak("Can't export symbol: $type$sym") };
#18...........
},
'wn7.def' => {
source => "wn7",
params => "def",
expect => <<'#19...........',
# do not weld paren to opening one-line non-paren container
$Self->_Add(
$SortOrderDisplay{
$Field->GenerateFieldForSelectSQL()
}
);
# this will not get welded with -wn
f(
do { 1; !!( my $x = bless [] ); }
);
#19...........
},
};
my $ntests = 0 + keys %{$rtests};
plan tests => $ntests;
}
###############
# EXECUTE TESTS
###############
foreach my $key ( sort keys %{$rtests} ) {
my $output;
my $sname = $rtests->{$key}->{source};
my $expect = $rtests->{$key}->{expect};
my $pname = $rtests->{$key}->{params};
my $source = $rsources->{$sname};
my $params = defined($pname) ? $rparams->{$pname} : "";
my $stderr_string;
my $errorfile_string;
my $err = Perl::Tidy::perltidy(
source => \$source,
destination => \$output,
perltidyrc => \$params,
argv => '', # for safety; hide any ARGV from perltidy
stderr => \$stderr_string,
errorfile => \$errorfile_string, # not used when -se flag is set
);
if ( $err || $stderr_string || $errorfile_string ) {
print STDERR "Error output received for test '$key'\n";
if ($err) {
print STDERR "An error flag '$err' was returned\n";
ok( !$err );
}
if ($stderr_string) {
print STDERR "---------------------\n";
print STDERR "<>\n$stderr_string\n";
print STDERR "---------------------\n";
ok( !$stderr_string );
}
if ($errorfile_string) {
print STDERR "---------------------\n";
print STDERR "<<.ERR file>>\n$errorfile_string\n";
print STDERR "---------------------\n";
ok( !$errorfile_string );
}
}
else {
if ( !is( $output, $expect, $key ) ) {
my $leno = length($output);
my $lene = length($expect);
if ( $leno == $lene ) {
print STDERR
"#> Test '$key' gave unexpected output. Strings differ but both have length $leno\n";
}
else {
print STDERR
"#> Test '$key' gave unexpected output. String lengths differ: output=$leno, expected=$lene\n";
}
}
}
}
Perl-Tidy-20210717/t/snippets21.t 0000644 0001750 0001750 00000053570 14072572631 015307 0 ustar steve steve # Created with: ./make_t.pl
# Contents:
#1 lop.lop
#2 switch_plain.def
#3 switch_plain.switch_plain
#4 sot.def
#5 sot.sot
#6 prune.def
#7 align33.def
#8 gnu7.def
#9 gnu7.gnu
#10 git33.def
#11 git33.git33
#12 rt133130.def
#13 rt133130.rt133130
#14 nib.def
#15 nib.nib1
#16 nib.nib2
#17 scbb-csc.def
#18 scbb-csc.scbb-csc
#19 here_long.def
# To locate test #13 you can search for its name or the string '#13'
use strict;
use Test::More;
use Carp;
use Perl::Tidy;
my $rparams;
my $rsources;
my $rtests;
BEGIN {
###########################################
# BEGIN SECTION 1: Parameter combinations #
###########################################
$rparams = {
'def' => "",
'git33' => <<'----------',
-wls='->' -wrs='->'
----------
'gnu' => "-gnu",
'lop' => "-nlop",
'nib1' => "-nnib",
'nib2' => <<'----------',
-nib -nibp='#\+\+'
----------
'rt133130' => <<'----------',
# only the method should get a csc:
-csc -cscl=sub -sal=method
----------
'scbb-csc' => "-scbb -csc",
'sot' => "-sot -sct",
'switch_plain' => "-nola",
};
############################
# BEGIN SECTION 2: Sources #
############################
$rsources = {
'align33' => <<'----------',
$wl = int( $wl * $f + .5 );
$wr = int( $wr * $f + .5 );
$pag = int( $pageh * $f + .5 );
$fe = $opt_F ? "t" : "f";
$cf = $opt_U ? "t" : "f";
$tp = $opt_t ? "t" : "f";
$rm = $numbstyle ? "t" : "f";
$pa = $showurl ? "t" : "f";
$nh = $seq_number ? "t" : "f";
----------
'git33' => <<'----------',
# test -wls='->' -wrs='->'
use Net::Ping;
my ($ping) = Net::Ping->new();
$ping->ping($host);
----------
'gnu7' => <<'----------',
# hanging side comments
if ( $seen == 1 ) { # We're the first word so far to have
# this abbreviation.
$hashref->{$abbrev} = $word;
}
elsif ( $seen == 2 ) { # We're the second word to have this
# abbreviation, so we can't use it.
delete $hashref->{$abbrev};
}
else { # We're the third word to have this
# abbreviation, so skip to the next word.
next WORD;
}
----------
'here_long' => <<'----------',
# must not break after here target regardless of maximum-line-length
$sth= $dbh->prepare (<<"END_OF_SELECT") or die "Couldn't prepare SQL" ;
SELECT COUNT(duration),SUM(duration)
FROM logins WHERE username='$user'
END_OF_SELECT
----------
'lop' => <<'----------',
# logical padding examples
$same =
( ( $aP eq $bP )
&& ( $aS eq $bS )
&& ( $aT eq $bT )
&& ( $a->{'title'} eq $b->{'title'} )
&& ( $a->{'href'} eq $b->{'href'} ) );
$bits =
$top > 0xffff ? 32
: $top > 0xff ? 16
: $top > 1 ? 8
: 1;
lc( $self->mime_attr('content-type')
|| $self->{MIH_DefaultType}
|| 'text/plain' );
# Padding can also remove spaces; here the space after the '(' is lost:
elsif ( $statement_type =~ /^sub\b/
|| $paren_type[$paren_depth] =~ /^sub\b/ )
----------
'nib' => <<'----------',
{ #<<<
{ #<<<
{ #++
print "hello world\n";
}
}
}
{ #++
{ #++
{ #<<<
print "hello world\n";
}
}
}
----------
'prune' => <<'----------',
# some tests for 'sub prune_alignment_tree'
$request->header( 'User-Agent' => $agent ) if $agent;
$request->header( 'From' => $from ) if $from;
$request->header( 'Range' => "bytes=0-$max_size" ) if $max_size;
for (
[ 'CONSTANT', sub { join "foo", "bar" }, 0, "bar" ],
[ 'CONSTANT', sub { join "foo", "bar", 3 }, 1, "barfoo3" ],
[ '$var', sub { join $_, "bar" }, 0, "bar" ],
[ '$myvar', sub { my $var; join $var, "bar" }, 0, "bar" ],
);
[
[ [NewXSHdr], [ NewXSName, NewXSArgs ], "XSHdr" ],
[ [NewXSCHdrs], [ NewXSName, NewXSArgs, GlobalNew ], "XSCHdrs" ],
[ [DefSyms], [StructName], "MkDefSyms" ],
[ [NewXSSymTab], [ DefSyms, NewXSArgs ], "AddArgsyms" ],
[ [NewXSLocals], [NewXSSymTab], "Sym2Loc" ],
[ [IsAffineFlag], [], sub { return "0" } ],
];
@degen_nums[ 1, 2, 4, 8 ] = ( 'a', 'c', 'g', 't' );
@degen_nums[ 5, 10, 9, 6, 3, 12 ] = ( 'r', 'y', 'w', 's', 'm', 'k' );
@degen_nums[ 14, 13, 11, 7, 15 ] = ( 'b', 'd', 'h', 'v', 'n' );
$_CreateFile = ff( "k32", "CreateFile", [ P, N, N, N, N, N, N ], N );
$_CloseHandle = ff( "k32", "CloseHandle", [N], N );
$_GetCommState = ff( "k32", "GetCommState", [ N, P ], I );
$_SetCommState = ff( "k32", "SetCommState", [ N, P ], I );
$_SetupComm = ff( "k32", "SetupComm", [ N, N, N ], I );
$_PurgeComm = ff( "k32", "PurgeComm", [ N, N ], I );
$_CreateEvent = ff( "k32", "CreateEvent", [ P, I, I, P ], N );
is_deeply \@t, [
[3], [0], [1], [0],
3, [1], 3, [1],
2, [0], [1], [0],
[1], [1], [1], 2,
3, [1], 2, [3],
4, [ 7, 8 ], 9, ["a"],
"b", 3, 2, 5,
3, 2, 5, 3,
[2], 5, 4, 5,
[ 3, 2, 1 ], 1, 2, 3,
[ -1, -2, -3 ], [ -1, -2, -3 ], [ -1, -2, -3 ], [ -1, -2 ],
3, [ -1, -2 ], 3, [ -1, -2, -3 ],
[ !1 ], [ 8, 7, 6 ], [ 8, 7, 6 ], [4],
!!0,
];
----------
'rt133130' => <<'----------',
method sum_radlinks {
my ( $global_radiation_matrix, $local_radiation_matrix, $rngg ) = @_;
my ( $i, $j, $n1, $n2, $num );
my $rggij;
$num = @$rngg;
for ( $i = 0 ; $i < $num ; $i++ ) {
$n1 = $rngg->[$i];
for ( $j = 0 ; $j < $num ; $j++ ) {
$n2 = $rngg->[$j];
$rggij = $local_radiation_matrix->[$i][$j];
if ( $rggij && ( $n1 != $n2 ) ) {
$global_radiation_matrix->[$n1][$n2] += $rggij;
}
}
}
}
----------
'scbb-csc' => <<'----------',
sub perlmod_install_advice
{
my(@mod) = @_;
if ($auto_install_cpan) {
require AutoInstall::Tk;
my $r = AutoInstall::Tk::do_autoinstall_tk(@mod);
if ($r > 0) {
for my $mod (@mod) {
warn "Re-require $mod...\n";
eval "require $mod";
die __LINE__ . ": $@" if $@;
}}
}
else {
my $shell = ($os eq 'win' ? M"Eingabeaufforderung" : M"Shell");
status_message
(
Mfmt(
(
@mod > 1
? "Die fehlenden Perl-Module können aus der %s mit dem Kommando\n"
: "Das fehlende Perl-Modul kann aus der %s mit dem Kommando\n"
),
$shell
)
.
" perl -MCPAN -e \"install " . join(", ", @mod) . "\"\n" .
"aus dem Internet geholt und installiert werden.\n",
"err"
);
}
}
----------
'sot' => <<'----------',
$opt_c = Text::CSV_XS->new(
{
binary => 1, sep_char => $opt_c, always_quote => 1,
}
);
$c->Tk::bind(
'' => sub {
my ($c) = @_;
my $e = $c->XEvent;
itemsUnderArea $c;
} );
__PACKAGE__->load_components( qw(
PK::Auto
Core
) );
----------
'switch_plain' => <<'----------',
# run with -nola to keep default from outdenting
use Switch::Plain;
my $r = 'fail';
my $x = int rand 100_000;
nswitch (1 + $x * 2) {
case $x: {}
default: {
$r = 'ok';
}
}
my @words = qw(cinnamon ginger nutmeg cloves);
my $test = 1;
$r = $test
? do {
sswitch( $words[ rand @words ] ) {
case $words[0]:
case $words[1]:
case $words[2]:
case $words[3]: { 'ok' }
default: { 'default case' }
}
}
: 'not ok';
----------
};
####################################
# BEGIN SECTION 3: Expected output #
####################################
$rtests = {
'lop.lop' => {
source => "lop",
params => "lop",
expect => <<'#1...........',
# logical padding examples
$same =
( ( $aP eq $bP )
&& ( $aS eq $bS )
&& ( $aT eq $bT )
&& ( $a->{'title'} eq $b->{'title'} )
&& ( $a->{'href'} eq $b->{'href'} ) );
$bits =
$top > 0xffff ? 32
: $top > 0xff ? 16
: $top > 1 ? 8
: 1;
lc( $self->mime_attr('content-type')
|| $self->{MIH_DefaultType}
|| 'text/plain' );
# Padding can also remove spaces; here the space after the '(' is lost:
elsif ( $statement_type =~ /^sub\b/
|| $paren_type[$paren_depth] =~ /^sub\b/ )
#1...........
},
'switch_plain.def' => {
source => "switch_plain",
params => "def",
expect => <<'#2...........',
# run with -nola to keep default from outdenting
use Switch::Plain;
my $r = 'fail';
my $x = int rand 100_000;
nswitch( 1 + $x * 2 ) {
case $x: { }
default: {
$r = 'ok';
}
}
my @words = qw(cinnamon ginger nutmeg cloves);
my $test = 1;
$r = $test
? do {
sswitch( $words[ rand @words ] ) {
case $words[0]:
case $words[1]:
case $words[2]:
case $words[3]: { 'ok' }
default: { 'default case' }
}
}
: 'not ok';
#2...........
},
'switch_plain.switch_plain' => {
source => "switch_plain",
params => "switch_plain",
expect => <<'#3...........',
# run with -nola to keep default from outdenting
use Switch::Plain;
my $r = 'fail';
my $x = int rand 100_000;
nswitch( 1 + $x * 2 ) {
case $x: { }
default: {
$r = 'ok';
}
}
my @words = qw(cinnamon ginger nutmeg cloves);
my $test = 1;
$r = $test
? do {
sswitch( $words[ rand @words ] ) {
case $words[0]:
case $words[1]:
case $words[2]:
case $words[3]: { 'ok' }
default: { 'default case' }
}
}
: 'not ok';
#3...........
},
'sot.def' => {
source => "sot",
params => "def",
expect => <<'#4...........',
$opt_c = Text::CSV_XS->new(
{
binary => 1,
sep_char => $opt_c,
always_quote => 1,
}
);
$c->Tk::bind(
'' => sub {
my ($c) = @_;
my $e = $c->XEvent;
itemsUnderArea $c;
}
);
__PACKAGE__->load_components(
qw(
PK::Auto
Core
)
);
#4...........
},
'sot.sot' => {
source => "sot",
params => "sot",
expect => <<'#5...........',
$opt_c = Text::CSV_XS->new( {
binary => 1,
sep_char => $opt_c,
always_quote => 1,
} );
$c->Tk::bind(
'' => sub {
my ($c) = @_;
my $e = $c->XEvent;
itemsUnderArea $c;
} );
__PACKAGE__->load_components( qw(
PK::Auto
Core
) );
#5...........
},
'prune.def' => {
source => "prune",
params => "def",
expect => <<'#6...........',
# some tests for 'sub prune_alignment_tree'
$request->header( 'User-Agent' => $agent ) if $agent;
$request->header( 'From' => $from ) if $from;
$request->header( 'Range' => "bytes=0-$max_size" ) if $max_size;
for (
[ 'CONSTANT', sub { join "foo", "bar" }, 0, "bar" ],
[ 'CONSTANT', sub { join "foo", "bar", 3 }, 1, "barfoo3" ],
[ '$var', sub { join $_, "bar" }, 0, "bar" ],
[ '$myvar', sub { my $var; join $var, "bar" }, 0, "bar" ],
);
[
[ [NewXSHdr], [ NewXSName, NewXSArgs ], "XSHdr" ],
[ [NewXSCHdrs], [ NewXSName, NewXSArgs, GlobalNew ], "XSCHdrs" ],
[ [DefSyms], [StructName], "MkDefSyms" ],
[ [NewXSSymTab], [ DefSyms, NewXSArgs ], "AddArgsyms" ],
[ [NewXSLocals], [NewXSSymTab], "Sym2Loc" ],
[ [IsAffineFlag], [], sub { return "0" } ],
];
@degen_nums[ 1, 2, 4, 8 ] = ( 'a', 'c', 'g', 't' );
@degen_nums[ 5, 10, 9, 6, 3, 12 ] = ( 'r', 'y', 'w', 's', 'm', 'k' );
@degen_nums[ 14, 13, 11, 7, 15 ] = ( 'b', 'd', 'h', 'v', 'n' );
$_CreateFile = ff( "k32", "CreateFile", [ P, N, N, N, N, N, N ], N );
$_CloseHandle = ff( "k32", "CloseHandle", [N], N );
$_GetCommState = ff( "k32", "GetCommState", [ N, P ], I );
$_SetCommState = ff( "k32", "SetCommState", [ N, P ], I );
$_SetupComm = ff( "k32", "SetupComm", [ N, N, N ], I );
$_PurgeComm = ff( "k32", "PurgeComm", [ N, N ], I );
$_CreateEvent = ff( "k32", "CreateEvent", [ P, I, I, P ], N );
is_deeply \@t, [
[3], [0], [1], [0],
3, [1], 3, [1],
2, [0], [1], [0],
[1], [1], [1], 2,
3, [1], 2, [3],
4, [ 7, 8 ], 9, ["a"],
"b", 3, 2, 5,
3, 2, 5, 3,
[2], 5, 4, 5,
[ 3, 2, 1 ], 1, 2, 3,
[ -1, -2, -3 ], [ -1, -2, -3 ], [ -1, -2, -3 ], [ -1, -2 ],
3, [ -1, -2 ], 3, [ -1, -2, -3 ],
[ !1 ], [ 8, 7, 6 ], [ 8, 7, 6 ], [4],
!!0,
];
#6...........
},
'align33.def' => {
source => "align33",
params => "def",
expect => <<'#7...........',
$wl = int( $wl * $f + .5 );
$wr = int( $wr * $f + .5 );
$pag = int( $pageh * $f + .5 );
$fe = $opt_F ? "t" : "f";
$cf = $opt_U ? "t" : "f";
$tp = $opt_t ? "t" : "f";
$rm = $numbstyle ? "t" : "f";
$pa = $showurl ? "t" : "f";
$nh = $seq_number ? "t" : "f";
#7...........
},
'gnu7.def' => {
source => "gnu7",
params => "def",
expect => <<'#8...........',
# hanging side comments
if ( $seen == 1 ) { # We're the first word so far to have
# this abbreviation.
$hashref->{$abbrev} = $word;
}
elsif ( $seen == 2 ) { # We're the second word to have this
# abbreviation, so we can't use it.
delete $hashref->{$abbrev};
}
else { # We're the third word to have this
# abbreviation, so skip to the next word.
next WORD;
}
#8...........
},
'gnu7.gnu' => {
source => "gnu7",
params => "gnu",
expect => <<'#9...........',
# hanging side comments
if ($seen == 1)
{ # We're the first word so far to have
# this abbreviation.
$hashref->{$abbrev} = $word;
}
elsif ($seen == 2)
{ # We're the second word to have this
# abbreviation, so we can't use it.
delete $hashref->{$abbrev};
}
else
{ # We're the third word to have this
# abbreviation, so skip to the next word.
next WORD;
}
#9...........
},
'git33.def' => {
source => "git33",
params => "def",
expect => <<'#10...........',
# test -wls='->' -wrs='->'
use Net::Ping;
my ($ping) = Net::Ping->new();
$ping->ping($host);
#10...........
},
'git33.git33' => {
source => "git33",
params => "git33",
expect => <<'#11...........',
# test -wls='->' -wrs='->'
use Net::Ping;
my ($ping) = Net::Ping -> new();
$ping -> ping($host);
#11...........
},
'rt133130.def' => {
source => "rt133130",
params => "def",
expect => <<'#12...........',
method sum_radlinks {
my ( $global_radiation_matrix, $local_radiation_matrix, $rngg ) = @_;
my ( $i, $j, $n1, $n2, $num );
my $rggij;
$num = @$rngg;
for ( $i = 0 ; $i < $num ; $i++ ) {
$n1 = $rngg->[$i];
for ( $j = 0 ; $j < $num ; $j++ ) {
$n2 = $rngg->[$j];
$rggij = $local_radiation_matrix->[$i][$j];
if ( $rggij && ( $n1 != $n2 ) ) {
$global_radiation_matrix->[$n1][$n2] += $rggij;
}
}
}
}
#12...........
},
'rt133130.rt133130' => {
source => "rt133130",
params => "rt133130",
expect => <<'#13...........',
method sum_radlinks {
my ( $global_radiation_matrix, $local_radiation_matrix, $rngg ) = @_;
my ( $i, $j, $n1, $n2, $num );
my $rggij;
$num = @$rngg;
for ( $i = 0 ; $i < $num ; $i++ ) {
$n1 = $rngg->[$i];
for ( $j = 0 ; $j < $num ; $j++ ) {
$n2 = $rngg->[$j];
$rggij = $local_radiation_matrix->[$i][$j];
if ( $rggij && ( $n1 != $n2 ) ) {
$global_radiation_matrix->[$n1][$n2] += $rggij;
}
}
}
} ## end sub sum_radlinks
#13...........
},
'nib.def' => {
source => "nib",
params => "def",
expect => <<'#14...........',
{ #<<<
{ #<<<
{ #++
print "hello world\n";
}
}
}
{ #++
{ #++
{ #<<<
print "hello world\n";
}
}
}
#14...........
},
'nib.nib1' => {
source => "nib",
params => "nib1",
expect => <<'#15...........',
{ #<<<
{ #<<<
{ #++
print "hello world\n";
}
}
}
{ #++
{ #++
{ #<<<
print "hello world\n";
}
}
}
#15...........
},
'nib.nib2' => {
source => "nib",
params => "nib2",
expect => <<'#16...........',
{ #<<<
{ #<<<
{ #++
print "hello world\n";
}
}
}
{ #++
{ #++
{ #<<<
print "hello world\n";
}
}
}
#16...........
},
'scbb-csc.def' => {
source => "scbb-csc",
params => "def",
expect => <<'#17...........',
sub perlmod_install_advice {
my (@mod) = @_;
if ($auto_install_cpan) {
require AutoInstall::Tk;
my $r = AutoInstall::Tk::do_autoinstall_tk(@mod);
if ( $r > 0 ) {
for my $mod (@mod) {
warn "Re-require $mod...\n";
eval "require $mod";
die __LINE__ . ": $@" if $@;
}
}
}
else {
my $shell = ( $os eq 'win' ? M "Eingabeaufforderung" : M "Shell" );
status_message(
Mfmt(
(
@mod > 1
? "Die fehlenden Perl-Module können aus der %s mit dem Kommando\n"
: "Das fehlende Perl-Modul kann aus der %s mit dem Kommando\n"
),
$shell
)
. " perl -MCPAN -e \"install "
. join( ", ", @mod ) . "\"\n"
. "aus dem Internet geholt und installiert werden.\n",
"err"
);
}
}
#17...........
},
'scbb-csc.scbb-csc' => {
source => "scbb-csc",
params => "scbb-csc",
expect => <<'#18...........',
sub perlmod_install_advice {
my (@mod) = @_;
if ($auto_install_cpan) {
require AutoInstall::Tk;
my $r = AutoInstall::Tk::do_autoinstall_tk(@mod);
if ( $r > 0 ) {
for my $mod (@mod) {
warn "Re-require $mod...\n";
eval "require $mod";
die __LINE__ . ": $@" if $@;
}
} ## end if ( $r > 0 )
} ## end if ($auto_install_cpan)
else {
my $shell = ( $os eq 'win' ? M "Eingabeaufforderung" : M "Shell" );
status_message(
Mfmt(
(
@mod > 1
? "Die fehlenden Perl-Module können aus der %s mit dem Kommando\n"
: "Das fehlende Perl-Modul kann aus der %s mit dem Kommando\n"
),
$shell
)
. " perl -MCPAN -e \"install "
. join( ", ", @mod ) . "\"\n"
. "aus dem Internet geholt und installiert werden.\n",
"err"
);
} ## end else [ if ($auto_install_cpan)]
} ## end sub perlmod_install_advice
#18...........
},
'here_long.def' => {
source => "here_long",
params => "def",
expect => <<'#19...........',
# must not break after here target regardless of maximum-line-length
$sth = $dbh->prepare(<<"END_OF_SELECT") or die "Couldn't prepare SQL";
SELECT COUNT(duration),SUM(duration)
FROM logins WHERE username='$user'
END_OF_SELECT
#19...........
},
};
my $ntests = 0 + keys %{$rtests};
plan tests => $ntests;
}
###############
# EXECUTE TESTS
###############
foreach my $key ( sort keys %{$rtests} ) {
my $output;
my $sname = $rtests->{$key}->{source};
my $expect = $rtests->{$key}->{expect};
my $pname = $rtests->{$key}->{params};
my $source = $rsources->{$sname};
my $params = defined($pname) ? $rparams->{$pname} : "";
my $stderr_string;
my $errorfile_string;
my $err = Perl::Tidy::perltidy(
source => \$source,
destination => \$output,
perltidyrc => \$params,
argv => '', # for safety; hide any ARGV from perltidy
stderr => \$stderr_string,
errorfile => \$errorfile_string, # not used when -se flag is set
);
if ( $err || $stderr_string || $errorfile_string ) {
print STDERR "Error output received for test '$key'\n";
if ($err) {
print STDERR "An error flag '$err' was returned\n";
ok( !$err );
}
if ($stderr_string) {
print STDERR "---------------------\n";
print STDERR "<>\n$stderr_string\n";
print STDERR "---------------------\n";
ok( !$stderr_string );
}
if ($errorfile_string) {
print STDERR "---------------------\n";
print STDERR "<<.ERR file>>\n$errorfile_string\n";
print STDERR "---------------------\n";
ok( !$errorfile_string );
}
}
else {
if ( !is( $output, $expect, $key ) ) {
my $leno = length($output);
my $lene = length($expect);
if ( $leno == $lene ) {
print STDERR
"#> Test '$key' gave unexpected output. Strings differ but both have length $leno\n";
}
else {
print STDERR
"#> Test '$key' gave unexpected output. String lengths differ: output=$leno, expected=$lene\n";
}
}
}
}
Perl-Tidy-20210717/t/test.t 0000644 0001750 0001750 00000000113 07432222315 014230 0 ustar steve steve use strict;
use Test;
BEGIN { plan tests => 1 }
use Perl::Tidy;
ok(1);
Perl-Tidy-20210717/t/snippets8.t 0000644 0001750 0001750 00000027636 14072572632 015241 0 ustar steve steve # Created with: ./make_t.pl
# Contents:
#1 rt123749.rt123749
#2 rt123774.def
#3 rt124114.def
#4 rt124354.def
#5 rt124354.rt124354
#6 rt125012.def
#7 rt125012.rt125012
#8 rt125506.def
#9 rt125506.rt125506
#10 rt126965.def
#11 rt15735.def
#12 rt18318.def
#13 rt18318.rt18318
#14 rt27000.def
#15 rt31741.def
#16 rt49289.def
#17 rt50702.def
#18 rt50702.rt50702
#19 rt68870.def
#20 rt70747.def
# To locate test #13 you can search for its name or the string '#13'
use strict;
use Test::More;
use Carp;
use Perl::Tidy;
my $rparams;
my $rsources;
my $rtests;
BEGIN {
###########################################
# BEGIN SECTION 1: Parameter combinations #
###########################################
$rparams = {
'def' => "",
'rt123749' => "-wn",
'rt124354' => "-io",
'rt125012' => <<'----------',
-mangle
-dac
----------
'rt125506' => "-io",
'rt18318' => <<'----------',
-nwrs='A'
----------
'rt50702' => <<'----------',
-wbb='='
----------
};
############################
# BEGIN SECTION 2: Sources #
############################
$rsources = {
'rt123749' => <<'----------',
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;
----------
'rt123774' => <<'----------',
# retain any space between backslash and quote to avoid fooling html formatters
my $var1 = \ "bubba";
my $var2 = \"bubba";
my $var3 = \ 'bubba';
my $var4 = \'bubba';
my $var5 = \ "bubba";
----------
'rt124114' => <<'----------',
#!/usr/bin/perl
my %h = {
a => 2 > 3 ? 1 : 0,
bbbb => sub { my $y = "1" },
c => sub { my $z = "2" },
d => 2 > 3 ? 1 : 0,
};
----------
'rt124354' => <<'----------',
package Foo;
use Moose;
has a => ( is => 'ro', isa => 'Int' );
has b => ( is => 'ro', isa => 'Int' );
has c => ( is => 'ro', isa => 'Int' );
__PACKAGE__->meta->make_immutable;
----------
'rt125012' => <<'----------',
++$_ for
#one space before eol:
values %_;
system
#one space before eol:
qq{};
----------
'rt125506' => <<'----------',
my $t = '
un
deux
trois
';
----------
'rt126965' => <<'----------',
my $restrict_customer = shift ? 1 : 0;
----------
'rt15735' => <<'----------',
my $user_prefs = $ref_type eq 'SCALAR' ? _load_from_string( $profile ) : $ref_type eq 'ARRAY' ? _load_from_array( $profile ) : $ref_type eq 'HASH' ? _load_from_hash( $profile ) : _load_from_file( $profile );
----------
'rt18318' => <<'----------',
# Class::Std attribute list
# The token type of the first colon is 'A' so use -nwrs='A' to avoid space
# after it
my %rank_of : ATTR( :init_arg :get :set );
----------
'rt27000' => <<'----------',
print add( 3, 4 ), "\n";
print add( 4, 3 ), "\n";
sub add {
my ( $term1, $term2 ) = @_;
# line 1234
die "$term1 > $term2" if $term1 > $term2;
return $term1 + $term2;
}
----------
'rt31741' => <<'----------',
$msg //= 'World';
----------
'rt49289' => <<'----------',
use constant qw{ DEBUG 0 };
----------
'rt50702' => <<'----------',
if (1) { my $uid = $ENV{ 'ORIG_LOGNAME' } || $ENV{ 'LOGNAME' } || $ENV{ 'REMOTE_USER' } || 'foobar'; } if (2) { my $uid = ($ENV{ 'ORIG_LOGNAME' } || $ENV{ 'LOGNAME' } || $ENV{ 'REMOTE_USER' } || 'foobar'); }
----------
'rt68870' => <<'----------',
s///r;
----------
'rt70747' => <<'----------',
coerce Q2RawStatGroupArray, from ArrayRef [Q2StatGroup], via {
[ map {
my $g = $_->as_hash;
$g->{stats} = [ map { scalar $_->as_array } @{ $g->{stats} } ]; $g;
} @$_;
]
};
----------
};
####################################
# BEGIN SECTION 3: Expected output #
####################################
$rtests = {
'rt123749.rt123749' => {
source => "rt123749",
params => "rt123749",
expect => <<'#1...........',
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;
#1...........
},
'rt123774.def' => {
source => "rt123774",
params => "def",
expect => <<'#2...........',
# retain any space between backslash and quote to avoid fooling html formatters
my $var1 = \ "bubba";
my $var2 = \"bubba";
my $var3 = \ 'bubba';
my $var4 = \'bubba';
my $var5 = \ "bubba";
#2...........
},
'rt124114.def' => {
source => "rt124114",
params => "def",
expect => <<'#3...........',
#!/usr/bin/perl
my %h = {
a => 2 > 3 ? 1 : 0,
bbbb => sub { my $y = "1" },
c => sub { my $z = "2" },
d => 2 > 3 ? 1 : 0,
};
#3...........
},
'rt124354.def' => {
source => "rt124354",
params => "def",
expect => <<'#4...........',
package Foo;
use Moose;
has a => ( is => 'ro', isa => 'Int' );
has b => ( is => 'ro', isa => 'Int' );
has c => ( is => 'ro', isa => 'Int' );
__PACKAGE__->meta->make_immutable;
#4...........
},
'rt124354.rt124354' => {
source => "rt124354",
params => "rt124354",
expect => <<'#5...........',
package Foo;
use Moose;
has a => ( is => 'ro', isa => 'Int' );
has b => ( is => 'ro', isa => 'Int' );
has c => ( is => 'ro', isa => 'Int' );
__PACKAGE__->meta->make_immutable;
#5...........
},
'rt125012.def' => {
source => "rt125012",
params => "def",
expect => <<'#6...........',
++$_ for
#one space before eol:
values %_;
system
#one space before eol:
qq{};
#6...........
},
'rt125012.rt125012' => {
source => "rt125012",
params => "rt125012",
expect => <<'#7...........',
++$_ for
values%_;
system
qq{};
#7...........
},
'rt125506.def' => {
source => "rt125506",
params => "def",
expect => <<'#8...........',
my $t = '
un
deux
trois
';
#8...........
},
'rt125506.rt125506' => {
source => "rt125506",
params => "rt125506",
expect => <<'#9...........',
my $t = '
un
deux
trois
';
#9...........
},
'rt126965.def' => {
source => "rt126965",
params => "def",
expect => <<'#10...........',
my $restrict_customer = shift ? 1 : 0;
#10...........
},
'rt15735.def' => {
source => "rt15735",
params => "def",
expect => <<'#11...........',
my $user_prefs =
$ref_type eq 'SCALAR' ? _load_from_string($profile)
: $ref_type eq 'ARRAY' ? _load_from_array($profile)
: $ref_type eq 'HASH' ? _load_from_hash($profile)
: _load_from_file($profile);
#11...........
},
'rt18318.def' => {
source => "rt18318",
params => "def",
expect => <<'#12...........',
# Class::Std attribute list
# The token type of the first colon is 'A' so use -nwrs='A' to avoid space
# after it
my %rank_of : ATTR( :init_arg :get :set );
#12...........
},
'rt18318.rt18318' => {
source => "rt18318",
params => "rt18318",
expect => <<'#13...........',
# Class::Std attribute list
# The token type of the first colon is 'A' so use -nwrs='A' to avoid space
# after it
my %rank_of :ATTR( :init_arg :get :set );
#13...........
},
'rt27000.def' => {
source => "rt27000",
params => "def",
expect => <<'#14...........',
print add( 3, 4 ), "\n";
print add( 4, 3 ), "\n";
sub add {
my ( $term1, $term2 ) = @_;
# line 1234
die "$term1 > $term2" if $term1 > $term2;
return $term1 + $term2;
}
#14...........
},
'rt31741.def' => {
source => "rt31741",
params => "def",
expect => <<'#15...........',
$msg //= 'World';
#15...........
},
'rt49289.def' => {
source => "rt49289",
params => "def",
expect => <<'#16...........',
use constant qw{ DEBUG 0 };
#16...........
},
'rt50702.def' => {
source => "rt50702",
params => "def",
expect => <<'#17...........',
if (1) {
my $uid =
$ENV{'ORIG_LOGNAME'}
|| $ENV{'LOGNAME'}
|| $ENV{'REMOTE_USER'}
|| 'foobar';
}
if (2) {
my $uid =
( $ENV{'ORIG_LOGNAME'}
|| $ENV{'LOGNAME'}
|| $ENV{'REMOTE_USER'}
|| 'foobar' );
}
#17...........
},
'rt50702.rt50702' => {
source => "rt50702",
params => "rt50702",
expect => <<'#18...........',
if (1) {
my $uid
= $ENV{'ORIG_LOGNAME'}
|| $ENV{'LOGNAME'}
|| $ENV{'REMOTE_USER'}
|| 'foobar';
}
if (2) {
my $uid
= ( $ENV{'ORIG_LOGNAME'}
|| $ENV{'LOGNAME'}
|| $ENV{'REMOTE_USER'}
|| 'foobar' );
}
#18...........
},
'rt68870.def' => {
source => "rt68870",
params => "def",
expect => <<'#19...........',
s///r;
#19...........
},
'rt70747.def' => {
source => "rt70747",
params => "def",
expect => <<'#20...........',
coerce Q2RawStatGroupArray, from ArrayRef [Q2StatGroup], via {
[
map {
my $g = $_->as_hash;
$g->{stats} = [ map { scalar $_->as_array } @{ $g->{stats} } ];
$g;
} @$_;
]
};
#20...........
},
};
my $ntests = 0 + keys %{$rtests};
plan tests => $ntests;
}
###############
# EXECUTE TESTS
###############
foreach my $key ( sort keys %{$rtests} ) {
my $output;
my $sname = $rtests->{$key}->{source};
my $expect = $rtests->{$key}->{expect};
my $pname = $rtests->{$key}->{params};
my $source = $rsources->{$sname};
my $params = defined($pname) ? $rparams->{$pname} : "";
my $stderr_string;
my $errorfile_string;
my $err = Perl::Tidy::perltidy(
source => \$source,
destination => \$output,
perltidyrc => \$params,
argv => '', # for safety; hide any ARGV from perltidy
stderr => \$stderr_string,
errorfile => \$errorfile_string, # not used when -se flag is set
);
if ( $err || $stderr_string || $errorfile_string ) {
print STDERR "Error output received for test '$key'\n";
if ($err) {
print STDERR "An error flag '$err' was returned\n";
ok( !$err );
}
if ($stderr_string) {
print STDERR "---------------------\n";
print STDERR "<>\n$stderr_string\n";
print STDERR "---------------------\n";
ok( !$stderr_string );
}
if ($errorfile_string) {
print STDERR "---------------------\n";
print STDERR "<<.ERR file>>\n$errorfile_string\n";
print STDERR "---------------------\n";
ok( !$errorfile_string );
}
}
else {
if ( !is( $output, $expect, $key ) ) {
my $leno = length($output);
my $lene = length($expect);
if ( $leno == $lene ) {
print STDERR
"#> Test '$key' gave unexpected output. Strings differ but both have length $leno\n";
}
else {
print STDERR
"#> Test '$key' gave unexpected output. String lengths differ: output=$leno, expected=$lene\n";
}
}
}
}
Perl-Tidy-20210717/t/snippets5.t 0000644 0001750 0001750 00000073573 14072572632 015237 0 ustar steve steve # Created with: ./make_t.pl
# Contents:
#1 list1.def
#2 listop1.def
#3 listop2.def
#4 lp1.def
#5 lp1.lp
#6 mangle1.def
#7 mangle1.mangle
#8 mangle2.def
#9 mangle2.mangle
#10 mangle3.def
#11 mangle3.mangle
#12 math1.def
#13 math2.def
#14 math3.def
#15 math4.def
#16 nasc.def
#17 nasc.nasc
#18 nothing.def
#19 nothing.nothing
#20 otr1.def
# To locate test #13 you can search for its name or the string '#13'
use strict;
use Test::More;
use Carp;
use Perl::Tidy;
my $rparams;
my $rsources;
my $rtests;
BEGIN {
###########################################
# BEGIN SECTION 1: Parameter combinations #
###########################################
$rparams = {
'def' => "",
'lp' => "-lp",
'mangle' => "--mangle",
'nasc' => "-nasc",
'nothing' => "",
};
############################
# BEGIN SECTION 2: Sources #
############################
$rsources = {
'list1' => <<'----------',
%height=("letter",27.9, "legal",35.6, "arche",121.9, "archd",91.4, "archc",61,
"archb",45.7, "archa",30.5, "flsa",33, "flse",33, "halfletter",21.6,
"11x17",43.2, "ledger",27.9);
%width=("letter",21.6, "legal",21.6, "arche",91.4, "archd",61, "archc",45.7,
"archb",30.5, "archa",22.9, "flsa",21.6, "flse",21.6, "halfletter",14,
"11x17",27.9, "ledger",43.2);
----------
'listop1' => <<'----------',
my @sorted = map { $_->[0] }
sort { $a->[1] <=> $b->[1] }
map { [ $_, rand ] } @list;
----------
'listop2' => <<'----------',
my @sorted =
map { $_->[0] } sort { $a->[1] <=> $b->[1] } map { [ $_, rand ] } @list;
----------
'lp1' => <<'----------',
# a good test problem for -lp; thanks to Ian Stuart
push @contents,
$c->table(
{ -border => '1' },
$c->Tr(
{ -valign => 'top' },
$c->td(
" Author ",
$c->textfield(
-tabindex => "1",
-name => "author",
-default => "$author",
-size => '20'
)
),
$c->td(
$c->strong(" Publication Date "),
$c->textfield(
-tabindex => "2",
-name => "pub_date",
-default => "$pub_date",
-size => '20'
),
)
),
$c->Tr(
{ -valign => 'top' },
$c->td(
{ -colspan => '2' },
$c->strong("Title"),
$c->textfield(
-tabindex => "3",
-name => "title",
-default => "$title",
-override => '1',
-size => '40'
),
)
),
$c->Tr(
{ -valign => 'top' },
$c->td(
$c->table(
$c->Tr(
$c->td( { -valign => 'top' }, $c->strong(" Document Type ") ),
$c->td(
{ -valign => 'top' },
$c->scrolling_list(
-tabindex => "4",
-name => "doc_type",
-values => [@docCodeValues],
-labels => \%docCodeLabels,
-default => "$doc_type"
)
)
)
)
),
$c->td(
$c->table(
$c->Tr(
$c->td(
{ -valign => 'top' },
$c->strong( " Relevant Discipline ", $c->br(), "Area " )
),
$c->td(
{ -valign => 'top' },
$c->scrolling_list(
-tabindex => "5",
-name => "discipline",
-values => [@discipValues],
-labels => \%discipLabels,
-default => "$discipline"
),
)
)
)
)
),
$c->Tr(
{ -valign => 'top' },
$c->td(
{ -colspan => '2' },
$c->table(
$c->Tr(
$c->td(
{ -valign => 'top' }, $c->strong(" Relevant Subject Area "),
$c->br(), "You may select multiple areas",
),
$c->td(
{ -valign => 'top' },
$c->checkbox_group(
-tabindex => "6",
-name => "subject",
-values => [@subjValues],
-labels => \%subjLabels,
-defaults => [@subject],
-rows => "2"
)
)
)
)
)
),
$c->Tr(
{ -valign => 'top' },
$c->td(
{ -colspan => '2' },
$c->strong("Location