# Perltidy Change Log
+## 2020 01 10
+
+ - 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'
+
+
+## 2019 12 03
+
+ - 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.
+
+
+## 2019 09 15
+
+ - 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
+
## 2019 06 01
- rt #128477: Prevent inconsistent owner/group and setuid/setgid bits.
## 2017 05 21
- Fixed debian #862667: failure to check for perltidy.ERR deletion can lead
- to overwriting abritrary files by symlink attack. Perltidy was continuing
+ to overwriting arbitrary files by symlink attack. Perltidy was continuing
to write files after an unlink failure. Thanks to Don Armstrong
for a patch.
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 unnecesarily broken
+ were unnecessarily broken
- RT #32905, patch to fix utf-8 error when output was STDOUT.
- Fixed RT #107832 and #106492, lack of vertical alignment of two lines
when -boc flag (break at old commas) is set. This bug was
- inadvertantly introduced in previous bug fix RT #98902.
+ 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:
- 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
- occured if there was no comma after the closing brace of the anonymous sub.
+ 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.
: undef;
-Text following un-parenthesized if/unless/while/until statements get a
- full level of indentation. Suggested by Jeff Armstorng and others.
+ full level of indentation. Suggested by Jeff Armstrong and others.
OLD:
return $ship->chargeWeapons("phaser-canon")
if $encounter->description eq 'klingon'
external calls to Tidy.pm module. Fixed incorrect html title when
Tidy.pm is called with IO::Scalar or IO::Array source.
- -Output file permissons are now set as follows. An output script file
+ -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
-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
- varaibles: $#: $#- $#+ so I updated the parser accordingly. Only $#:
+ 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
t/snippets13.t
t/snippets14.t
t/snippets15.t
+t/snippets16.t
t/snippets2.t
t/snippets3.t
t/snippets4.t
"web" : "https://github.com/perltidy/perltidy"
}
},
- "version" : "20190601"
+ "version" : "20200110"
}
- inc
resources:
repository: https://github.com/perltidy/perltidy.git
-version: '20190601'
+version: '20200110'
);
}
-Perl::Tidy::perltidy( argv => $arg_string );
+# Exit codes returned by perltidy:
+# 0 = no errors
+# 1 = perltidy could not run to completion due to errors
+# 2 = perltidy ran to completion with error messages
+exit Perl::Tidy::perltidy( argv => $arg_string );
__END__
However, valid perl scripts containing binary data may sometimes be identified
as non-text, and this flag forces perltidy to process them.
+=item B<-ast>, B<--assert-tidy>
+
+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.
+
+=item B<-asu>, B<--assert-untidy>
+
+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.
+
+=item B<-sal=s>, B<--sub-alias-list=s>
+
+This flag causes one or more words to be treated the same as if they were the keyword 'sub'. The string B<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.
+
+
=back
=head1 FORMATTING OPTIONS
You will probably also want to use the flag B<-skp> (previous item) too.
+=item B<-spp=n> or B<--space-prototype-paren=n>
+
+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 B<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 paren
+
+The default is B<-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]
+
=item Trimming whitespace around C<qw> quotes
B<-tqw> or B<--trim-qw> provide the default behavior of trimming
This shows that blocks with a single statement become one-line blocks.
-
=item B<-olbs=n>, B<--one-line-block-semicolons=n>
This flag controls the placement of semicolons at the end of one-line blocks.
ending semicolons which terminate one-line blocks containing just one
semicolon. So these two options are not exact inverses.
+=item B<-olbn=n>, B<--one-line-block-nesting=n>
+
+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 intact
+
+For the above example, the default formatting (B<-olbn=0>) is
+
+ foreach (@list) {
+ if ( $_ eq $asked_for ) { last }
+ ++$found;
+ }
+
+If the parameter B<-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.
+
+
=back
flexibility, the following convention is used in all cases to decide if
a leading '.' should be used. If the extension C<ext> begins with
C<A-Z>, C<a-z>, or C<0-9>, then it will be appended to the filename with
-an intermediate '.' (or perhaps an '_' on VMS systems). Otherwise, it
+an intermediate '.' (or perhaps a '_' on VMS systems). Otherwise, it
will be appended directly.
For example, suppose the file is F<somefile.pl>. For C<-bext=old>, a '.' is
=back
+=head1 ERROR HANDLING
+
+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.
+
=head1 SEE ALSO
perlstyle(1), Perl::Tidy(3)
+=head1 INSTALLATION
+
+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'.
+
=head1 VERSION
-This man page documents perltidy version 20190601
+This man page documents perltidy version 20200110
=head1 BUG REPORTS
=head1 COPYRIGHT
-Copyright (c) 2000-2018 by Steve Hancock
+Copyright (c) 2000-2020 by Steve Hancock
=head1 LICENSE
<h1>Perltidy Change Log</h1>
+<h2>2020 01 10</h2>
+
+<pre><code>- 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'
+</code></pre>
+
+<h2>2019 12 03</h2>
+
+<pre><code>- 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.
+</code></pre>
+
+<h2>2019 09 15</h2>
+
+<pre><code>- 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
+</code></pre>
+
<h2>2019 06 01</h2>
<pre><code>- rt #128477: Prevent inconsistent owner/group and setuid/setgid bits.
<h2>2017 05 21</h2>
<pre><code>- Fixed debian #862667: failure to check for perltidy.ERR deletion can lead
- to overwriting abritrary files by symlink attack. Perltidy was continuing
+ to overwriting arbitrary files by symlink attack. Perltidy was continuing
to write files after an unlink failure. Thanks to Don Armstrong
for a patch.
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 unnecesarily broken
+ were unnecessarily broken
- RT #32905, patch to fix utf-8 error when output was STDOUT.
- Fixed RT #107832 and #106492, lack of vertical alignment of two lines
when -boc flag (break at old commas) is set. This bug was
- inadvertantly introduced in previous bug fix RT #98902.
+ 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:
- 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
- occured if there was no comma after the closing brace of the anonymous sub.
+ 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.
: undef;
-Text following un-parenthesized if/unless/while/until statements get a
-full level of indentation. Suggested by Jeff Armstorng and others.
+full level of indentation. Suggested by Jeff Armstrong and others.
OLD:
return $ship->chargeWeapons("phaser-canon")
if $encounter->description eq 'klingon'
external calls to Tidy.pm module. Fixed incorrect html title when
Tidy.pm is called with IO::Scalar or IO::Array source.
--Output file permissons are now set as follows. An output script file
+-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
-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
-varaibles: $#: $#- $#+ so I updated the parser accordingly. Only $#:
+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
<li><a href="#EXAMPLES">EXAMPLES</a></li>
<li><a href="#Using-the-formatter-Callback-Object">Using the formatter Callback Object</a></li>
<li><a href="#EXPORT">EXPORT</a></li>
+ <li><a href="#INSTALLATION">INSTALLATION</a></li>
<li><a href="#VERSION">VERSION</a></li>
<li><a href="#LICENSE">LICENSE</a></li>
<li><a href="#BUG-REPORTS">BUG REPORTS</a></li>
<h1 id="ERROR-HANDLING">ERROR HANDLING</h1>
-<p>Perltidy will return with an error flag indicating if 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 this flag because if it is set the destination stream will be empty or incomplete and should be ignored. Error messages in the <b>stderr</b> stream will indicate the cause of any problem.</p>
+<p>An exit value of 0, 1, or 2 is returned by perltidy to indicate the status of the result.</p>
-<p>If the error flag is not set then perltidy ran to completion. However there may still be warning messages in the <b>stderr</b> stream related to control parameters, and there may be warning messages in the <b>errorfile</b> stream relating to possible syntax errors in the source code being tidied.</p>
+<p>A exit value of 0 indicates that perltidy ran to completion with no error messages.</p>
+
+<p>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 <b>stderr</b> stream will indicate the cause of any problem.</p>
+
+<p>An exit value of 2 indicates that perltidy ran to completion but there there are warning messages in the <b>stderr</b> stream related to parameter errors or conflicts and/or warning messages in the <b>errorfile</b> stream relating to possible syntax errors in the source code being tidied.</p>
<p>In the event of a catastrophic error for which recovery is not possible <b>perltidy</b> terminates by making calls to <b>croak</b> or <b>confess</b> to help the programmer localize the problem. These should normally only occur during program development.</p>
<pre><code> &perltidy</code></pre>
+<h1 id="INSTALLATION">INSTALLATION</h1>
+
+<p>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'.</p>
+
<h1 id="VERSION">VERSION</h1>
-<p>This man page documents Perl::Tidy version 20190601</p>
+<p>This man page documents Perl::Tidy version 20200110</p>
<h1 id="LICENSE">LICENSE</h1>
<li><a href="#SWITCHES-WHICH-MAY-BE-NEGATED">SWITCHES WHICH MAY BE NEGATED</a></li>
<li><a href="#LIMITATIONS">LIMITATIONS</a></li>
<li><a href="#FILES">FILES</a></li>
+ <li><a href="#ERROR-HANDLING">ERROR HANDLING</a></li>
<li><a href="#SEE-ALSO">SEE ALSO</a></li>
+ <li><a href="#INSTALLATION">INSTALLATION</a></li>
<li><a href="#VERSION">VERSION</a></li>
<li><a href="#BUG-REPORTS">BUG REPORTS</a></li>
<li><a href="#COPYRIGHT">COPYRIGHT</a></li>
<p>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.</p>
+</dd>
+<dt id="ast---assert-tidy"><b>-ast</b>, <b>--assert-tidy</b></dt>
+<dd>
+
+<p>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.</p>
+
+</dd>
+<dt id="asu---assert-untidy"><b>-asu</b>, <b>--assert-untidy</b></dt>
+<dd>
+
+<p>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.</p>
+
+</dd>
+<dt id="sal-s---sub-alias-list-s"><b>-sal=s</b>, <b>--sub-alias-list=s</b></dt>
+<dd>
+
+<p>This flag causes one or more words to be treated the same as if they were the keyword 'sub'. The string <b>s</b> contains one or more alias words, separated by spaces or commas.</p>
+
+<p>For example,</p>
+
+<pre><code> perltidy -sal='method fun _sub M4' </code></pre>
+
+<p>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.</p>
+
</dd>
</dl>
<p>You will probably also want to use the flag <b>-skp</b> (previous item) too.</p>
+</dd>
+<dt id="spp-n-or---space-prototype-paren-n"><b>-spp=n</b> or <b>--space-prototype-paren=n</b></dt>
+<dd>
+
+<p>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.</p>
+
+<pre><code> sub usage();</code></pre>
+
+<p>This integer <b>n</b> may have the value 0, 1, or 2 as follows:</p>
+
+<pre><code> -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 paren</code></pre>
+
+<p>The default is <b>-spp=1</b>, 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:</p>
+
+<pre><code> sub usage(); # n=0 [no space]
+ sub usage(); # n=1 [default; follows input]
+ sub usage (); # n=2 [space]</code></pre>
+
</dd>
<dt id="Trimming-whitespace-around-qw-quotes">Trimming whitespace around <code>qw</code> quotes</dt>
<dd>
<p>Note that the <b>n=2</b> option has no effect if adding semicolons is prohibited with the <b>-nasc</b> flag. Also not that while <b>n=2</b> adds missing semicolons to all one-line blocks, regardless of complexity, the <b>n=0</b> option only removes ending semicolons which terminate one-line blocks containing just one semicolon. So these two options are not exact inverses.</p>
+</dd>
+<dt id="olbn-n---one-line-block-nesting-n"><b>-olbn=n</b>, <b>--one-line-block-nesting=n</b></dt>
+<dd>
+
+<p>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.</p>
+
+<pre><code> foreach (@list) { if ($_ eq $asked_for) { last } ++$found }</code></pre>
+
+<p>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:</p>
+
+<pre><code> n=0 break nested one-line blocks into multiple lines [DEFAULT]
+ n=1 stable: keep existing nested-one line blocks intact</code></pre>
+
+<p>For the above example, the default formatting (<b>-olbn=0</b>) is</p>
+
+<pre><code> foreach (@list) {
+ if ( $_ eq $asked_for ) { last }
+ ++$found;
+ }</code></pre>
+
+<p>If the parameter <b>-olbn=1</b> 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.</p>
+
</dd>
</dl>
<h2 id="Specifying-File-Extensions">Specifying File Extensions</h2>
-<p>Several parameters allow default file extensions to be overridden. For example, a backup file extension may be specified with <b>-bext=ext</b>, where <b>ext</b> 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 <code>ext</code> begins with <code>A-Z</code>, <code>a-z</code>, or <code>0-9</code>, then it will be appended to the filename with an intermediate '.' (or perhaps an '_' on VMS systems). Otherwise, it will be appended directly.</p>
+<p>Several parameters allow default file extensions to be overridden. For example, a backup file extension may be specified with <b>-bext=ext</b>, where <b>ext</b> 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 <code>ext</code> begins with <code>A-Z</code>, <code>a-z</code>, or <code>0-9</code>, then it will be appended to the filename with an intermediate '.' (or perhaps a '_' on VMS systems). Otherwise, it will be appended directly.</p>
<p>For example, suppose the file is <i>somefile.pl</i>. For <code>-bext=old</code>, a '.' is added to give <i>somefile.pl.old</i>. For <code>-bext=.old</code>, no additional '.' is added, so again the backup file is <i>somefile.pl.old</i>. For <code>-bext=~</code>, then no dot is added, and the backup file will be <i>somefile.pl~</i> .</p>
</dd>
</dl>
+<h1 id="ERROR-HANDLING">ERROR HANDLING</h1>
+
+<p>An exit value of 0, 1, or 2 is returned by perltidy to indicate the status of the result.</p>
+
+<p>A exit value of 0 indicates that perltidy ran to completion with no error messages.</p>
+
+<p>A non-zero exit value indicates some kind of problem was detected.</p>
+
+<p>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.</p>
+
+<p>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.</p>
+
<h1 id="SEE-ALSO">SEE ALSO</h1>
<p>perlstyle(1), Perl::Tidy(3)</p>
+<h1 id="INSTALLATION">INSTALLATION</h1>
+
+<p>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'.</p>
+
<h1 id="VERSION">VERSION</h1>
-<p>This man page documents perltidy version 20190601</p>
+<p>This man page documents perltidy version 20200110</p>
<h1 id="BUG-REPORTS">BUG REPORTS</h1>
<h1 id="COPYRIGHT">COPYRIGHT</h1>
-<p>Copyright (c) 2000-2018 by Steve Hancock</p>
+<p>Copyright (c) 2000-2020 by Steve Hancock</p>
<h1 id="LICENSE">LICENSE</h1>
<pre><code> perltidy *.pl</code></pre>
-<p>and in this case, each of the output files will be have a name equal to the input file with the extension <i>.tdy</i> appended. If you decide that the formatting is acceptable, you will want to backup your originals and then remove the <i>.tdy</i> extensions from the reformatted files. There is an powerful perl script called <code>rename</code> that can be used for this purpose; if you don't have it, you can find it for example in <b>The Perl Cookbook</b>.</p>
+<p>and in this case, each of the output files will be have a name equal to the input file with the extension <i>.tdy</i> appended. If you decide that the formatting is acceptable, you will want to backup your originals and then remove the <i>.tdy</i> extensions from the reformatted files. There is a powerful perl script called <code>rename</code> that can be used for this purpose; if you don't have it, you can find it for example in <b>The Perl Cookbook</b>.</p>
<p>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>-b</b> flag. For example, the command</p>
$missing_file_spec
$fh_stderr
$rOpts_character_encoding
+ $Warn_count
};
@ISA = qw( Exporter );
# 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 developement. If it ever reaches 99 then the
+ # 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 = '20190601';
+ $VERSION = '20200110';
}
sub streamhandle {
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' );
+ return if ( $^O eq 'VMS' );
# this should work at least for Windows and Unix:
$test_file = $path . '/' . $name;
$fh_stderr = *STDERR;
}
- sub Warn { my $msg = shift; $fh_stderr->print($msg); return }
+ sub Warn { my $msg = shift; $fh_stderr->print($msg); $Warn_count++; return }
sub Exit {
my $flag = shift;
croak "unexpected return to Die";
}
+ my $md5_hex = sub {
+ my ($buf) = @_;
+
+ # Evaluate the MD5 sum for a string
+ # Patch for [rt.cpan.org #88020]
+ # Use utf8::encode since md5_hex() only operates on bytes.
+ # my $digest = md5_hex( utf8::encode($sink_buffer) );
+
+ # Note added 20180114: the above patch did not work correctly. I'm not
+ # sure why. But switching to the method recommended in the Perl 5
+ # documentation for Encode worked. According to this we can either use
+ # $octets = encode_utf8($string) or equivalently
+ # $octets = encode("utf8",$string)
+ # and then calculate the checksum. So:
+ my $octets = Encode::encode( "utf8", $buf );
+ my $digest = md5_hex($octets);
+ return $digest;
+ };
+
# extract various dump parameters
my $dump_options_type = $input_hash{'dump_options_type'};
my $dump_options = $get_hash_ref->('dump_options');
}
Perl::Tidy::Formatter::check_options($rOpts);
+ Perl::Tidy::Tokenizer::check_options($rOpts);
if ( $rOpts->{'format'} eq 'html' ) {
Perl::Tidy::HtmlWriter->check_options($rOpts);
}
while ( my $input_file = shift @ARGV ) {
my $fileroot;
my @input_file_stat;
+ my $display_name;
#---------------------------------------------------------------
# prepare this input stream
#---------------------------------------------------------------
if ($source_stream) {
- $fileroot = "perltidy";
+ $fileroot = "perltidy";
+ $display_name = "<source_stream>";
# If the source is from an array or string, then .LOG output
# is only possible if a logfile stream is specified. This prevents
}
}
elsif ( $input_file eq '-' ) { # '-' indicates input from STDIN
- $fileroot = "perltidy"; # root name to use for .ERR, .LOG, etc
+ $fileroot = "perltidy"; # root name to use for .ERR, .LOG, etc
+ $display_name = "<stdin>";
$in_place_modify = 0;
}
else {
- $fileroot = $input_file;
+ $fileroot = $input_file;
+ $display_name = $input_file;
unless ( -e $input_file ) {
# file doesn't exist - check for a file glob
$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;
+
# 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.
$prefilter
|| ( $rOpts_character_encoding
&& $rOpts_character_encoding eq 'utf8' )
+ || $rOpts->{'assert-tidy'}
+ || $rOpts->{'assert-untidy'}
+ || $do_convergence_test
)
{
my $buf = '';
$buf .= $line;
}
- $buf = $prefilter->($buf) if $prefilter;
-
if ( $rOpts_character_encoding
&& $rOpts_character_encoding eq 'utf8'
&& !utf8::is_utf8($buf) )
}
}
+ # MD5 sum of input file is evaluated before any prefilter
+ if ( $rOpts->{'assert-tidy'} || $rOpts->{'assert-untidy'} ) {
+ $digest_input = $md5_hex->($buf);
+ }
+
+ $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} = 1;
+ }
+
$source_object = Perl::Tidy::LineSource->new( \$buf, $rOpts,
$rpending_logfile_message );
}
$line_separator = "\n" unless defined($line_separator);
my ( $sink_object, $postfilter_buffer );
- if ($postfilter) {
+ if ( $postfilter
+ || $rOpts->{'assert-tidy'}
+ || $rOpts->{'assert-untidy'} )
+ {
$sink_object =
Perl::Tidy::LineSink->new( \$postfilter_buffer, $tee_file,
$line_separator, $rOpts, $rpending_logfile_message, $binmode );
my $logger_object =
Perl::Tidy::Logger->new( $rOpts, $log_file, $warning_file,
- $fh_stderr, $saw_extrude );
+ $fh_stderr, $saw_extrude, $display_name );
write_logfile_header(
$rOpts, $logger_object, $config_file,
$rraw_options, $Windows_type, $readable_options,
# loop over iterations for one source stream
#---------------------------------------------------------------
- # We will do a convergence test if 3 or more iterations are allowed.
- # It would be pointless for fewer because we have to make at least
- # two passes before we can see if we are converged, and the test
- # would just slow things down.
- my $max_iterations = $rOpts->{'iterations'};
- my $convergence_log_message;
- my %saw_md5;
- my $do_convergence_test = $max_iterations > 2;
-
- # Since Digest::MD5 qw(md5_hex) has been in the earliest version of Perl
- # we are requiring (5.8), I have commented out this check
-##? if ($do_convergence_test) {
-##? eval "use Digest::MD5 qw(md5_hex)";
-##? $do_convergence_test = !$@;
-##?
-##? ### Trying to avoid problems with ancient versions of perl
-##? ##eval { my $string = "perltidy"; utf8::encode($string) };
-##? ##$do_convergence_test = $do_convergence_test && !$@;
-##? }
-
# save objects to allow redirecting output during iterations
my $sink_object_final = $sink_object;
my $debugger_object_final = $debugger_object;
$rpending_logfile_message );
# stop iterations if errors or converged
- #my $stop_now = $logger_object->{_warning_count};
my $stop_now = $tokenizer->report_tokenization_errors();
+ $stop_now ||= $tokenizer->get_unexpected_error_count();
if ($stop_now) {
$convergence_log_message = <<EOM;
Stopping iterations because of severe errors.
}
elsif ($do_convergence_test) {
- # Patch for [rt.cpan.org #88020]
- # Use utf8::encode since md5_hex() only operates on bytes.
- # my $digest = md5_hex( utf8::encode($sink_buffer) );
-
- # Note added 20180114: this patch did not work correctly.
- # I'm not sure why. But switching to the method
- # recommended in the Perl 5 documentation for Encode
- # worked. According to this we can either use
- # $octets = encode_utf8($string) or equivalently
- # $octets = encode("utf8",$string)
- # and then calculate the checksum. So:
- my $octets = Encode::encode( "utf8", $sink_buffer );
- my $digest = md5_hex($octets);
+ my $digest = $md5_hex->($sink_buffer);
if ( !$saw_md5{$digest} ) {
$saw_md5{$digest} = $iter;
}
#---------------------------------------------------------------
# Perform any postfilter operation
#---------------------------------------------------------------
- if ($postfilter) {
+ if ( $postfilter
+ || $rOpts->{'assert-tidy'}
+ || $rOpts->{'assert-untidy'} )
+ {
$sink_object->close_output_file();
$sink_object =
Perl::Tidy::LineSink->new( $output_file, $tee_file,
$line_separator, $rOpts, $rpending_logfile_message, $binmode );
- my $buf = $postfilter->($postfilter_buffer);
+
+ 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 ) {
+ $logger_object->warning(
+"assertion failure: '--assert-tidy' is set but output differs from input\n"
+ );
+ }
+ }
+ 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"
+ );
+ }
+ }
+
$source_object =
Perl::Tidy::LineSource->new( \$buf, $rOpts,
$rpending_logfile_message );
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 only some of the multiple files may have had errors.
+
NORMAL_EXIT:
- return 0;
+ my $ret = $Warn_count ? 2 : 0;
+ return $ret;
ERROR_EXIT:
return 1;
$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->( '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->( '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' );
########################################
$category = 6; # Controlling list formatting
'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:
nowarning-output
character-encoding=none
one-line-block-semicolons=1
+ one-line-block-nesting=0
outdent-labels
outdent-long-quotes
outdent-long-comments
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
$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;
+ }
+
# 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
Basic Options:
-i=n use n columns per indentation level (default n=4)
- -t tabs: use one tab character per indentation level, not recommeded
+ -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.
return;
}
-=pod
-sub do_syntax_check {
- my ( $stream, $flags, $error_redirection ) = @_;
-
- ############################################################
- # This code is not reachable because syntax check is deactivated,
- # but it is retained for reference.
- ############################################################
-
- # We need a named input file for executing perl
- my ( $stream_filename, $is_tmpfile ) = get_stream_as_named_file($stream);
-
- # TODO: Need to add name of file to log somewhere
- # otherwise Perl output is hard to read
- if ( !$stream_filename ) { return $stream_filename, "" }
-
- # We have to quote the filename in case it has unusual characters
- # or spaces. Example: this filename #CM11.pm# gives trouble.
- my $quoted_stream_filename = '"' . $stream_filename . '"';
-
- # Under VMS something like -T will become -t (and an error) so we
- # will put quotes around the flags. Double quotes seem to work on
- # Unix/Windows/VMS, but this may not work on all systems. (Single
- # quotes do not work under Windows). It could become necessary to
- # put double quotes around each flag, such as: -"c" -"T"
- # We may eventually need some system-dependent coding here.
- $flags = '"' . $flags . '"';
-
- # now wish for luck...
- my $msg = qx/perl $flags $quoted_stream_filename $error_redirection/;
-
- if ($is_tmpfile) {
- unlink $stream_filename
- or Perl::Tidy::Die("couldn't unlink stream $stream_filename: $!\n");
- }
- return $stream_filename, $msg;
-}
-=cut
-
1;
=head1 ERROR HANDLING
-Perltidy will return with an error flag indicating if 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 this flag because if it is set the destination stream will
-be empty or incomplete and should be ignored. Error messages in the B<stderr>
-stream will indicate the cause of any problem.
-
-If the error flag is not set then perltidy ran to completion. However there
-may still be warning messages in the B<stderr> stream related to control
-parameters, and there may be warning messages in the B<errorfile> stream
-relating to possible syntax errors in the source code being tidied.
+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 B<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 B<stderr> stream related to parameter errors or
+conflicts and/or warning messages in the B<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
B<perltidy> terminates by making calls to B<croak> or B<confess> to help the
&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 20190601
+This man page documents Perl::Tidy version 20200110
=head1 LICENSE
package Perl::Tidy::Debugger;
use strict;
use warnings;
-our $VERSION = '20190601';
+our $VERSION = '20200110';
sub new {
package Perl::Tidy::DevNull;
use strict;
use warnings;
-our $VERSION = '20190601';
-sub new { my $self = shift; return bless {}, $self }
+our $VERSION = '20200110';
+sub new { my $self = shift; return bless {}, $self }
sub print { return }
sub close { return }
package Perl::Tidy::Diagnostics;
use strict;
use warnings;
-our $VERSION = '20190601';
+our $VERSION = '20200110';
sub new {
package Perl::Tidy::FileWriter;
use strict;
use warnings;
-our $VERSION = '20190601';
+our $VERSION = '20200110';
# Maximum number of little messages; probably need not be changed.
my $MAX_NAG_MESSAGES = 6;
use strict;
use warnings;
use Carp;
-our $VERSION = '20190601';
+our $VERSION = '20200110';
# The Tokenizer will be loaded with the Formatter
##use Perl::Tidy::Tokenizer; # for is_keyword()
@levels_to_go
@leading_spaces_to_go
@reduced_spaces_to_go
- @matching_token_to_go
@mate_index_to_go
@ci_levels_to_go
@nesting_depth_to_go
%is_anon_sub_1_brace_follower
%is_sort_map_grep
%is_sort_map_grep_eval
+ %want_one_line_block
%is_sort_map_grep_eval_do
%is_block_without_semicolon
%is_if_unless
$gnu_position_predictor = 0; # where the current token is predicted to be
$max_gnu_stack_index = 0;
$max_gnu_item_index = -1;
- $gnu_stack[0] = new_lp_indentation_item( 0, -1, -1, 0, 0 );
- @gnu_item_list = ();
- $last_output_indentation = 0;
- $last_indentation_written = 0;
- $last_unadjusted_indentation = 0;
- $last_leading_token = "";
+ $gnu_stack[0] = new_lp_indentation_item( 0, -1, -1, 0, 0 );
+ @gnu_item_list = ();
+ $last_output_indentation = 0;
+ $last_indentation_written = 0;
+ $last_unadjusted_indentation = 0;
+ $last_leading_token = "";
$last_output_short_opening_token = 0;
$saw_VERSION_in_this_file = !$rOpts->{'pass-version-line'};
@summed_lengths_to_go = (); # line length to start of ith token
@token_lengths_to_go = ();
@levels_to_go = ();
- @matching_token_to_go = ();
@mate_index_to_go = ();
@ci_levels_to_go = ();
@nesting_depth_to_go = (0);
K_closing_container => {}, # for quickly traversing structure
K_opening_ternary => {}, # for quickly traversing structure
K_closing_ternary => {}, # for quickly traversing structure
+ rcontainer_map => {}, # hierarchical map of containers
rK_phantom_semicolons =>
undef, # for undoing phantom semicolons if iterating
rpaired_to_inner_container => {},
rbreak_container => {}, # prevent one-line blocks
+ rshort_nested => {}, # blocks not forced open
rvalid_self_keys => [], # for checking
valign_batch_count => 0,
};
my ( $package0, $filename0, $line0, $subroutine0 ) = caller(0);
my ( $package1, $filename1, $line1, $subroutine1 ) = caller(1);
my ( $package2, $filename2, $line2, $subroutine2 ) = caller(2);
+ my $input_stream_name = $logger_object->get_input_stream_name();
Die(<<EOM);
==============================================================================
-Fault detected at line $line0 of sub '$subroutine1'
+While operating on input stream with name: '$input_stream_name'
+A fault was detected at line $line0 of sub '$subroutine1'
in file '$filename1'
which was called from line $line1 of sub '$subroutine2'
Message: '$msg'
# 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 withing them according to input parameters. Note
+ # 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.
next;
}
+ # Handle block comment to be deleted
+ elsif ( $CODE_type eq 'DEL' ) {
+ $self->flush();
+ next;
+ }
+
# Handle all other lines of code
$self->print_line_of_tokens($line_of_tokens);
}
# 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->{'tee-pod'} ) { $tee_line = 1; }
+ if ( $rOpts->{'tee-pod'} ) { $tee_line = 1; }
if ( $rOpts->{'trim-pod'} ) { $input_line =~ s/\s+$// }
if ( !$skip_line
&& !$in_format_skipping_section
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 }
+
my @tokary;
@tokary[
_TOKEN_, _TYPE_,
$rblock_type->[$j], $rcontainer_type->[$j],
$rcontainer_environment->[$j], $rtype_sequence->[$j],
$rlevels->[$j], $rlevels->[$j],
- $rslevels->[$j], $rci_levels->[$j],
+ $slevel, $rci_levels->[$j],
$input_line_no,
);
push @{$rLL}, \@tokary;
$binary_ws_rules{'t'}{'L'} = WS_NO;
$binary_ws_rules{'t'}{'{'} = WS_NO;
$binary_ws_rules{'}'}{'L'} = WS_NO;
- $binary_ws_rules{'}'}{'{'} = 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;
# A sub to store one token in the new array
# All new tokens must be stored by this sub so that it can update
# all data structures on the fly.
- my $last_nonblank_type = ';';
- my $store_token = sub {
+ my $last_nonblank_type = ';';
+ my $last_nonblank_token = ';';
+ my $last_nonblank_block_type = '';
+ my $store_token = sub {
my ($item) = @_;
# This will be the index of this item in the new array
$item->[_CUMULATIVE_LENGTH_] = $cumulative_length;
my $type = $item->[_TYPE_];
- if ( $type ne 'b' ) { $last_nonblank_type = $type }
+
+ # trim side comments
+ if ( $type eq '#' ) {
+ $item->[_TOKEN_] =~ s/\s*$//;
+ }
+
+ if ( $type && $type ne 'b' && $type ne '#' ) {
+ $last_nonblank_type = $type;
+ $last_nonblank_token = $item->[_TOKEN_];
+ $last_nonblank_block_type = $item->[_BLOCK_TYPE_];
+ }
# and finally, add this item to the new array
push @{$rLL_new}, $item;
# 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 >= $Kmax ); # skip terminal blank
+ next if ( $KK >= $Klast ); # skip terminal blank
my $Knext = $KK + 1;
my $ws = $rwhitespace_flags->[$Knext];
if ( $ws == -1
}
if ( $token =~ /$SUB_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;
}
# check a quote for problems
elsif ( $type eq 'Q' ) {
+ $check_Q->( $KK, $Kfirst );
+ }
+
+ # handle semicolons
+ elsif ( $type eq ';' ) {
+
+ # Remove unnecessary semicolons, but not after bare
+ # blocks, where it could be unsafe if the brace is
+ # mistokenized.
+ if (
+ $rOpts->{'delete-semicolons'}
+ && (
+ (
+ $last_nonblank_type eq '}'
+ && (
+ $is_block_without_semicolon{
+ $last_nonblank_block_type}
+ || $last_nonblank_block_type =~ /$SUB_PATTERN/
+ || $last_nonblank_block_type =~ /^\w+:$/ )
+ )
+ || $last_nonblank_type eq ';'
+ )
+ )
+ {
+
+ # This looks like a deletable semicolon, but even if a
+ # semicolon can be deleted it is necessarily best to do so.
+ # We apply these additional rules for deletion:
+ # - Always ok to delete a ';' at the end of a line
+ # - Never delete a ';' before a '#' because it would
+ # promote it to a block comment.
+ # - If a semicolon is not at the end of line, then only
+ # delete if it is followed by another semicolon or closing
+ # token. This includes the comment rule. It may take
+ # two passes to get to a final state, but it is a little
+ # safer. For example, keep the first semicolon here:
+ # eval { sub bubba { ok(0) }; ok(0) } || ok(1);
+ # It is not required but adds some clarity.
+ my $ok_to_delete = 1;
+ if ( $KK < $Klast ) {
+ my $Kn = $self->K_next_nonblank($KK);
+ if ( defined($Kn) && $Kn <= $Klast ) {
+ my $next_nonblank_token_type =
+ $rLL->[$Kn]->[_TYPE_];
+ $ok_to_delete = $next_nonblank_token_type eq ';'
+ || $next_nonblank_token_type eq '}';
+ }
+ }
- # This is ready to go but is commented out because there is
- # still identical logic in sub break_lines.
- # $check_Q->($KK, $Kfirst);
+ if ($ok_to_delete) {
+ note_deleted_semicolon();
+ next;
+ }
+ else {
+ write_logfile_entry("Extra ';'\n");
+ }
+ }
}
elsif ($type_sequence) {
}
}
-=pod
- # NOTE: This does not work yet. Version in print-line-of-tokens
- # is Still used until fixed
-
- # 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)
- # Note: this test is placed here because we know the continuation flag
- # at this point, which allows us to avoid non-meaningful checks.
- my $structural_indentation_level = $rLL->[$Kfirst]->[_LEVEL_];
- compare_indentation_levels( $guessed_indentation_level,
- $structural_indentation_level )
- unless ( $rLL->[$Kfirst]->[_CI_LEVEL_] > 0
- || $guessed_indentation_level == 0
- && $rLL->[$Kfirst]->[_TYPE_] eq 'Q' );
-=cut
-
# 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.
return;
}
+sub map_containers {
+
+ # Maps the container hierarchy
+ my $self = shift;
+ my $rLL = $self->{rLL};
+ return unless ( defined($rLL) && @{$rLL} );
+
+ my $K_opening_container = $self->{K_opening_container};
+ my $K_closing_container = $self->{K_closing_container};
+ my $rcontainer_map = $self->{rcontainer_map};
+
+ # loop over containers
+ my @stack; # stack of container sequence numbers
+ my $KNEXT = 0;
+ while ( defined($KNEXT) ) {
+ my $KK = $KNEXT;
+ $KNEXT = $rLL->[$KNEXT]->[_KNEXT_SEQ_ITEM_];
+ my $rtoken_vars = $rLL->[$KK];
+ my $type_sequence = $rtoken_vars->[_TYPE_SEQUENCE_];
+ if ( !$type_sequence ) {
+ next if ( $KK == 0 ); # first token in file may not be container
+ Fault("sequence = $type_sequence not defined at K=$KK");
+ }
+
+ my $token = $rtoken_vars->[_TOKEN_];
+ if ( $is_opening_token{$token} ) {
+ if (@stack) {
+ $rcontainer_map->{$type_sequence} = $stack[-1];
+ }
+ push @stack, $type_sequence;
+ }
+ if ( $is_closing_token{$token} ) {
+ if (@stack) {
+ my $seqno = pop @stack;
+ if ( $seqno != $type_sequence ) {
+
+ # shouldn't happen unless file is garbage
+ }
+ }
+ }
+ }
+
+ # the stack should be empty for a good file
+ if (@stack) {
+
+ # unbalanced containers; file probably bad
+ }
+ else {
+ # ok
+ }
+ return;
+}
+
+sub mark_short_nested_blocks {
+
+ # This routine looks at the entire file and marks any short nested blocks
+ # which should not be broken. The results are stored in the hash
+ # $rshort_nested->{$type_sequence}
+ # which will be true if the container should remain intact.
+ #
+ # For example, consider the following line:
+
+ # sub cxt_two { sort { $a <=> $b } test_if_list() }
+
+ # The 'sort' block is short and nested within an outer sub block.
+ # Normally, the existance of the 'sort' block will force the sub block to
+ # break open, but this is not always desirable. Here we will set a flag for
+ # the sort block to prevent this. To give the user control, we will
+ # follow the input file formatting. If either of the blocks is broken in
+ # the input file then we will allow it to remain broken. Otherwise we will
+ # set a flag to keep it together in later formatting steps.
+
+ # The flag which is set here will be checked in two places:
+ # 'sub print_line_of_tokens' and 'sub starting_one_line_block'
+
+ my $self = shift;
+ my $rLL = $self->{rLL};
+ return unless ( defined($rLL) && @{$rLL} );
+
+ return unless ( $rOpts->{'one-line-block-nesting'} );
+
+ my $K_opening_container = $self->{K_opening_container};
+ my $K_closing_container = $self->{K_closing_container};
+ my $rbreak_container = $self->{rbreak_container};
+ my $rshort_nested = $self->{rshort_nested};
+ my $rcontainer_map = $self->{rcontainer_map};
+ my $rlines = $self->{rlines};
+
+ # Variables needed for estimating line lengths
+ my $starting_indent;
+ my $starting_lentot;
+ my $length_tol = 1;
+
+ my $excess_length_to_K = sub {
+ my ($K) = @_;
+
+ # Estimate the length from the line start to a given token
+ my $length = $self->cumulative_length_before_K($K) - $starting_lentot;
+ my $excess_length =
+ $starting_indent + $length + $length_tol - $rOpts_maximum_line_length;
+ return ($excess_length);
+ };
+
+ my $is_broken_block = sub {
+
+ # a block is broken if the input line numbers of the braces differ
+ my ($seqno) = @_;
+ my $K_opening = $K_opening_container->{$seqno};
+ return unless ( defined($K_opening) );
+ my $K_closing = $K_closing_container->{$seqno};
+ return unless ( defined($K_closing) );
+ return $rbreak_container->{$seqno}
+ || $rLL->[$K_closing]->[_LINE_INDEX_] !=
+ $rLL->[$K_opening]->[_LINE_INDEX_];
+ };
+
+ # loop over all containers
+ my @open_block_stack;
+ my $iline = -1;
+ my $KNEXT = 0;
+ while ( defined($KNEXT) ) {
+ my $KK = $KNEXT;
+ $KNEXT = $rLL->[$KNEXT]->[_KNEXT_SEQ_ITEM_];
+ my $rtoken_vars = $rLL->[$KK];
+ my $type_sequence = $rtoken_vars->[_TYPE_SEQUENCE_];
+ if ( !$type_sequence ) {
+ next if ( $KK == 0 ); # first token in file may not be container
+
+ # an error here is most likely due to a recent programming change
+ Fault("sequence = $type_sequence not defined at K=$KK");
+ }
+
+ # We are just looking at code blocks
+ my $token = $rtoken_vars->[_TOKEN_];
+ my $type = $rtoken_vars->[_TYPE_];
+ next unless ( $type eq $token );
+ my $block_type = $rtoken_vars->[_BLOCK_TYPE_];
+ next unless ($block_type);
+
+ # Keep a stack of all acceptable block braces seen.
+ # Only consider blocks entirely on one line so dump the stack when line
+ # changes.
+ my $iline_last = $iline;
+ $iline = $rLL->[$KK]->[_LINE_INDEX_];
+ if ( $iline != $iline_last ) { @open_block_stack = () }
+
+ if ( $token eq '}' ) {
+ if (@open_block_stack) { pop @open_block_stack }
+ }
+ next unless ( $token eq '{' );
+
+ # block must be balanced (bad scripts may be unbalanced)
+ my $K_opening = $K_opening_container->{$type_sequence};
+ my $K_closing = $K_closing_container->{$type_sequence};
+ next unless ( defined($K_opening) && defined($K_closing) );
+
+ # require that this block be entirely on one line
+ next if ( $is_broken_block->($type_sequence) );
+
+ # See if this block fits on one line of allowed length (which may
+ # be different from the input script)
+ $starting_lentot =
+ $KK <= 0 ? 0 : $rLL->[ $KK - 1 ]->[_CUMULATIVE_LENGTH_];
+ $starting_indent = 0;
+ if ( !$rOpts_variable_maximum_line_length ) {
+ my $level = $rLL->[$KK]->[_LEVEL_];
+ $starting_indent = $rOpts_indent_columns * $level;
+ }
+
+ # Dump the stack if block is too long and skip this block
+ if ( $excess_length_to_K->($K_closing) > 0 ) {
+ @open_block_stack = ();
+ next;
+ }
+
+ # OK, Block passes tests, remember it
+ push @open_block_stack, $type_sequence;
+
+ # We are only marking nested code blocks,
+ # so check for a previous block on the stack
+ next unless ( @open_block_stack > 1 );
+
+ # Looks OK, mark this as a short nested block
+ $rshort_nested->{$type_sequence} = 1;
+
+ }
+ return;
+}
+
sub weld_containers {
# do any welding operations
# loop over structure items to find cuddled pairs
my $level = 0;
- my $KK = 0;
- while ( defined( $KK = $rLL->[$KK]->[_KNEXT_SEQ_ITEM_] ) ) {
+ my $KNEXT = 0;
+ while ( defined($KNEXT) ) {
+ my $KK = $KNEXT;
+ $KNEXT = $rLL->[$KNEXT]->[_KNEXT_SEQ_ITEM_];
my $rtoken_vars = $rLL->[$KK];
my $type_sequence = $rtoken_vars->[_TYPE_SEQUENCE_];
if ( !$type_sequence ) {
- Fault("sequence = $type_sequence not defined");
+ next if ( $KK == 0 ); # first token in file may not be container
+ Fault("sequence = $type_sequence not defined at K=$KK");
}
# We use the original levels because they get changed by sub
# Do not weld if this makes our line too long
$do_not_weld ||= $excess_length_to_K->($Kinner_opening) > 0;
+ # DO-NOT-WELD RULE 4; implemented for git#10:
+ # Do not weld an opening -ce brace if the next container is on a single
+ # line, different from the opening brace. (This is very rare). For
+ # example, given the following with -ce, we will avoid joining the {
+ # and [
+
+ # } else {
+ # [ $_, length($_) ]
+ # }
+
+ # because this would produce a terminal one-line block:
+
+ # } else { [ $_, length($_) ] }
+
+ # which may not be what is desired. But given this input:
+
+ # } else { [ $_, length($_) ] }
+
+ # then we will do the weld and retain the one-line block
+ if ( $rOpts->{'cuddled-else'} ) {
+ my $block_type = $rLL->[$Kouter_opening]->[_BLOCK_TYPE_];
+ if ( $block_type && $rcuddled_block_types->{'*'}->{$block_type} ) {
+ my $io_line = $inner_opening->[_LINE_INDEX_];
+ my $ic_line = $inner_closing->[_LINE_INDEX_];
+ my $oo_line = $outer_opening->[_LINE_INDEX_];
+ $do_not_weld ||=
+ ( $oo_line < $io_line && $ic_line == $io_line );
+ }
+ }
+
if ($do_not_weld) {
# After neglecting a pair, we start measuring from start of point io
};
# look for single qw quotes nested in containers
- my $KK = 0;
- while ( defined( $KK = $rLL->[$KK]->[_KNEXT_SEQ_ITEM_] ) ) {
+ my $KNEXT = 0;
+ while ( defined($KNEXT) ) {
+ my $KK = $KNEXT;
+ $KNEXT = $rLL->[$KNEXT]->[_KNEXT_SEQ_ITEM_];
my $rtoken_vars = $rLL->[$KK];
my $outer_seqno = $rtoken_vars->[_TYPE_SEQUENCE_];
if ( !$outer_seqno ) {
- Fault("sequence = $outer_seqno not defined");
+ next if ( $KK == 0 ); # first token in file may not be container
+ Fault("sequence = $outer_seqno not defined at K=$KK");
}
my $token = $rtoken_vars->[_TOKEN_];
$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';
+ }
+ }
}
}
# remains fixed for the rest of this iteration.
$self->respace_tokens();
+ # Make a hierarchical map of the containers
+ $self->map_containers();
+
# Implement any welding needed for the -wn or -cb options
$self->weld_containers();
+ # Locate small nested blocks which should not be broken
+ $self->mark_short_nested_blocks();
+
# 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
# return length of tokens ($ibeg .. $iend) including $ibeg & $iend
# returns 0 if $ibeg > $iend (shouldn't happen)
my ( $ibeg, $iend ) = @_;
- return 0 if ( $iend < 0 || $ibeg > $iend );
+ return 0 if ( $iend < 0 || $ibeg > $iend );
return $summed_lengths_to_go[ $iend + 1 ] if ( $ibeg < 0 );
return $summed_lengths_to_go[ $iend + 1 ] - $summed_lengths_to_go[$ibeg];
}
write_logfile_entry(
" Last at input line $last_deleted_semicolon_at\n");
}
- write_logfile_entry(" (Use -ndsc to prevent semicolon deletion)\n");
+ write_logfile_entry(" (Use -ndsm to prevent semicolon deletion)\n");
write_logfile_entry("\n");
}
}
}
+ make_sub_matching_pattern();
make_bli_pattern();
make_block_brace_vertical_tightness_pattern();
make_blank_line_pattern();
make_keyword_group_list_pattern();
+ # Make initial list of desired one line block types
+ # They will be modified by 'prepare_cuddled_block_types'
+ %want_one_line_block = %is_sort_map_grep_eval;
+
prepare_cuddled_block_types();
if ( $rOpts->{'dump-cuddled-block-list'} ) {
dump_cuddled_block_list(*STDOUT);
'?' => ':',
);
+ if ( $rOpts->{'ignore-old-breakpoints'} ) {
+ if ( $rOpts->{'break-at-old-method-breakpoints'} ) {
+ Warn("Conflicting parameters: -iob and -bom; -bom will be ignored\n"
+ );
+ }
+ if ( $rOpts->{'break-at-old-comma-breakpoints'} ) {
+ Warn("Conflicting parameters: -iob and -boc; -boc will be ignored\n"
+ );
+ }
+
+ # Note: there are additional parameters that can be made inactive by
+ # -iob, but they are on by default so we would generate excessive
+ # warnings if we noted them. They are:
+ # $rOpts->{'break-at-old-keyword-breakpoints'}
+ # $rOpts->{'break-at-old-logical-breakpoints'}
+ # $rOpts->{'break-at-old-ternary-breakpoints'}
+ # $rOpts->{'break-at-old-attribute-breakpoints'}
+ }
+
# frequently used parameters
$rOpts_add_newlines = $rOpts->{'add-newlines'};
$rOpts_add_whitespace = $rOpts->{'add-whitespace'};
$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;
return;
}
+sub make_sub_matching_pattern {
+
+ $SUB_PATTERN = '^sub\s+(::|\w)';
+ $ASUB_PATTERN = '^sub$';
+
+ if ( $rOpts->{'sub-alias-list'} ) {
+
+ # Note that any 'sub-alias-list' has been preprocessed to
+ # be a trimmed, space-separated list which includes 'sub'
+ # for example, it might be 'sub method fun'
+ my $sub_alias_list = $rOpts->{'sub-alias-list'};
+ $sub_alias_list =~ s/\s+/\|/g;
+ $SUB_PATTERN =~ s/sub/\($sub_alias_list\)/;
+ $ASUB_PATTERN =~ s/sub/\($sub_alias_list\)/;
+ }
+ return;
+}
+
sub make_bli_pattern {
if ( defined( $rOpts->{'brace-left-and-indent-list'} )
$container_environment_to_go[$max_index_to_go] = $container_environment;
$ci_levels_to_go[$max_index_to_go] = $ci_level;
$mate_index_to_go[$max_index_to_go] = -1;
- $matching_token_to_go[$max_index_to_go] = '';
$bond_strength_to_go[$max_index_to_go] = 0;
# Note: negative levels are currently retained as a diagnostic so that
return;
}
- sub insert_new_token_to_go {
-
- # insert a new token into the output stream. use same level as
- # previous token; assumes a character at max_index_to_go.
- my ( $self, @args ) = @_;
- save_current_token();
- ( $token, $type, $slevel, $no_internal_newlines ) = @args;
-
- if ( $max_index_to_go == UNDEFINED_INDEX ) {
- warning("code bug: bad call to insert_new_token_to_go\n");
- }
- $level = $levels_to_go[$max_index_to_go];
-
- # FIXME: it seems to be necessary to use the next, rather than
- # previous, value of this variable when creating a new blank (align.t)
- #my $slevel = $nesting_depth_to_go[$max_index_to_go];
- $ci_level = $ci_levels_to_go[$max_index_to_go];
- $container_environment = $container_environment_to_go[$max_index_to_go];
- $in_continued_quote = 0;
- $block_type = "";
- $type_sequence = "";
-
- # store an undef for the K value to catch unexpected usage
- # This routine is only called by add_closing_side_comments, and
- # eventually that call will be eliminated.
- $Ktoken_vars = undef;
-
- $self->store_token_to_go();
- restore_current_token();
- return;
- }
-
sub copy_hash {
my ($rold_token_hash) = @_;
my %new_token_hash =
my $rLL = $self->{rLL};
my $rbreak_container = $self->{rbreak_container};
+ my $rshort_nested = $self->{rshort_nested};
if ( !defined($K_first) ) {
- # Unexpected blank line..
- # Calling routine was supposed to handle this
- Warn(
-"Programming Error: Unexpected Blank Line in print_line_of_tokens. Ignoring"
- );
+ # Empty line: This can happen if tokens are deleted, for example
+ # with the -mangle parameter
return;
}
######################################
if ($is_comment) {
- if ( $rOpts->{'delete-block-comments'} ) { return }
-
if ( $rOpts->{'tee-block-comments'} ) {
$file_writer_object->tee_on();
}
return;
}
- # TODO: Move to sub scan_comments
# 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)
- # Note: this test is placed here because we know the continuation flag
- # at this point, which allows us to avoid non-meaningful checks.
my $structural_indentation_level = $rinput_token_array->[0]->[_LEVEL_];
compare_indentation_levels( $guessed_indentation_level,
$structural_indentation_level )
if ( $type eq '#' ) {
- # trim trailing whitespace
- # (there is no option at present to prevent this)
- $token =~ s/\s*$//;
-
if (
$rOpts->{'delete-side-comments'}
$next_nonblank_token_type =
$rinput_token_array->[$j_next]->[_TYPE_];
- ######################
- # MAYBE MOVE ELSEWHERE?
- ######################
- if ( $type eq 'Q' ) {
- note_embedded_tab() if ( $token =~ "\t" );
-
- # 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|\/)/
- && $last_nonblank_token =~ /^(=|==|!=)$/
-
- # preceded by simple scalar
- && $last_last_nonblank_type eq 'i'
- && $last_last_nonblank_token =~ /^\$/
-
- # followed by some kind of termination
- # (but give complaint if we can's see far enough ahead)
- && $next_nonblank_token =~ /^[; \)\}]$/
-
- # scalar is not declared
- && !(
- $types_to_go[0] eq 'k'
- && $tokens_to_go[0] =~ /^(my|our|local)$/
- )
- )
- {
- my $guess = substr( $last_nonblank_token, 0, 1 ) . '~';
- complain(
-"Note: be sure you want '$last_nonblank_token' instead of '$guess' here\n"
- );
- }
- }
-
# 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
( $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
destroy_one_line_block();
}
- # Remove unnecessary semicolons, but not after bare
- # blocks, where it could be unsafe if the brace is
- # mistokenized.
- if (
- (
- $last_nonblank_token eq '}'
- && (
- $is_block_without_semicolon{
- $last_nonblank_block_type}
- || $last_nonblank_block_type =~ /$SUB_PATTERN/
- || $last_nonblank_block_type =~ /^\w+:$/ )
- )
- || $last_nonblank_type eq ';'
- )
- {
-
- if (
- $rOpts->{'delete-semicolons'}
-
- # don't delete ; before a # because it would promote it
- # to a block comment
- && ( $next_nonblank_token_type ne '#' )
- )
- {
- note_deleted_semicolon();
- $self->output_line_to_go()
- unless ( $no_internal_newlines
- || $index_start_one_line_block != UNDEFINED_INDEX );
- next;
- }
- else {
- write_logfile_entry("Extra ';'\n");
- }
- }
$self->store_token_to_go();
$self->output_line_to_go()
};
# Do not end line in a weld
- # TODO: Move this fix into the routine?
- #my $jnb = $max_index_to_go;
- #if ( $jnb > 0 && $types_to_go[$jnb] eq 'b' ) { $jnb-- }
return if ( weld_len_right_to_go($max_index_to_go) );
# just set a tentative breakpoint if we might be in a one-line block
return;
}
-## my $cscw_block_comment;
-## $cscw_block_comment = $self->add_closing_side_comment()
-## if ( $rOpts->{'closing-side-comments'} && $max_index_to_go >= 0 );
-
my $comma_arrow_count_contained = match_opening_and_closing_tokens();
# tell the -lp option we are outputting a batch so it can close
my $leading_type = $types_to_go[$imin];
# blank lines before subs except declarations and one-liners
- # MCONVERSION LOCATION - for sub tokenization change
if ( $leading_token =~ /^(sub\s)/ && $leading_type eq 'i' ) {
$want_blank = $rOpts->{'blank-lines-before-subs'}
- if (
- terminal_type( \@types_to_go, \@block_type_to_go, $imin,
- $imax ) !~ /^[\;\}]$/
- );
+ if ( $self->terminal_type_i( $imin, $imax ) !~ /^[\;\}]$/ );
}
# break before all package declarations
- # MCONVERSION LOCATION - for tokenizaton change
elsif ($leading_token =~ /^(package\s)/
&& $leading_type eq 'i' )
{
# break before certain key blocks except one-liners
if ( $leading_token =~ /^(BEGIN|END)$/ && $leading_type eq 'k' ) {
$want_blank = $rOpts->{'blank-lines-before-subs'}
- if (
- terminal_type( \@types_to_go, \@block_type_to_go, $imin,
- $imax ) ne '}'
- );
+ if ( $self->terminal_type_i( $imin, $imax ) ne '}' );
}
# Break before certain block types if we haven't had a
&& $lc >= $rOpts->{'long-block-line-count'}
&& consecutive_nonblank_lines() >=
$rOpts->{'long-block-line-count'}
- && (
- terminal_type( \@types_to_go, \@block_type_to_go, $imin,
- $imax ) ne '}'
- );
+ && $self->terminal_type_i( $imin, $imax ) ne '}';
}
# Check for blank lines wanted before a closing brace
else {
( $ri_first, $ri_last, my $colon_count ) =
- set_continuation_breaks($saw_good_break);
+ $self->set_continuation_breaks($saw_good_break);
- break_all_chain_tokens( $ri_first, $ri_last );
+ $self->break_all_chain_tokens( $ri_first, $ri_last );
break_equals( $ri_first, $ri_last );
recombine_breakpoints( $ri_first, $ri_last );
}
- insert_final_breaks( $ri_first, $ri_last ) if $colon_count;
+ $self->insert_final_breaks( $ri_first, $ri_last ) if $colon_count;
}
# do corrector step if -lp option is used
if ( $rOpts_one_line_block_semicolons == 0 ) {
$self->delete_one_line_semicolons( $ri_first, $ri_last );
}
- $self->send_lines_to_vertical_aligner( $ri_first, $ri_last,
- $do_not_pad );
+
+ # The line breaks for this batch of code have been finalized. Now we
+ # can to package the results for further processing. We will switch
+ # from the local '_to_go' buffer arrays (i-index) back to the global
+ # token arrays (K-index) at this point.
+ my $rlines_K;
+ my $index_error;
+ for ( my $n = 0 ; $n < @{$ri_first} ; $n++ ) {
+ my $ibeg = $ri_first->[$n];
+ my $Kbeg = $K_to_go[$ibeg];
+ my $iend = $ri_last->[$n];
+ my $Kend = $K_to_go[$iend];
+ if ( $iend - $ibeg != $Kend - $Kbeg ) {
+ $index_error = $n unless defined($index_error);
+ }
+ push @{$rlines_K},
+ [ $Kbeg, $Kend, $forced_breakpoint_to_go[$iend] ];
+ }
+
+ # Check correctness of the mapping between the i and K token indexes
+ if ( defined($index_error) ) {
+
+ # Temporary debug code - should never get here
+ for ( my $n = 0 ; $n < @{$ri_first} ; $n++ ) {
+ my $ibeg = $ri_first->[$n];
+ my $Kbeg = $K_to_go[$ibeg];
+ my $iend = $ri_last->[$n];
+ my $Kend = $K_to_go[$iend];
+ my $idiff = $iend - $ibeg;
+ my $Kdiff = $Kend - $Kbeg;
+ print STDERR <<EOM;
+line $n, irange $ibeg-$iend = $idiff, Krange $Kbeg-$Kend = $Kdiff;
+EOM
+ }
+ Fault("Index error at line $index_error; i and K ranges differ");
+ }
+
+ my $rbatch_hash = {
+ rlines_K => $rlines_K,
+ do_not_pad => $do_not_pad,
+ ibeg0 => $ri_first->[0],
+ };
+
+ $self->send_lines_to_vertical_aligner($rbatch_hash);
# Insert any requested blank lines after an opening brace. We have to
# skip back before any side comment to find the terminal token
prepare_for_new_input_lines();
-## # output any new -cscw block comment
-## if ($cscw_block_comment) {
-## $self->flush();
-## $file_writer_object->write_code_line( $cscw_block_comment . "\n" );
-## }
return;
}
$first_deleted_semicolon_at = $last_deleted_semicolon_at;
}
$deleted_semicolon_count++;
- write_logfile_entry("Deleted unnecessary ';'\n"); # i hope ;)
+ write_logfile_entry("Deleted unnecessary ';' at line $input_line_number\n");
return;
}
my ( $self, $j, $jmax, $level, $slevel, $ci_level, $rtoken_array ) = @_;
my $rbreak_container = $self->{rbreak_container};
+ my $rshort_nested = $self->{rshort_nested};
my $jmax_check = @{$rtoken_array};
if ( $jmax_check < $jmax ) {
if ( $rtoken_array->[$i]->[_TYPE_] eq 'b' ) { $pos += 1 }
else { $pos += rtoken_length($i) }
+ # ignore some small blocks
+ my $type_sequence = $rtoken_array->[$i]->[_TYPE_SEQUENCE_];
+ my $nobreak = $rshort_nested->{$type_sequence};
+
# Return false result if we exceed the maximum line length,
if ( $pos > maximum_line_length($i_start) ) {
return 0;
}
- # or encounter another opening brace before finding the closing brace.
+ # keep going for non-containers
+ elsif ( !$type_sequence ) {
+
+ }
+
+ # return if we encounter another opening brace before finding the
+ # closing brace.
elsif ($rtoken_array->[$i]->[_TOKEN_] eq '{'
&& $rtoken_array->[$i]->[_TYPE_] eq '{'
- && $rtoken_array->[$i]->[_BLOCK_TYPE_] )
+ && $rtoken_array->[$i]->[_BLOCK_TYPE_]
+ && !$nobreak )
{
return 0;
}
# if we find our closing brace..
elsif ($rtoken_array->[$i]->[_TOKEN_] eq '}'
&& $rtoken_array->[$i]->[_TYPE_] eq '}'
- && $rtoken_array->[$i]->[_BLOCK_TYPE_] )
+ && $rtoken_array->[$i]->[_BLOCK_TYPE_]
+ && !$nobreak )
{
# be sure any trailing comment also fits on the line
# we keep old one-line blocks but do not form new ones. It is not
# always a good idea to make as many one-line blocks as possible,
# so other types are not done. The user can always use -mangle.
- if ( $is_sort_map_grep_eval{$block_type} ) {
+ if ( $want_one_line_block{$block_type} ) {
create_one_line_block( $i_start, 1 );
}
return 0;
# map { $_, $lookup->{$_} }
# sort { $a <=> $b }
# grep { $lookup->{$_} ne $default } keys %$lookup );
- my ( $ri_first, $ri_last ) = @_;
+ my ( $self, $ri_first, $ri_last ) = @_;
my ( $line_1, $line_2, $lev_last );
my $this_line_is_semicolon_terminated;
my $max_line = @{$ri_first} - 1;
sub pad_token {
# insert $pad_spaces before token number $ipad
- my ( $ipad, $pad_spaces ) = @_;
+ my ( $self, $ipad, $pad_spaces ) = @_;
+ my $rLL = $self->{rLL};
if ( $pad_spaces > 0 ) {
$tokens_to_go[$ipad] = ' ' x $pad_spaces . $tokens_to_go[$ipad];
}
return;
}
+ # Keep token arrays in sync
+ $self->sync_token_K($ipad);
+
$token_lengths_to_go[$ipad] += $pad_spaces;
foreach my $i ( $ipad .. $max_index_to_go ) {
$summed_lengths_to_go[ $i + 1 ] += $pad_spaces;
# &Error_OutOfRange;
# }
#
- my ( $ri_first, $ri_last ) = @_;
+ my ( $self, $ri_first, $ri_last ) = @_;
my $max_line = @{$ri_first} - 1;
# FIXME: move these declarations below
# find any unclosed container
next
unless ( $type_sequence_to_go[$i]
- && $mate_index_to_go[$i] > $iend );
+ && $self->mate_index_to_go($i) > $iend );
# find next nonblank token to pad
$ipad = $inext_to_go[$i];
my $i2 = $ri_last->[$l];
if ( $types_to_go[$i2] eq '#' ) {
my $i1 = $ri_first->[$l];
- next
- if (
- terminal_type( \@types_to_go, \@block_type_to_go,
- $i1, $i2 ) eq ','
- );
+ next if $self->terminal_type_i( $i1, $i2 ) eq ',';
}
}
if ( $pad_spaces == -1 ) {
if ( $ipad > $ibeg && $types_to_go[ $ipad - 1 ] eq 'b' )
{
- pad_token( $ipad - 1, $pad_spaces );
+ $self->pad_token( $ipad - 1, $pad_spaces );
}
}
$pad_spaces = 0;
my $length_t = total_line_length( $ibeg, $iend );
if ( $pad_spaces + $length_t <= maximum_line_length($ibeg) )
{
- pad_token( $ipad, $pad_spaces );
+ $self->pad_token( $ipad, $pad_spaces );
}
}
}
my $self = shift;
# add closing side comments after closing block braces if -csc used
- my $cscw_block_comment;
+ my ( $closing_side_comment, $cscw_block_comment );
#---------------------------------------------------------------
# Step 1: loop through all tokens of this line to accumulate
# ..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
+ && $self->mate_index_to_go($i_terminal) < 0
# ..and either
&& (
}
# switch to the new csc (unless we deleted it!)
- $tokens_to_go[$max_index_to_go] = $token if $token;
+ if ($token) {
+ $tokens_to_go[$max_index_to_go] = $token;
+ $self->sync_token_K($max_index_to_go);
+ }
}
# handle case of NO existing closing side comment
else {
- # Remove any existing blank and add another below.
- # This is a tricky point. A side comment needs to have the same level
- # as the preceding closing brace or else the line will not get the right
- # indentation. So even if we have a blank, we are going to replace it.
- if ( $types_to_go[$max_index_to_go] eq 'b' ) {
- unstore_token_to_go();
- }
-
- # insert the new side comment into the output token stream
- my $type = '#';
- my $block_type = '';
- my $type_sequence = '';
- my $container_environment =
- $container_environment_to_go[$max_index_to_go];
- my $level = $levels_to_go[$max_index_to_go];
- my $slevel = $nesting_depth_to_go[$max_index_to_go];
- my $no_internal_newlines = 0;
-
- my $ci_level = $ci_levels_to_go[$max_index_to_go];
- my $in_continued_quote = 0;
-
- # insert a blank token
- $self->insert_new_token_to_go( ' ', 'b', $slevel,
- $no_internal_newlines );
-
- # then the side comment
- $self->insert_new_token_to_go( $token, $type, $slevel,
- $no_internal_newlines );
+ # 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 $cscw_block_comment;
+ return ( $closing_side_comment, $cscw_block_comment );
}
sub previous_nonblank_token {
sub send_lines_to_vertical_aligner {
- my ( $self, $ri_first, $ri_last, $do_not_pad ) = @_;
+ my ( $self, $rbatch_hash ) = @_;
- my $valign_batch_number = $self->increment_valign_batch_count();
+ # This routine receives a batch of code for which the final line breaks
+ # have been defined. Here we prepare the lines for passing to the vertical
+ # aligner. We do the following tasks:
+ # - mark certain vertical alignment tokens tokens, such as '=', in each line.
+ # - make minor indentation adjustments
+ # - insert extra blank spaces to help display certain logical constructions
- my $cscw_block_comment;
- if ( $rOpts->{'closing-side-comments'} && $max_index_to_go >= 0 ) {
- $cscw_block_comment = $self->add_closing_side_comment();
+ my $rlines_K = $rbatch_hash->{rlines_K};
+ if ( !@{$rlines_K} ) {
+ Fault("Unexpected call with no lines");
+ return;
+ }
+ my $n_last_line = @{$rlines_K} - 1;
+ my $do_not_pad = $rbatch_hash->{do_not_pad};
- # Add or update any closing side comment
- if ( $types_to_go[$max_index_to_go] eq '#' ) {
- $ri_last->[-1] = $max_index_to_go;
- }
+ my $rLL = $self->{rLL};
+ my $Klimit = $self->{Klimit};
+
+ my ( $Kbeg_next, $Kend_next ) = @{ $rlines_K->[0] };
+ my $type_beg_next = $rLL->[$Kbeg_next]->[_TYPE_];
+ my $token_beg_next = $rLL->[$Kbeg_next]->[_TOKEN_];
+ my $type_end_next = $rLL->[$Kend_next]->[_TYPE_];
+
+ # Construct indexes to the global_to_go arrays so that called routines can
+ # still access those arrays. This might eventually be removed
+ # when all called routines have been converted to access token values
+ # in the rLL array instead.
+ my $ibeg0 = $rbatch_hash->{ibeg0};
+ my $Kbeg0 = $Kbeg_next;
+ my ( $ri_first, $ri_last );
+ foreach my $rline ( @{$rlines_K} ) {
+ my ( $Kbeg, $Kend ) = @{$rline};
+ my $ibeg = $ibeg0 + $Kbeg - $Kbeg0;
+ my $iend = $ibeg0 + $Kend - $Kbeg0;
+ push @{$ri_first}, $ibeg;
+ push @{$ri_last}, $iend;
+ }
+ #####################################################################
+
+ my $valign_batch_number = $self->increment_valign_batch_count();
+
+ my ( $cscw_block_comment, $closing_side_comment );
+ if ( $rOpts->{'closing-side-comments'} ) {
+ ( $closing_side_comment, $cscw_block_comment ) =
+ $self->add_closing_side_comment();
}
my $rindentation_list = [0]; # ref to indentations for each line
- # define the array @matching_token_to_go for the output tokens
+ # 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.
- set_vertical_alignment_markers( $ri_first, $ri_last );
-
- # flush if necessary to avoid unwanted alignment
- my $must_flush = 0;
- if ( @{$ri_first} > 1 ) {
+ my $ralignment_type_to_go =
+ $self->set_vertical_alignment_markers( $ri_first, $ri_last );
- # flush before a long if statement
- if ( $types_to_go[0] eq 'k' && $tokens_to_go[0] =~ /^(if|unless)$/ ) {
- $must_flush = 1;
- }
- }
- if ($must_flush) {
+ # flush before a long if statement to avoid unwanted alignment
+ if ( $n_last_line > 0
+ && $type_beg_next eq 'k'
+ && $token_beg_next =~ /^(if|unless)$/ )
+ {
Perl::Tidy::VerticalAligner::flush();
}
- undo_ci( $ri_first, $ri_last );
+ $self->undo_ci( $ri_first, $ri_last );
- set_logical_padding( $ri_first, $ri_last );
+ $self->set_logical_padding( $ri_first, $ri_last );
# loop to prepare each line for shipment
- my $n_last_line = @{$ri_first} - 1;
my $in_comma_list;
+ my ( $Kbeg, $type_beg, $token_beg );
+ my ( $Kend, $type_end );
for my $n ( 0 .. $n_last_line ) {
- my $ibeg = $ri_first->[$n];
- my $iend = $ri_last->[$n];
-
- my ( $rtokens, $rfields, $rpatterns ) =
- make_alignment_patterns( $ibeg, $iend );
- # Set flag to show how much level changes between this line
- # and the next line, if we have it.
- my $ljump = 0;
+ my $ibeg = $ri_first->[$n];
+ my $iend = $ri_last->[$n];
+ my $rline = $rlines_K->[$n];
+ my $forced_breakpoint = $rline->[2];
+
+ # we may need to look at variables on three consecutive lines ...
+
+ # Some vars on line [n-1], if any:
+ my $Kbeg_last = $Kbeg;
+ my $type_beg_last = $type_beg;
+ my $token_beg_last = $token_beg;
+ my $Kend_last = $Kend;
+ my $type_end_last = $type_end;
+
+ # Some vars on line [n]:
+ $Kbeg = $Kbeg_next;
+ $type_beg = $type_beg_next;
+ $token_beg = $token_beg_next;
+ $Kend = $Kend_next;
+ $type_end = $type_end_next;
+
+ # We use two slightly different definitions of level jump at the end
+ # of line:
+ # $ljump is the level jump needed by 'sub set_adjusted_indentation'
+ # $level_jump is the level jump needed by the vertical aligner.
+ my $ljump = 0; # level jump at end of line
+
+ # Get some vars on line [n+1], if any:
if ( $n < $n_last_line ) {
- my $ibegp = $ri_first->[ $n + 1 ];
- $ljump = $levels_to_go[$ibegp] - $levels_to_go[$iend];
+ ( $Kbeg_next, $Kend_next ) =
+ @{ $rlines_K->[ $n + 1 ] };
+ $type_beg_next = $rLL->[$Kbeg_next]->[_TYPE_];
+ $token_beg_next = $rLL->[$Kbeg_next]->[_TOKEN_];
+ $type_end_next = $rLL->[$Kend_next]->[_TYPE_];
+ $ljump = $rLL->[$Kbeg_next]->[_LEVEL_] - $rLL->[$Kend]->[_LEVEL_];
}
+ # level jump at end of line for the vertical aligner:
+ my $level_jump =
+ $Kend >= $Klimit
+ ? 0
+ : $rLL->[ $Kend + 1 ]->[_SLEVEL_] - $rLL->[$Kbeg]->[_SLEVEL_];
+
+ $self->delete_needless_alignments( $ibeg, $iend,
+ $ralignment_type_to_go );
+
+ my ( $rtokens, $rfields, $rpatterns ) =
+ $self->make_alignment_patterns( $ibeg, $iend,
+ $ralignment_type_to_go );
+
my ( $indentation, $lev, $level_end, $terminal_type,
$is_semicolon_terminated, $is_outdented_line )
= $self->set_adjusted_indentation( $ibeg, $iend, $rfields, $rpatterns,
my $outdent_long_lines = (
# which are long quotes, if allowed
- ( $types_to_go[$ibeg] eq 'Q' && $rOpts->{'outdent-long-quotes'} )
+ ( $type_beg eq 'Q' && $rOpts->{'outdent-long-quotes'} )
# which are long block comments, if allowed
|| (
- $types_to_go[$ibeg] eq '#'
+ $type_beg eq '#'
&& $rOpts->{'outdent-long-comments'}
# but not if this is a static block comment
)
);
- my $level_jump =
- $nesting_depth_to_go[ $iend + 1 ] - $nesting_depth_to_go[$ibeg];
-
my $rvertical_tightness_flags =
- set_vertical_tightness_flags( $n, $n_last_line, $ibeg, $iend,
+ $self->set_vertical_tightness_flags( $n, $n_last_line, $ibeg, $iend,
$ri_first, $ri_last );
# flush an outdented line to avoid any unwanted vertical alignment
# );
#
my $is_terminal_ternary = 0;
- if ( $tokens_to_go[$ibeg] eq ':'
- || $n > 0 && $tokens_to_go[ $ri_last->[ $n - 1 ] ] eq ':' )
- {
- my $last_leading_type = ":";
- if ( $n > 0 ) {
- my $iprev = $ri_first->[ $n - 1 ];
- $last_leading_type = $types_to_go[$iprev];
- }
+
+ 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 )
{
- my $inext = $ri_first->[ $n + 1 ];
- $level_end = $levels_to_go[$inext];
- $terminal_type = $types_to_go[$inext];
+ $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 ) )
+ )
+ {
- $is_terminal_ternary = $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;
- # the terminal term must not contain any ternary terms, as in
- # my $ECHO = (
- # $Is_MSWin32 ? ".\\echo$$"
- # : $Is_MacOS ? ":echo$$"
- # : ( $Is_NetWare ? "echo$$" : "./echo$$" )
- # );
- && !grep { /^[\?\:]$/ } @types_to_go[ $ibeg + 1 .. $iend ];
+ 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_];
+ }
+ }
}
- # send this new line down the pipe
- my $forced_breakpoint = $forced_breakpoint_to_go[$iend];
+ # add any new closing side comment to the last line
+ if ( $closing_side_comment && $n == $n_last_line && @{$rfields} ) {
+ $rfields->[-1] .= " $closing_side_comment";
+ }
+ # send this new line down the pipe
my $rvalign_hash = {};
- $rvalign_hash->{level} = $lev;
- $rvalign_hash->{level_end} = $level_end;
- $rvalign_hash->{indentation} = $indentation;
- $rvalign_hash->{is_forced_break} =
- $forced_breakpoint_to_go[$iend] || $in_comma_list;
+ $rvalign_hash->{level} = $lev;
+ $rvalign_hash->{level_end} = $level_end;
+ $rvalign_hash->{indentation} = $indentation;
+ $rvalign_hash->{is_forced_break} = $forced_breakpoint || $in_comma_list;
$rvalign_hash->{outdent_long_lines} = $outdent_long_lines;
$rvalign_hash->{is_terminal_ternary} = $is_terminal_ternary;
$rvalign_hash->{is_terminal_statement} = $is_semicolon_terminated;
Perl::Tidy::VerticalAligner::valign_input( $rvalign_hash, $rfields,
$rtokens, $rpatterns );
- $in_comma_list =
- $tokens_to_go[$iend] eq ',' && $forced_breakpoint_to_go[$iend];
+ $in_comma_list = $type_end eq ',' && $forced_breakpoint;
# flush an outdented line to avoid any unwanted vertical alignment
Perl::Tidy::VerticalAligner::flush() if ($is_outdented_line);
$last_output_short_opening_token
# line ends in opening token
- = $types_to_go[$iend] =~ /^[\{\(\[L]$/
+ = $type_end =~ /^[\{\(\[L]$/
# and either
&& (
# line has either single opening token
- $iend == $ibeg
+ $Kend == $Kbeg
# or is a single token followed by opening token.
# Note that sub identifiers have blanks like 'sub doit'
- || ( $iend - $ibeg <= 2 && $tokens_to_go[$ibeg] !~ /\s+/ )
+ || ( $Kend - $Kbeg <= 2 && $token_beg !~ /\s+/ )
)
# and limit total to 10 character widths
# remember indentation of lines containing opening containers for
# later use by sub set_adjusted_indentation
- save_opening_indentation( $ri_first, $ri_last, $rindentation_list );
+ $self->save_opening_indentation( $ri_first, $ri_last, $rindentation_list );
# output any new -cscw block comment
if ($cscw_block_comment) {
my %block_type_map;
my %keyword_map;
+ my %operator_map;
BEGIN {
# treat an 'undef' similar to numbers and quotes
'undef' => 'Q',
);
+
+ # map certain operators to the same class for pattern matching
+ %operator_map = (
+ '!~' => '=~',
+ '+=' => '+=',
+ '-=' => '+=',
+ '*=' => '+=',
+ '/=' => '+=',
+ );
+ }
+
+ sub delete_needless_alignments {
+ my ( $self, $ibeg, $iend, $ralignment_type_to_go ) = @_;
+
+ # Remove unwanted alignments. This routine is a place to remove
+ # alignments which might cause problems at later stages. There are
+ # currently two types of fixes:
+
+ # 1. Remove excess parens
+ # 2. Remove alignments within 'elsif' conditions
+
+ # Patch #1: Excess alignment of parens can prevent other good
+ # alignments. For example, note the parens in the first two rows of
+ # the following snippet. They would normally get marked for alignment
+ # and aligned as follows:
+
+ # my $w = $columns * $cell_w + ( $columns + 1 ) * $border;
+ # my $h = $rows * $cell_h + ( $rows + 1 ) * $border;
+ # my $img = new Gimp::Image( $w, $h, RGB );
+
+ # This causes unnecessary paren alignment and prevents the third equals
+ # from aligning. If we remove the unwanted alignments we get:
+
+ # my $w = $columns * $cell_w + ( $columns + 1 ) * $border;
+ # my $h = $rows * $cell_h + ( $rows + 1 ) * $border;
+ # my $img = new Gimp::Image( $w, $h, RGB );
+
+ # A rule for doing this which works well is to remove alignment of
+ # parens whose containers do not contain other aligning tokens, with
+ # the exception that we always keep alignment of the first opening
+ # paren on a line (for things like 'if' and 'elsif' statements).
+
+ # Setup needed constants
+ my $i_good_paren = -1;
+ my $imin_match = $iend + 1;
+ my $i_elsif_close = $ibeg - 1;
+ my $i_elsif_open = $iend + 1;
+ if ( $iend > $ibeg ) {
+ if ( $types_to_go[$ibeg] eq 'k' ) {
+
+ # Paren patch: mark a location of a paren we should keep, such
+ # as one following something like a leading 'if', 'elsif',..
+ $i_good_paren = $ibeg + 1;
+ if ( $types_to_go[$i_good_paren] eq 'b' ) {
+ $i_good_paren++;
+ }
+
+ # 'elsif' patch: remember the range of the parens of an elsif,
+ # and do not make alignments within them because this can cause
+ # loss of padding and overall brace alignment in the vertical
+ # aligner.
+ if ( $tokens_to_go[$ibeg] eq 'elsif'
+ && $i_good_paren < $iend
+ && $tokens_to_go[$i_good_paren] eq '(' )
+ {
+ $i_elsif_open = $i_good_paren;
+ $i_elsif_close = $self->mate_index_to_go($i_good_paren);
+ }
+ }
+ }
+
+ # Loop to make the fixes on this line
+ my @imatch_list;
+ for my $i ( $ibeg .. $iend ) {
+
+ if ( $ralignment_type_to_go->[$i] ne '' ) {
+
+ # Patch #2: undo alignment within elsif parens
+ if ( $i > $i_elsif_open && $i < $i_elsif_close ) {
+ $ralignment_type_to_go->[$i] = '';
+ next;
+ }
+ push @imatch_list, $i;
+
+ }
+ if ( $tokens_to_go[$i] eq ')' ) {
+
+ # Patch #1: undo the corresponding opening paren if:
+ # - it is at the top of the stack
+ # - and not the first overall opening paren
+ # - does not follow a leading keyword on this line
+ my $imate = $self->mate_index_to_go($i);
+ if ( @imatch_list
+ && $imatch_list[-1] eq $imate
+ && ( $ibeg > 1 || @imatch_list > 1 )
+ && $imate > $i_good_paren )
+ {
+ $ralignment_type_to_go->[$imate] = '';
+ pop @imatch_list;
+ }
+ }
+ }
+ return;
}
sub make_alignment_patterns {
# @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 ( $ibeg, $iend ) = @_;
+ my ( $self, $ibeg, $iend, $ralignment_type_to_go ) = @_;
my @tokens = ();
my @fields = ();
my @patterns = ();
my $j = 0; # field index
$patterns[0] = "";
+ my %token_count;
for my $i ( $ibeg .. $iend ) {
# Keep track of containers balanced on this line only.
if ( $tok =~ /^[\(\{\[]/ ) { #'(' ) {
# if container is balanced on this line...
- my $i_mate = $mate_index_to_go[$i];
+ my $i_mate = $self->mate_index_to_go($i);
if ( $i_mate > $i && $i_mate <= $iend ) {
$depth++;
my $seqno = $type_sequence_to_go[$i];
# matches.
# if we are not aligning on this paren...
- if ( $matching_token_to_go[$i] eq '' ) {
-
- # Sum length from previous alignment, or start of line.
- my $len =
- ( $i_start == $ibeg )
- ? total_line_length( $i_start, $i - 1 )
- : token_sequence_length( $i_start, $i - 1 );
+ if ( $ralignment_type_to_go->[$i] eq '' ) {
+
+ # Sum length from previous alignment
+ my $len = token_sequence_length( $i_start, $i - 1 );
+ if ( $i_start == $ibeg ) {
+
+ # For first token, use distance from start of line
+ # but subtract off the indentation due to level.
+ # Otherwise, results could vary with indentation.
+ $len += leading_spaces_to_go($ibeg) -
+ $levels_to_go[$i_start] * $rOpts_indent_columns;
+ if ( $len < 0 ) { $len = 0 }
+ }
- # tack length onto the container name to make unique
+ # tack this length onto the container name to try
+ # to make a unique token name
$container_name[$depth] .= "-" . $len;
}
}
# if we find a new synchronization token, we are done with
# a field
- if ( $i > $i_start && $matching_token_to_go[$i] ne '' ) {
+ if ( $i > $i_start && $ralignment_type_to_go->[$i] ne '' ) {
- my $tok = my $raw_tok = $matching_token_to_go[$i];
+ my $tok = my $raw_tok = $ralignment_type_to_go->[$i];
# map similar items
- if ( $tok eq '!~' ) { $tok = '=~' }
+ 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.
$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,
# saves indentations of lines of all unmatched opening tokens.
# These will be used by sub get_opening_indentation.
- my ( $ri_first, $ri_last, $rindentation_list ) = @_;
+ my ( $self, $ri_first, $ri_last, $rindentation_list ) = @_;
# we no longer need indentations of any saved indentations which
# are unmatched closing tokens in this batch, because we will
# which matches the token at index $i_opening
# -and its offset (number of columns) from the start of the line
#
- my ( $i_closing, $ri_first, $ri_last, $rindentation_list ) = @_;
+ my ( $self, $i_closing, $ri_first, $ri_last, $rindentation_list ) = @_;
# first, see if the opening token is in the current batch
my $i_opening = $mate_index_to_go[$i_closing];
my ( $i_opening, $ri_start, $ri_last, $rindentation_list ) = @_;
+ if ( !@{$ri_last} ) {
+ warning("Error in opening_indentation: no lines");
+ return;
+ }
+
my $nline = $rindentation_list->[0]; # line number of previous lookup
# reset line location if necessary
# we need to know the last token of this line
my ( $terminal_type, $i_terminal ) =
- terminal_type( \@types_to_go, \@block_type_to_go, $ibeg, $iend );
+ $self->terminal_type_i( $ibeg, $iend );
my $is_outdented_line = 0;
$opening_indentation, $opening_offset,
$is_leading, $opening_exists
)
- = get_opening_indentation( $ibeg_weld_fix, $ri_first, $ri_last,
- $rindentation_list );
+ = $self->get_opening_indentation( $ibeg_weld_fix, $ri_first,
+ $ri_last, $rindentation_list );
# First set the default behavior:
if (
# 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 a indentation jump larger than 1 level.
+ # 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 ( defined($K_next_nonblank) ) {
+
+ # Patch for RT#131115: honor -bli flag at closing brace
+ my $is_bli =
+ $rOpts_brace_left_and_indent
+ && $block_type_to_go[$i_terminal]
+ && $block_type_to_go[$i_terminal] =~ /$bli_pattern/o;
+
+ if ( !$is_bli && defined($K_next_nonblank) ) {
my $lev = $rLL->[$K_beg]->[_LEVEL_];
my $level_next = $rLL->[$K_next_nonblank]->[_LEVEL_];
$adjust_indentation = 1 if ( $level_next < $lev );
$opening_indentation, $opening_offset,
$is_leading, $opening_exists
)
- = get_opening_indentation( $ibeg, $ri_first, $ri_last,
- $rindentation_list );
+ = $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) >
$opening_indentation, $opening_offset,
$is_leading, $opening_exists
)
- = get_opening_indentation( $ibeg, $ri_first, $ri_last,
+ = $self->get_opening_indentation( $ibeg, $ri_first, $ri_last,
$rindentation_list );
my $indentation = $leading_spaces_to_go[$ibeg];
if ( defined($opening_indentation)
$opening_indentation, $opening_offset,
$is_leading, $opening_exists
)
- = get_opening_indentation( $ibeg, $ri_first, $ri_last,
+ = $self->get_opening_indentation( $ibeg, $ri_first, $ri_last,
$rindentation_list );
if ($is_leading) { $adjust_indentation = 2; }
}
# 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 = (
- # $iend == $ibeg ) && $block_type_to_go[$ibeg];
+ # an isolated brace
#############################################################
my $is_isolated_block_brace = $block_type_to_go[$ibeg]
- && ( $iend == $ibeg
+ && ( $i_terminal == $ibeg
|| $is_if_elsif_else_unless_while_until_for_foreach{
$block_type_to_go[$ibeg]
} );
}
}
+sub mate_index_to_go {
+ my ( $self, $i ) = @_;
+
+ # Return the matching index of a container or ternary pair
+ # This is equivalent to the array @mate_index_to_go
+ my $K = $K_to_go[$i];
+ my $K_mate = $self->K_mate_index($K);
+ my $i_mate = -1;
+ if ( defined($K_mate) ) {
+ $i_mate = $i + ( $K_mate - $K );
+ if ( $i_mate < 0 || $i_mate > $max_index_to_go ) {
+ $i_mate = -1;
+ }
+ }
+ my $i_mate_alt = $mate_index_to_go[$i];
+
+ # Debug code to eventually be removed
+ if ( 0 && $i_mate_alt != $i_mate ) {
+ my $tok = $tokens_to_go[$i];
+ my $type = $types_to_go[$i];
+ my $tok_mate = '*';
+ my $type_mate = '*';
+ if ( $i_mate >= 0 && $i_mate <= $max_index_to_go ) {
+ $tok_mate = $tokens_to_go[$i_mate];
+ $type_mate = $types_to_go[$i_mate];
+ }
+ my $seq = $type_sequence_to_go[$i];
+ my $file = $logger_object->get_input_stream_name();
+
+ Warn(
+"mate_index: file '$file': i=$i, imate=$i_mate, should be $i_mate_alt, K=$K, K_mate=$K_mate\ntype=$type, tok=$tok, seq=$seq, max=$max_index_to_go, tok_mate=$tok_mate, type_mate=$type_mate"
+ );
+ }
+ return $i_mate;
+}
+
+sub K_mate_index {
+
+ # Given the index K of an opening or closing container, or ?/: ternary pair,
+ # return the index K of the other member of the pair.
+ my ( $self, $K ) = @_;
+ return unless defined($K);
+ my $rLL = $self->{rLL};
+ my $seqno = $rLL->[$K]->[_TYPE_SEQUENCE_];
+ return unless ($seqno);
+
+ my $K_opening = $self->{K_opening_container}->{$seqno};
+ if ( defined($K_opening) ) {
+ if ( $K != $K_opening ) { return $K_opening }
+ return $self->{K_closing_container}->{$seqno};
+ }
+
+ $K_opening = $self->{K_opening_ternary}->{$seqno};
+ if ( defined($K_opening) ) {
+ if ( $K != $K_opening ) { return $K_opening }
+ return $self->{K_closing_ternary}->{$seqno};
+ }
+ return;
+}
+
sub set_vertical_tightness_flags {
- my ( $n, $n_last_line, $ibeg, $iend, $ri_first, $ri_last ) = @_;
+ my ( $self, $n, $n_last_line, $ibeg, $iend, $ri_first, $ri_last ) = @_;
# Define vertical tightness controls for the nth line of a batch.
# We create an array of parameters which tell the vertical aligner
my $is_semicolon_terminated;
if ( $n + 1 == $n_last_line ) {
- my ( $terminal_type, $i_terminal ) = terminal_type(
- \@types_to_go, \@block_type_to_go,
- $ibeg_next, $iend_next
- );
+ my ( $terminal_type, $i_terminal ) =
+ $self->terminal_type_i( $ibeg_next, $iend_next );
$is_semicolon_terminated = $terminal_type eq ';'
&& $nesting_depth_to_go[$iend_next] <
$nesting_depth_to_go[$ibeg_next];
{
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 {
#;
@is_vertical_alignment_type{@q} = (1) x scalar(@q);
- # only align these at end of line
+ # 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);
# vertical alignment markers (such as an '=').
#
# Method: We look at each token $i in this output batch and set
- # $matching_token_to_go[$i] equal to those tokens at which we would
+ # $ralignment_type_to_go->[$i] equal to those tokens at which we would
# accept vertical alignment.
- my ( $ri_first, $ri_last ) = @_;
+ my ( $self, $ri_first, $ri_last ) = @_;
+
+ my $ralignment_type_to_go;
+ for my $i ( 0 .. $max_index_to_go ) {
+ $ralignment_type_to_go->[$i] = '';
+ }
# nothing to do if we aren't allowed to change whitespace
if ( !$rOpts_add_whitespace ) {
- for my $i ( 0 .. $max_index_to_go ) {
- $matching_token_to_go[$i] = '';
- }
- return;
+ return $ralignment_type_to_go;
}
# remember the index of last nonblank token before any sidecomment
$vert_last_nonblank_block_type = '';
# look at each token in this output line..
- my $count = 0;
+ 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];
- # check for flag indicating that we should not align
- # this token
- if ( $matching_token_to_go[$i] ) {
- $matching_token_to_go[$i] = '';
+ # do not align tokens at lower level then start of line
+ # except for side comments
+ if ( $levels_to_go[$i] < $levels_to_go[$ibeg]
+ && $types_to_go[$i] ne '#' )
+ {
+ $ralignment_type_to_go->[$i] = '';
next;
}
# align before one of these types..
# Note: add '.' after new vertical aligner is operational
- elsif ( $is_vertical_alignment_type{$type} ) {
+ elsif ( $is_vertical_alignment_type{$type}
+ && !$is_not_vertical_alignment_token{$token} )
+ {
$alignment_type = $token;
# Do not align a terminal token. Although it might
# $code =
# ( $case_matters ? $accessor : " lc($accessor) " )
# . ( $yesno ? " eq " : " ne " )
+
+ # Also, do not align a ( following a leading ? so we can
+ # align something like this:
+ # $converter{$_}->{ushortok} =
+ # $PDL::IO::Pic::biggrays
+ # ? ( m/GIF/ ? 0 : 1 )
+ # : ( m/GIF|RAST|IFF/ ? 0 : 1 );
if ( $i == $ibeg + 2
- && $types_to_go[$ibeg] =~ /^[\.\:]$/
+ && $types_to_go[$ibeg] =~ /^[\.\:\?]$/
&& $types_to_go[ $i - 1 ] eq 'b' )
{
$alignment_type = "";
}
+ # Certain tokens only align at the same level as the
+ # initial line level
+ if ( $is_low_level_alignment_token{$token}
+ && $levels_to_go[$i] != $level_beg )
+ {
+ $alignment_type = "";
+ }
+
# For a paren after keyword, only align something like this:
# if ( $a ) { &a }
# elsif ( $b ) { &b }
- if ( $token eq '(' && $vert_last_nonblank_type eq 'k' ) {
- $alignment_type = ""
- unless $vert_last_nonblank_token =~
- /^(if|unless|elsif)$/;
+ if ( $token eq '(' ) {
+
+ if ( $vert_last_nonblank_type eq 'k' ) {
+ $alignment_type = ""
+ unless $vert_last_nonblank_token =~
+ /^(if|unless|elsif)$/;
+ }
}
# be sure the alignment tokens are unique
$alignment_type = $vert_last_nonblank_type;
}
- #--------------------------------------------------------
- # patch for =~ operator. We only align this if it
- # is the first operator in a line, and the line is a simple
- # statement. Aligning them within a statement
- # interferes could interfere with other good alignments.
- #--------------------------------------------------------
- if ( $alignment_type eq '=~' ) {
- my $terminal_type = $types_to_go[$i_terminal];
- if ( $count > 0 || $max_line > 0 || $terminal_type ne ';' )
- {
- $alignment_type = "";
- }
- }
-
#--------------------------------------------------------
# then store the value
#--------------------------------------------------------
- $matching_token_to_go[$i] = $alignment_type;
- $count++ if ($alignment_type);
+ $ralignment_type_to_go->[$i] = $alignment_type;
if ( $type ne 'b' ) {
$vert_last_nonblank_type = $type;
$vert_last_nonblank_token = $token;
}
}
}
- return;
+ return $ralignment_type_to_go;
}
}
-sub terminal_type {
+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 ( $rtype, $rblock_type, $ibeg, $iend ) = @_;
+ my ( $self, $ibeg, $iend ) = @_;
- # check for full-line comment..
- if ( $rtype->[$ibeg] eq '#' ) {
- return wantarray ? ( $rtype->[$ibeg], $ibeg ) : $rtype->[$ibeg];
+ # 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];
}
- else {
- # start at end and walk backwards..
- for ( my $i = $iend ; $i >= $ibeg ; $i-- ) {
+ # Skip past a blank
+ if ( $type_i eq 'b' ) {
+ $i--;
+ if ( $i < $ibeg ) {
+ return wantarray ? ( $type_i, $ibeg ) : $type_i;
+ }
+ $type_i = $types_to_go[$i];
+ }
+
+ # Found it..make sure it is a BLOCK termination,
+ # but hide a terminal } after sort/grep/map because it is not
+ # necessarily the end of the line. (terminal.t)
+ my $block_type = $block_type_to_go[$i];
+ if (
+ $type_i eq '}'
+ && ( !$block_type
+ || ( $is_sort_map_grep_eval_do{$block_type} ) )
+ )
+ {
+ $type_i = 'b';
+ }
+ return wantarray ? ( $type_i, $i ) : $type_i;
+}
+
+sub terminal_type_K {
- # skip past any side comment and blanks
- next if ( $rtype->[$i] eq 'b' );
- next if ( $rtype->[$i] eq '#' );
+ # 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
- # 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 $terminal_type = $rtype->[$i];
- if (
- $terminal_type eq '}'
- && ( !$rblock_type->[$i]
- || ( $is_sort_map_grep_eval_do{ $rblock_type->[$i] } ) )
- )
- {
- $terminal_type = 'b';
- }
- return wantarray ? ( $terminal_type, $i ) : $terminal_type;
+ my ( $self, $Kbeg, $Kend ) = @_;
+ my $rLL = $self->{rLL};
+
+ if ( !defined($Kend) ) {
+ Fault("Error in terminal_type_K: Kbeg=$Kbeg > $Kend=Kend");
+ }
+
+ # Start at the end and work backwards
+ my $K = $Kend;
+ my $type_K = $rLL->[$K]->[_TYPE_];
+
+ # Check for side comment
+ if ( $type_K eq '#' ) {
+ $K--;
+ if ( $K < $Kbeg ) {
+ return wantarray ? ( $type_K, $Kbeg ) : $type_K;
}
+ $type_K = $rLL->[$K]->[_TYPE_];
+ }
- # empty line
- return wantarray ? ( ' ', $ibeg ) : ' ';
+ # Skip past a blank
+ if ( $type_K eq 'b' ) {
+ $K--;
+ if ( $K < $Kbeg ) {
+ return wantarray ? ( $type_K, $Kbeg ) : $type_K;
+ }
+ $type_K = $rLL->[$K]->[_TYPE_];
}
+
+ # found it..make sure it is a BLOCK termination,
+ # but hide a terminal } after sort/grep/map because it is not
+ # necessarily the end of the line. (terminal.t)
+ my $block_type = $rLL->[$K]->[_BLOCK_TYPE_];
+ if (
+ $type_K eq '}'
+ && ( !$block_type
+ || ( $is_sort_map_grep_eval_do{$block_type} ) )
+ )
+ {
+ $type_K = 'b';
+ }
+ return wantarray ? ( $type_K, $K ) : $type_K;
+
}
{ # set_bond_strengths
my $i_break = $rcomma_index->[0];
set_forced_breakpoint($i_break);
${$rdo_not_break_apart} = 1;
- set_non_alignment_flags( $comma_count, $rcomma_index );
return;
}
${$rdo_not_break_apart} = 1;
}
}
- set_non_alignment_flags( $comma_count, $rcomma_index );
return;
}
${$rdo_not_break_apart} = 1;
}
}
- set_non_alignment_flags( $comma_count, $rcomma_index );
}
return;
}
}
}
-sub set_non_alignment_flags {
-
- # set flag which indicates that these commas should not be
- # aligned
- my ( $comma_count, $rcomma_index ) = @_;
- foreach ( 0 .. $comma_count - 1 ) {
- $matching_token_to_go[ $rcomma_index->[$_] ] = 1;
- }
- return;
-}
-
sub study_list_complexity {
# Look for complex tables which should be formatted with one term per line.
return;
}
+sub sync_token_K {
+ my ( $self, $i ) = @_;
+
+ # Keep tokens in the rLL array in sync with the _to_go array
+ my $rLL = $self->{rLL};
+ my $K = $K_to_go[$i];
+ if ( defined($K) ) {
+ $rLL->[$K]->[_TOKEN_] = $tokens_to_go[$i];
+ }
+ else {
+ # shouldn't happen
+ }
+ return;
+}
+
{ # begin recombine_breakpoints
my %is_amp_amp;
if ( $types_to_go[$i] eq ';' && $tokens_to_go[$i] eq '' ) {
$tokens_to_go[$i] = $want_left_space{';'} == WS_NO ? ';' : ' ;';
+ $self->sync_token_K($i);
my $line_number = 1 + $self->get_old_line_index( $K_to_go[$i] );
note_added_semicolon($line_number);
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 )
+ # 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 )
+ )
)
);
# statement. If we see a break at any one, break at all similar tokens
# within the same container.
#
- my ( $ri_left, $ri_right ) = @_;
+ my ( $self, $ri_left, $ri_right ) = @_;
my %saw_chain_type;
my %left_chain_type;
if ( $left_chain_type{$type} ) {
next if $nobreak_to_go[ $itest - 1 ];
foreach my $i ( @{ $left_chain_type{$type} } ) {
- next unless in_same_container( $i, $itest );
+ next unless $self->in_same_container_i( $i, $itest );
push @insert_list, $itest - 1;
# Break at matching ? if this : is at a different level.
if ( $right_chain_type{$type} ) {
next if $nobreak_to_go[$itest];
foreach my $i ( @{ $right_chain_type{$type} } ) {
- next unless in_same_container( $i, $itest );
+ next unless $self->in_same_container_i( $i, $itest );
push @insert_list, $itest;
# break at matching ? if this : is at a different level
sub insert_final_breaks {
- my ( $ri_left, $ri_right ) = @_;
+ my ( $self, $ri_left, $ri_right ) = @_;
my $nmax = @{$ri_right} - 1;
}
# For long ternary chains,
- # if the first : we see has its # ? is in the interior
+ # 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 ) {
$type eq ','
|| $type eq 'k' && ( $nmax > 1 && $token eq 'return' )
)
- && in_same_container( $ii, $i_question )
+ && $self->in_same_container_i( $ii, $i_question )
)
{
push @insert_list, $ii;
last;
}
-
-## # For now, a good break is either a comma or a 'return'.
-## if ( ( $type eq ',' || $type eq 'k' && $token eq 'return' )
-## && in_same_container( $ii, $i_question ) )
-## {
-## push @insert_list, $ii;
-## last;
-## }
}
# insert any new break points
return;
}
-sub in_same_container {
+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 :
- # FIXME: this can be written more efficiently now
- my ( $i1, $i2 ) = @_;
- my $type = $types_to_go[$i1];
- my $depth = $nesting_depth_to_go[$i1];
- return unless ( $nesting_depth_to_go[$i2] == $depth );
- if ( $i2 < $i1 ) { ( $i1, $i2 ) = ( $i2, $i1 ) }
-
- ###########################################################
- # This is potentially a very slow routine and not critical.
- # For safety just give up for large differences.
- # See test file 'infinite_loop.txt'
- # TODO: replace this loop with a data structure
- ###########################################################
- return if ( $i2 - $i1 > 200 );
-
- foreach my $i ( $i1 + 1 .. $i2 - 1 ) {
- next if ( $nesting_depth_to_go[$i] > $depth );
- return if ( $nesting_depth_to_go[$i] < $depth );
-
- my $tok = $tokens_to_go[$i];
- $tok = ',' if $tok eq '=>'; # treat => same as ,
+ # This is an interface between the _to_go arrays to the rLL array
+ my ( $self, $i1, $i2 ) = @_;
+ return $self->in_same_container_K( $K_to_go[$i1], $K_to_go[$i2] );
+}
+{ # sub in_same_container_K
+ my $ris_break_token;
+ my $ris_comma_token;
+
+ BEGIN {
+
+ # all cases break on seeing commas at same level
+ my @q = qw( => );
+ push @q, ',';
+ @{$ris_comma_token}{@q} = (1) x scalar(@q);
+
+ # Non-ternary text also breaks on seeing any of qw(? : || or )
# Example: we would not want to break at any of these .'s
# : "<A HREF=\"#item_" . htmlify( 0, $s2 ) . "\">$str</A>"
- if ( $type ne ':' ) {
- return if ( $tok =~ /^[\,\:\?]$/ ) || $tok eq '||' || $tok eq 'or';
+ 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 ':' );
+ }
}
- else {
- return if ( $tok =~ /^[\,]$/ );
+
+ # 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;
}
- return 1;
}
sub set_continuation_breaks {
# 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 $saw_good_break = shift;
- 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
+ my ( $self, $saw_good_break ) = @_;
+ my @i_first = (); # the first index to output
+ my @i_last = (); # the last index to output
+ my @i_colon_breaks = (); # needed to decide if we have to break at ?'s
if ( $types_to_go[0] eq ':' ) { push @i_colon_breaks, 0 }
set_bond_strengths();
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 $i_begin = $imin; # index for starting next iteration
my $leading_spaces = leading_spaces_to_go($imin);
my $line_count = 0;
# RT #104427: Dont break before opening sub brace because
# sub block breaks handled at higher level, unless
- # it looks like the preceeding list is long and broken
+ # it looks like the preceding list is long and broken
&& !(
$next_nonblank_block_type =~ /^sub\b/
&& ( $nesting_depth_to_go[$i_begin] ==
# do not break if statement is broken by side comment
next
- if (
- $tokens_to_go[$max_index_to_go] eq '#'
- && terminal_type( \@types_to_go, \@block_type_to_go, 0,
- $max_index_to_go ) !~ /^[\;\}]$/
- );
+ if ( $tokens_to_go[$max_index_to_go] eq '#'
+ && $self->terminal_type_i( 0, $max_index_to_go ) !~
+ /^[\;\}]$/ );
# no break needed if matching : is also on the line
next
return;
}
1;
-
package Perl::Tidy::HtmlWriter;
use strict;
use warnings;
-our $VERSION = '20190601';
+our $VERSION = '20200110';
use File::Basename;
use strict;
use warnings;
use Carp;
-our $VERSION = '20190601';
+our $VERSION = '20200110';
sub new {
my ( $package, $rscalar, $mode ) = @_;
use strict;
use warnings;
use Carp;
-our $VERSION = '20190601';
+our $VERSION = '20200110';
sub new {
my ( $package, $rarray, $mode ) = @_;
package Perl::Tidy::IndentationItem;
use strict;
use warnings;
-our $VERSION = '20190601';
+our $VERSION = '20200110';
sub new {
sub tentatively_decrease_available_spaces {
# We are asked to tentatively delete $spaces_needed of indentation
- # for a indentation item. We may want to undo this later. NOTE: if
+ # 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 ) = @_;
package Perl::Tidy::LineBuffer;
use strict;
use warnings;
-our $VERSION = '20190601';
+our $VERSION = '20200110';
sub new {
package Perl::Tidy::LineSink;
use strict;
use warnings;
-our $VERSION = '20190601';
+our $VERSION = '20200110';
sub new {
package Perl::Tidy::LineSource;
use strict;
use warnings;
-our $VERSION = '20190601';
+our $VERSION = '20200110';
sub new {
package Perl::Tidy::Logger;
use strict;
use warnings;
-our $VERSION = '20190601';
+our $VERSION = '20200110';
sub new {
- my ( $class, $rOpts, $log_file, $warning_file, $fh_stderr, $saw_extrude ) =
- @_;
+ my ( $class, $rOpts, $log_file, $warning_file, $fh_stderr, $saw_extrude,
+ $display_name )
+ = @_;
my $fh_warnings = $rOpts->{'standard-error-output'} ? $fh_stderr : undef;
: 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,
_warning_file => $warning_file,
_warning_count => 0,
_complaint_count => 0,
- _saw_code_bug => -1, # -1=no 0=maybe 1=for sure
- _saw_brace_error => 0,
- _saw_extrude => $saw_extrude,
- _output_array => [],
+ _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};
$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 }
- $fh_warnings->print("$input_line_number:\t$msg");
- $self->write_logfile_entry("WARNING: $msg");
+ 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 {
- $fh_warnings->print($msg);
$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("No further warnings will be given\n");
+ $fh_warnings->print(
+ $filename_stamp . "No further warnings will be given\n" );
}
}
return;
package Perl::Tidy::Tokenizer;
use strict;
use warnings;
-our $VERSION = '20190601';
+our $VERSION = '20200110';
use Perl::Tidy::LineBuffer;
%is_keyword_taking_list
%is_keyword_taking_optional_args
%is_q_qq_qw_qx_qr_s_y_tr_m
+ %is_sub
+ %is_package
};
# possible values of operator_expected()
return;
}
+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;
+ }
+ }
+ return;
+}
+
sub new {
my ( $class, @args ) = @_;
}
}
+sub get_unexpected_error_count {
+ my ($self) = shift;
+ return $self->{_unexpected_error_count};
+}
+
# interface to Perl::Tidy::Diagnostics routines
sub write_diagnostics {
my $msg = shift;
{
$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. Sometime after Perl 5.10 this seems to have
+ # been dropped, but we have to support it in order to format
+ # older programs. 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,
@_ = qw(use require);
@is_use_require{@_} = (1) x scalar(@_);
- my %is_sub_package;
- @_ = qw(sub package);
- @is_sub_package{@_} = (1) x scalar(@_);
-
# This hash holds the hash key in $tokenizer_self for these keywords:
my %is_format_END_DATA = (
'format' => '_in_format',
# but do not start on blanks and comments
if ( $id_scan_state && $pre_type !~ /[b#]/ ) {
- if ( $id_scan_state =~ /^(sub|package)/ ) {
+ if ( $is_sub{$id_scan_state} || $is_package{$id_scan_state} ) {
scan_id();
}
else {
elsif (
( $next_nonblank_token eq ':' )
&& ( $rtokens->[ $i_next + 1 ] ne ':' )
- && ( $i_next <= $max_token_index ) # colon on same line
+ && ( $i_next <= $max_token_index ) # colon on same line
&& label_ok()
)
{
}
# 'sub' || 'package'
- elsif ( $is_sub_package{$tok_kw} ) {
+ elsif ( $is_sub{$tok_kw} || $is_package{$tok_kw} ) {
error_if_expecting_OPERATOR()
if ( $expecting == OPERATOR );
scan_id();
if ( $type eq ';' && $tok =~ /\w/ ) { $fix_type = 'k' }
# output anonymous 'sub' as keyword
- if ( $type eq 't' && $tok eq 'sub' ) { $fix_type = 'k' }
+ if ( $type eq 't' && $is_sub{$tok} ) { $fix_type = 'k' }
# -----------------------------------------------------------------
# could change the interpretation of the statement.
else {
if ( $tok =~ /^([x\/\+\-\*\%\&\.\?\<]|\>\>)$/ ) {
- complain("operator in print statement not recommended\n");
+
+ # 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 print statement not recommended\n");
+ }
$op_expected = OPERATOR;
}
}
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;
}
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" );
# handle non-blank line; identifier, if any, must follow
unless ($blank_line) {
- if ( $id_scan_state eq 'sub' ) {
+ if ( $is_sub{$id_scan_state} ) {
( $i, $tok, $type, $id_scan_state ) = do_scan_sub(
$input_line, $i, $i_beg,
$tok, $type, $rtokens,
);
}
- elsif ( $id_scan_state eq 'package' ) {
+ 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 );
$attrs = $2;
# If we also found the sub name on this call then append PROTO.
- # This is not necessary but for compatability with previous
+ # This is not necessary but for compatibility with previous
# versions when the -csc flag is used:
if ( $match && $proto ) {
$tok .= $proto;
$statement_type = $tok;
}
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"
);
@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(sub);
+ @is_sub{@q} = (1) x scalar(@q);
+
+ @q = qw(package);
+ @is_package{@q} = (1) x scalar(@q);
+
# These keywords are handled specially in the tokenizer code:
my @special_keywords = qw(
do
package Perl::Tidy::VerticalAligner;
use strict;
use warnings;
-our $VERSION = '20190601';
+our $VERSION = '20200110';
use Perl::Tidy::VerticalAligner::Alignment;
use Perl::Tidy::VerticalAligner::Line;
my $jmax = @{$rfields} - 1;
return unless ( $jmax > 0 );
- #my $old_line = $group_lines[-1];
-
# check for balanced else block following if/elsif/unless
my $rfields_old = $old_line->get_rfields();
# If we had a peek at the subsequent line we could make a much better
# decision here, but for now this is not available.
for ( my $j = 1 ; $j < $jmax_new - 1 ; $j++ ) {
- my $new_tok = $rtokens->[$j];
- my $is_good_alignment = ( $new_tok =~ /^(=|\?|if|unless|\|\||\&\&)/ );
+ my $new_tok = $rtokens->[$j];
+
+ # git#16: do not consider fat commas as good aligmnents here
+ my $is_good_alignment =
+ ( $new_tok =~ /^(=|\?|if|unless|\|\||\&\&)/ && $new_tok !~ /^=>/ );
return if ($is_good_alignment);
}
my @new_lines = @group_lines;
initialize_for_new_group();
- ##my $has_terminal_ternary = $new_lines[-1]->{_is_terminal_ternary};
-
# remove unmatched tokens in all lines
delete_unmatched_tokens( \@new_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 ) {
elsif ( $new_line->get_jmax() == 1 && !$keep_group_intact ) {
- # There are no matching tokens, so now check side comments:
+ # 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 = $group_lines[-1]->get_rfields()->[-1];
my $side_comment = $new_line->get_rfields()->[-1];
my_flush_code() unless ( $side_comment && $prev_comment );
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) = @_;
+ 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);
+ }
+ return ( $raw_tok, $lev, $tag, $tok_count );
+}
+
{ # sub is_deletable_token
my %is_deletable_equals;
sub is_deletable_token {
- # Determine if an token with no match possibility can be removed to
+ # Determine if a token with no match possibility can be removed to
# improve chances of making an alignment.
my ( $token, $i, $imax, $jline, $i_eq ) = @_;
- # Strip off the level and other stuff appended to the token.
- # 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)
- my ( $tok, $lev, $tag ) = ( $token, 0, "" );
- if ( $tok =~ /^(\D+)(\d+)(.*)$/ ) { $tok = $1; $lev = $2; $tag = $3 }
- ##print "$token >> $tok $lev $tag\n";
+ my ( $raw_tok, $lev, $tag, $tok_count ) =
+ decode_alignment_token($token);
+
+ # okay to delete second and higher copies of a token
+ if ( $tok_count > 1 ) { return 1 }
# only remove lower level commas
- ##if ( $tok eq ',' ) { return unless $lev > $group_level; }
- if ( $tok eq ',' ) {
+ if ( $raw_tok eq ',' ) {
- #print "tok=$tok, lev=$lev, gl=$group_level, i=$i, ieq=$i_eq\n";
return if ( defined($i_eq) && $i < $i_eq );
- return if ( $lev >= $group_level );
+ return if ( $lev <= $group_level );
}
# most operators with an equals sign should be retained if at
# same level as this statement
- elsif ( $tok =~ /=/ ) {
- return unless ( $lev > $group_level || $is_deletable_equals{$tok} );
+ elsif ( $raw_tok =~ /=/ ) {
+ return
+ unless ( $lev > $group_level || $is_deletable_equals{$raw_tok} );
}
# otherwise, ok to delete the token
sub delete_unmatched_tokens {
my ($rlines) = @_;
- # We will look at each line of a collection and compare its alignment
- # tokens with its neighbors. If it has alignment tokens which do not match
- # either neighbor, then we will usually remove them. This will
- # simplify later work and improve chances of aligning.
+ # 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.
return unless @{$rlines};
my $has_terminal_match = $rlines->[-1]->get_j_terminal_match();
- # ignore hanging side comments
+ # ignore hanging side comments in these operations
my @filtered = grep { !$_->{_is_hanging_side_comment} } @{$rlines};
my $rnew_lines = \@filtered;
my @i_equals;
+ my @min_levels;
+
+ my $jmax = @{$rnew_lines} - 1;
+
+ my %is_good_tok;
- # Step 1: create a hash of tokens for each line
+ # create a hash of tokens for each line
my $rline_hashes = [];
foreach my $line ( @{$rnew_lines} ) {
my $rhash = {};
my $rtokens = $line->get_rtokens();
my $i = 0;
my $i_eq;
+ my $lev_min;
foreach my $tok ( @{$rtokens} ) {
- $rhash->{$tok} = [ $i, undef, undef ];
+ my ( $raw_tok, $lev, $tag, $tok_count ) =
+ decode_alignment_token($tok);
+ if ( !defined($lev_min) || $lev < $lev_min ) { $lev_min = $lev }
+
+ # 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) && $tok =~ /^=(\d+)/ ) {
- my $lev = $1;
+ if ( !defined($i_eq) && $raw_tok eq '=' ) {
if ( $lev eq $group_level ) { $i_eq = $i }
}
$i++;
}
push @{$rline_hashes}, $rhash;
- push @i_equals, $i_eq;
+ push @i_equals, $i_eq;
+ push @min_levels, $lev_min;
}
- # Step 2: compare each line pair and record matches
- for ( my $jl = 0 ; $jl < @{$rline_hashes} - 1 ; $jl++ ) {
+ # 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;
+ my $count = 0; # UNUSED NOW?
my $ntoks = 0;
foreach my $tok ( keys %{$rhash_l} ) {
$ntoks++;
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
+ if ( $nr == 0 && $nl > 0 ) {
+ $rnew_lines->[$jl]->{_end_group} = 1;
+ }
}
- # Step 3: remove unmatched tokens
- my $jj = 0;
- my $jmax = @{$rnew_lines} - 1;
- foreach my $line ( @{$rnew_lines} ) {
- my $rtokens = $line->get_rtokens();
- my $rhash = $rline_hashes->[$jj];
- my $i = 0;
- my $nl = 0;
- my $nr = 0;
- my $i_eq = $i_equals[$jj];
- my @idel;
- my $imax = @{$rtokens} - 2;
-
- for ( my $i = 0 ; $i <= $imax ; $i++ ) {
- my $tok = $rtokens->[$i];
- next if ( $tok eq '#' ); # shouldn't happen
- my ( $il, $ir ) = @{ $rhash->{$tok} }[ 1, 2 ];
- $nl++ if defined($il);
- $nr++ if defined($ir);
- if (
- !defined($il)
- && !defined($ir)
- && is_deletable_token( $tok, $i, $imax, $jj, $i_eq )
+ # find subgroups
+ my @subgroups;
+ push @subgroups, [ 0, $jmax ];
+ for ( my $jl = 0 ; $jl < $jmax ; $jl++ ) {
+ if ( $rnew_lines->[$jl]->{_end_group} ) {
+ $subgroups[-1]->[1] = $jl;
+ push @subgroups, [ $jl + 1, $jmax ];
+ }
+ }
- # Patch: do not touch the first line of a terminal match,
- # such as below, because j_terminal has already been set.
- # if ($tag) { $tago = "<$tag>"; $tagc = "</$tag>"; }
- # else { $tago = $tagc = ''; }
- # But see snippets 'else1.t' and 'else2.t'
- && !( $jj == 0 && $has_terminal_match && $jmax == 1 )
+ # Loop to process each subgroups
+ foreach my $item (@subgroups) {
+ my ( $jbeg, $jend ) = @{$item};
- )
- {
- push @idel, $i;
+ # look for complete ternary or if/elsif/else blocks
+ my $nlines = $jend - $jbeg + 1;
+ my %token_line_count;
+ 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}++;
+ }
+ }
+ }
+
+ # Look for if/else/elsif and ternary blocks
+ my $is_full_block;
+ foreach my $tok ( keys %token_line_count ) {
+ if ( $token_line_count{$tok} == $nlines ) {
+ if ( $tok =~ /^\?/ || $tok =~ /^\{\d+if/ ) {
+ $is_full_block = 1;
+ }
}
}
- if (@idel) { delete_selected_tokens( $line, \@idel ) }
+ # 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 = 0;
+ my $i_eq = $i_equals[$jj];
+ my @idel;
+ my $imax = @{$rtokens} - 2;
+ my $delete_above_level;
+
+ 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} };
+
+ # always remove unmatched tokens
+ my $delete_me = !defined($il) && !defined($ir);
+
+ # also, if this is a complete ternary or if/elsif/else block,
+ # remove all alignments which are not also in every line
+ $delete_me ||=
+ ( $is_full_block && $token_line_count{$tok} < $nlines );
+
+ # 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 }
+ }
+
+ if (
+ $delete_me
+ && is_deletable_token( $tok, $i, $imax, $jj, $i_eq )
+
+ # Patch: do not touch the first line of a terminal match,
+ # such as below, because j_terminal has already been set.
+ # if ($tag) { $tago = "<$tag>"; $tagc = "</$tag>"; }
+ # else { $tago = $tagc = ''; }
+ # But see snippets 'else1.t' and 'else2.t'
+ && !( $jj == $jbeg && $has_terminal_match && $nlines == 2 )
+
+ )
+ {
+ push @idel, $i;
+ if ( !defined($delete_above_level)
+ || $lev < $delete_above_level )
+ {
+
+ # delete all following higher level alignments
+ $delete_above_level = $lev;
- # set a break if this is an interior line with possible left matches
- # but no matches to the right. We do not do this for the last line
- # because it could be followed by hanging side comments filtered out
- # above.
- if ( $nr == 0 && $nl > 0 && $jj < @{$rnew_lines} - 1 ) {
- $rnew_lines->[$jj]->{_end_group} = 1;
+ # but keep deleting after => to next lower level
+ # to avoid some bizarre alignments
+ if ( $raw_tok eq '=>' ) {
+ $delete_above_level = $lev - 1;
+ }
+ }
+ }
+ }
+
+ if (@idel) { delete_selected_tokens( $line, \@idel ) }
}
- $jj++;
- }
+ } # End loop over subgroups
- #use Data::Dumper;
- #print Data::Dumper->Dump( [$rline_hashes] );
return;
}
-sub decide_if_aligned_pair {
+{ # decide_if_aligned_pair
- # Do not try to align two lines which are not really similar
- return unless ( @group_lines == 2 );
- return if ($is_matching_terminal_line);
+ my %is_if_or;
+ my %is_assignment;
- my $group_list_type = $group_lines[0]->get_list_type();
+ BEGIN {
- my $rtokens = $group_lines[0]->get_rtokens();
- my $leading_equals = ( $rtokens->[0] =~ /=/ );
-
- # A marginal match is a match which has different patterns. Normally, we
- # should not allow exactly two lines to match if marginal. But we will modify
- # this rule for two lines with a leading equals-like operator such that we
- # match if the patterns to the left of the equals are the same. So for
- # example the following two lines are a marginal match but have the same
- # left side patterns, so we will align the equals.
- # my $orig = my $format = "^<<<<< ~~\n";
- # my $abc = "abc";
- # But these have a different left pattern so they will not be aligned
- # $xmldoc .= $`;
- # $self->{'leftovers'} .= "<bx-seq:seq" . $';
- my $is_marginal = $marginal_match;
- if ( $leading_equals && $is_marginal ) {
- my $rpatterns0 = $group_lines[0]->get_rpatterns();
- my $rpatterns1 = $group_lines[1]->get_rpatterns();
- my $pat0 = $rpatterns0->[0];
- my $pat1 = $rpatterns1->[0];
- $is_marginal = $pat0 ne $pat1;
+ my @q = qw(
+ if or ||
+ );
+ @is_if_or{@q} = (1) x scalar(@q);
+
+ @q = qw(
+ = **= += *= &= <<= &&=
+ -= /= |= >>= ||= //=
+ .= %= ^=
+ x=
+ );
+ @is_assignment{@q} = (1) x scalar(@q);
}
- my $do_not_align = (
+ sub decide_if_aligned_pair {
+
+ # Do not try to align two lines which are not really similar
+ return unless ( @group_lines == 2 );
+ return if ($is_matching_terminal_line);
# always align lists
- !$group_list_type
+ my $group_list_type = $group_lines[0]->get_list_type();
+ return 0 if ($group_list_type);
+
+ my $jmax0 = $group_lines[0]->get_jmax();
+ my $jmax1 = $group_lines[1]->get_jmax();
+ my $rtokens = $group_lines[0]->get_rtokens();
+ my $leading_equals = ( $rtokens->[0] =~ /=/ );
+
+ # scan the tokens on the second line
+ my $rtokens1 = $group_lines[1]->get_rtokens();
+ my $saw_if_or; # if we saw an 'if' or 'or' at group level
+ my $raw_tokb = ""; # first token seen at group level
+ for ( my $j = 0 ; $j < $jmax1 - 1 ; $j++ ) {
+ my ( $raw_tok, $lev, $tag, $tok_count ) =
+ decode_alignment_token( $rtokens1->[$j] );
+ if ( $raw_tok && $lev == $group_level ) {
+ if ( !$raw_tokb ) { $raw_tokb = $raw_tok }
+ $saw_if_or ||= $is_if_or{$raw_tok};
+ }
+ }
- && (
+ # A marginal match is a match which has different patterns. Normally,
+ # we should not allow exactly two lines to match if marginal. But
+ # we can allow matching in some specific cases.
+ my $is_marginal = $marginal_match;
- # don't align if it was just a marginal match
- $is_marginal ##$marginal_match
+ # lines with differing number of alignment tokens are marginal
+ $is_marginal ||=
+ $previous_maximum_jmax_seen != $previous_minimum_jmax_seen
+ && !$is_assignment{$raw_tokb};
- # don't align two lines with big gap
- # NOTE: I am not sure if this test is actually functional any longer
- || $group_maximum_gap > 12
+ # We will use the line endings to help decide on alignments...
+ # See if the lines end with semicolons...
+ my $rpatterns0 = $group_lines[0]->get_rpatterns();
+ my $rpatterns1 = $group_lines[1]->get_rpatterns();
+ my $sc_term0;
+ my $sc_term1;
+ if ( $jmax0 < 1 || $jmax1 < 1 ) {
- # or lines with differing number of alignment tokens
- || ( $previous_maximum_jmax_seen != $previous_minimum_jmax_seen
- && !$leading_equals )
- )
- );
+ # shouldn't happen
+ }
+ else {
+ my $pat0 = $rpatterns0->[ $jmax0 - 1 ];
+ my $pat1 = $rpatterns1->[ $jmax1 - 1 ];
+ $sc_term0 = $pat0 =~ /;b?$/;
+ $sc_term1 = $pat1 =~ /;b?$/;
+ }
- # But try to convert them into a simple comment group if the first line
- # a has side comment
- my $rfields = $group_lines[0]->get_rfields();
- my $maximum_field_index = $group_lines[0]->get_jmax();
- if ( $do_not_align
- && ( length( $rfields->[$maximum_field_index] ) > 0 ) )
- {
- combine_fields();
- $do_not_align = 0;
+ 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 '{' )
+ && $jmax1 == 2
+ && $sc_term0 ne $sc_term1;
+
+ # Undo the marginal match flag in certain cases,
+ if ($is_marginal) {
+
+ # Two lines with a leading equals-like operator are allowed to
+ # align if the patterns to the left of the equals are the same.
+ # For example the following two lines are a marginal match but have
+ # the same left side patterns, so we will align the equals.
+ # my $orig = my $format = "^<<<<< ~~\n";
+ # my $abc = "abc";
+ # But these have a different left pattern so they will not be
+ # aligned
+ # $xmldoc .= $`;
+ # $self->{'leftovers'} .= "<bx-seq:seq" . $';
+
+ # First line semicolon terminated but second not, usually ok:
+ # my $want = "'ab', 'a', 'b'";
+ # my $got = join( ", ",
+ # map { defined($_) ? "'$_'" : "undef" }
+ # @got );
+ # First line not semicolon terminated, Not OK to match:
+ # $$href{-NUM_TEXT_FILES} = $$href{-NUM_BINARY_FILES} =
+ # $$href{-NUM_DIRS} = 0;
+ my $pat0 = $rpatterns0->[0];
+ my $pat1 = $rpatterns1->[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;
+ }
+ 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;
+ }
+ }
+ }
+
+ ###############################
+ # Set the return flag:
+ # Don't align if still marginal
+ ###############################
+ my $do_not_align = $is_marginal;
+
+ # But try to convert them into a simple comment group if the first line
+ # a has side comment
+ my $rfields = $group_lines[0]->get_rfields();
+ my $maximum_field_index = $group_lines[0]->get_jmax();
+ if ( $do_not_align
+ && ( length( $rfields->[$maximum_field_index] ) > 0 ) )
+ {
+ combine_fields();
+ $do_not_align = 0;
+ }
+ return $do_not_align;
}
- return $do_not_align;
}
sub adjust_side_comment {
my @seqno_last =
( split /:/, $last_nonblank_seqno_string );
my @seqno_now = ( split /:/, $seqno_string );
- if ( $seqno_now[-1] == $seqno_last[0]
+ if ( @seqno_now
+ && @seqno_last
+ && $seqno_now[-1] == $seqno_last[0]
&& $seqno_now[0] == $seqno_last[-1] )
{
package Perl::Tidy::VerticalAligner::Alignment;
use strict;
use warnings;
-our $VERSION = '20190601';
+our $VERSION = '20200110';
{
package Perl::Tidy::VerticalAligner::Line;
use strict;
use warnings;
-our $VERSION = '20190601';
+our $VERSION = '20200110';
{
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 };
+\%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" ~~ +{ foo => 1, bar => 2 };
+{ foo => 1, bar => 2 } ~~ "baz";
-"baz" ~~ +{ foo => 1, bar => 2 };
-[] ~~ [];
-[] ~~ [];
-[] ~~ [1];
-[1] ~~ [];
+"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/ ];
# 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' => <<'----------',
'align26' => <<'----------',
# align first of multiple equals
-$SIG{PIPE}=sub{die"writingtoaclosedpipe"};#1=
-$SIG{HUP}=$SIG{BREAK}=$SIG{INT}=$SIG{TERM};#3=
+$SIG{PIPE}=sub{die"writingtoaclosedpipe"};
+$SIG{BREAK}=$SIG{INT}=$SIG{TERM};
+$SIG{HUP}=\&some_handler;
----------
'align27' => <<'----------',
# 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...........
},
params => "def",
expect => <<'#18...........',
# align first of multiple equals
-$SIG{PIPE} = sub { die "writingtoaclosedpipe" }; #1=
-$SIG{HUP} = $SIG{BREAK} = $SIG{INT} = $SIG{TERM}; #3=
+$SIG{PIPE} = sub { die "writingtoaclosedpipe" };
+$SIG{BREAK} = $SIG{INT} = $SIG{TERM};
+$SIG{HUP} = \&some_handler;
#18...........
},
regex => [ $ws, $pod_or_DATA, $id, $exql ],
string => [ $ws, $pod_or_DATA, $id, $exql ],
code => [
- $ws, { DONT_MATCH => $pod_or_DATA },
+ $ws, { DONT_MATCH => $pod_or_DATA },
$variable, $id, { DONT_MATCH => \&extract_quotelike }
],
code_no_comments => [
{ DONT_MATCH => $comment },
- $ncws, { DONT_MATCH => $pod_or_DATA },
+ $ncws, { DONT_MATCH => $pod_or_DATA },
$variable, $id, { DONT_MATCH => \&extract_quotelike }
],
executable => [ $ws, { DONT_MATCH => $pod_or_DATA } ],
regex => [ $ws, $pod_or_DATA, $id, $exql ],
string => [ $ws, $pod_or_DATA, $id, $exql ],
code => [
- $ws, { DONT_MATCH => $pod_or_DATA },
+ $ws, { DONT_MATCH => $pod_or_DATA },
$variable, $id, { DONT_MATCH => \&extract_quotelike }
],
code_no_comments => [
{ DONT_MATCH => $comment },
- $ncws, { DONT_MATCH => $pod_or_DATA },
+ $ncws, { DONT_MATCH => $pod_or_DATA },
$variable, $id, { DONT_MATCH => \&extract_quotelike }
],
executable => [ $ws, { DONT_MATCH => $pod_or_DATA } ],
params => "def",
expect => <<'#10...........',
#!/usr/bin/perl -w
-use strict; # with -kgb, no break after hash bang
+use strict; # with -kgb, no break after hash bang
our ( @Changed, $TAP ); # break after isolated 'our'
use File::Compare;
use Symbol;
params => "kgb",
expect => <<'#11...........',
#!/usr/bin/perl -w
-use strict; # with -kgb, no break after hash bang
+use strict; # with -kgb, no break after hash bang
our ( @Changed, $TAP ); # break after isolated 'our'
use File::Compare;
#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'
'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",
};
############################
############################
$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(
->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, [
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 () { }
----------
'wngnu1' => <<'----------',
);
#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 () { }
+#18...........
+ },
+
+ 'spp.spp0' => {
+ source => "spp",
+ params => "spp0",
+ expect => <<'#19...........',
+sub get_val() { }
+
+sub get_Val() { }
+
+sub Get_val() { }
+#19...........
+ },
};
my $ntests = 0 + keys %{$rtests};
--- /dev/null
+# 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
+
+# To locate test #13 you can search for its name or the string '#13'
+
+use strict;
+use Test;
+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 );
+----------
+
+ 'multiple_equals' => <<'----------',
+# 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 () { }
+----------
+ };
+
+ ####################################
+ # BEGIN SECTION 3: Expected output #
+ ####################################
+ $rtests = {
+
+ 'spp.spp1' => {
+ source => "spp",
+ params => "spp1",
+ expect => <<'#1...........',
+sub get_val() { }
+
+sub get_Val () { }
+
+sub Get_val () { }
+#1...........
+ },
+
+ 'spp.spp2' => {
+ source => "spp",
+ params => "spp2",
+ expect => <<'#2...........',
+sub get_val () { }
+
+sub get_Val () { }
+
+sub Get_val () { }
+#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...........
+ },
+ };
+
+ 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 ) {
+ if ($err) {
+ print STDERR
+"This error received calling Perl::Tidy with '$sname' + '$pname'\n";
+ ok( !$err );
+ }
+ if ($stderr_string) {
+ print STDERR "---------------------\n";
+ print STDERR "<<STDERR>>\n$stderr_string\n";
+ print STDERR "---------------------\n";
+ print STDERR
+"This error received calling Perl::Tidy with '$sname' + '$pname'\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' + '$pname'\n";
+ ok( !$errorfile_string );
+ }
+ }
+ else {
+ ok( $output, $expect );
+ }
+}
given ( [ 9, "a", 11 ] ) {
when (qr/\d/) {
given ($count) {
- when (1) { ok( $count == 1 ) }
- else { ok( $count != 1 ) }
+ when (1) { ok( $count == 1 ) }
+ else { ok( $count != 1 ) }
when ( [ 5, 6 ] ) { ok(0) }
- else { ok(1) }
+ else { ok(1) }
}
}
ok(1) when 11;
source => "rt125012",
params => "rt125012",
expect => <<'#7...........',
-++$_ for values%_;
-system qq{};
+++$_ for
+ values%_;
+system
+ qq{};
#7...........
},
projects / perltidy.git / commitdiff