# Perltidy Change Log
+## 2022 06 13
+
+ - No significant bugs have been found since the last release but users
+ of programs which call the Perl::Tidy module should note the first
+ item below, which changes a default setting. The main change to
+ existing formatting is the second item below, which adds vertical
+ alignment to 'use' statements.
+
+ - The flag --encode-output-strings, or -eos, is now set 'on' by default.
+ This has no effect on the use of the 'perltidy' binary script, but could
+ change the behavior of some programs which use the Perl::Tidy module on
+ files encoded in UTF-8. If any problems are noticed, an emergency fix
+ can be made by reverting to the old default by setting -neos. For
+ an explanation of why this change needs to be made see:
+
+ https://github.com/perltidy/perltidy/issues/92
+
+ https://github.com/perltidy/perltidy/blob/master/docs/eos_flag.md
+
+ - Added vertical alignment for qw quotes and empty parens in 'use'
+ statements (see issue #git 93). This new alignment is 'on' by default
+ and will change formatting as shown below. If this is not wanted it can
+ be turned off with the parameter -vxl='q' (--valign-exclude-list='q').
+
+ # old default, or -vxl='q'
+ use Getopt::Long qw(GetOptions);
+ use Fcntl qw(O_RDONLY O_WRONLY O_EXCL O_CREAT);
+ use Symbol qw(gensym);
+ use Exporter ();
+
+ # new default
+ use Getopt::Long qw(GetOptions);
+ use Fcntl qw(O_RDONLY O_WRONLY O_EXCL O_CREAT);
+ use Symbol qw(gensym);
+ use Exporter ();
+
+ - The parameter -kbb (--keep-break-before) now ignores a request to break
+ before an opening token, such as '('. Likewise, -kba (--keep-break-after)
+ now ignores a request to break after a closing token, such as ')'. This
+ change was made to avoid a rare instability discovered in random testing.
+
+ - Previously, if a -dsc command was used to delete all side comments,
+ then any special side comments for controlling non-indenting braces got
+ deleted too. Now, these control side comments are retained when -dsc is
+ set unless a -nnib (--nonon-indenting-braces) flag is also set to
+ deactivate them.
+
+ - This version runs about 10 percent faster on large files than the previous
+ release due to optimizations made with the help of Devel::NYTProf. Much
+ of the gain came from faster processing of blank tokens and comments.
+
+ - This version of perltidy was stress-tested for many cpu hours with
+ random input parameters. No failures to converge, internal fault checks,
+ undefined variable references or other irregularities were seen.
+
## 2022 02 17
- A new flag, --encode-output-strings, or -eos, has been added to resolve
COPYING
docs/BugLog.html
docs/ChangeLog.html
+docs/eos_flag.md
docs/index.html
docs/index.md
docs/INSTALL.html
t/testsa.t
t/testss.t
t/testwide-passthrough.pl.src
-t/testwide-passthrough.t.SKIP
+t/testwide-passthrough.t
t/testwide-tidy.pl.src
t/testwide-tidy.pl.srctdy
-t/testwide-tidy.t.SKIP
+t/testwide-tidy.t
t/testwide.pl.src
t/testwide.t
META.yml Module YAML meta-data (added by MakeMaker)
"requires" : {
"ExtUtils::MakeMaker" : "0"
}
+ },
+ "runtime" : {
+ "requires" : {
+ "perl" : "5.008"
+ }
}
},
"release_status" : "stable",
"web" : "https://github.com/perltidy/perltidy"
}
},
- "version" : "20220217",
+ "version" : "20220613",
"x_serialization_backend" : "JSON::PP version 4.04"
}
directory:
- t
- inc
+requires:
+ perl: '5.008'
resources:
repository: https://github.com/perltidy/perltidy.git
-version: '20220217'
+version: '20220613'
x_serialization_backend: 'CPAN::Meta::YAML version 0.012'
use ExtUtils::MakeMaker;
+
+my $mm_ver = $ExtUtils::MakeMaker::VERSION;
+if ( $mm_ver =~ /_/ ) { # developer release/version
+ $mm_ver = eval $mm_ver;
+ die $@ if $@;
+}
+
+# Minimum version found by perlver:
+#
+# ------------------------------------------
+# | file | explicit | syntax | external |
+# | ------------------------------------------ |
+# | perltidy.pl | v5.8.0 | v5.8.0 | n/a |
+# | ------------------------------------------ |
+# | Minimum explicit version : v5.8.0 |
+# | Minimum syntax version : v5.8.0 |
+# | Minimum version of perl : v5.8.0 |
+# ------------------------------------------
+
WriteMakefile(
NAME => "Perl::Tidy",
VERSION_FROM => "lib/Perl/Tidy.pm",
)
: ()
),
+ (
+ $mm_ver >= 6.48 ? ( MIN_PERL_VERSION => 5.008 )
+ : ()
+ ),
EXE_FILES => ['bin/perltidy'],
dist => { COMPRESS => 'gzip', SUFFIX => 'gz' },
=head1 DESCRIPTION
Perltidy reads a perl script and writes an indented, reformatted script.
+This document describes the parameters available for controlling this formatting.
+
+Perltidy is a commandline frontend to the module Perl::Tidy. For documentation
+describing how to call the Perl::Tidy module from other applications see the
+separate documentation for Perl::Tidy. It is the file Perl::Tidy.pod in the source distribution.
Many users will find enough information in L<"EXAMPLES"> to get
started. New users may benefit from the short tutorial
existence of an B<-html> flag. Without this flag, the output is passed
through a formatter. The default formatting tries to follow the
recommendations in perlstyle(1), but it can be controlled in detail with
-numerous input parameters, which are described in L<"FORMATTING
-OPTIONS">.
+numerous input parameters, which are described in L<"FORMATTING OPTIONS">.
When the B<-html> flag is given, the output is passed through an HTML
formatter which is described in L<"HTML OPTIONS">.
Change the extension of the output file to be F<ext> instead of the
default F<tdy> (or F<html> in case the -B<-html> option is used).
-See L<Specifying File Extensions>.
+See L<"Specifying File Extensions">.
=item B<-opath>=path, B<--output-path>=path
that no backup file should be saved.
To change the default extension to something other than F<.bak> see
-L<Specifying File Extensions>.
+L<"Specifying File Extensions">.
A backup file of the source is always written, but you can request that it
be deleted at the end of processing if there were no errors. This is risky
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.
+will cause the perltidy to treat the words 'method', 'fun', '_sub' and 'M4' the same as if they were 'sub'. Note that if the alias words are separated by spaces then the string of words should be placed in quotes.
-Note that several other parameters accept a list of keywords, including 'sub' (see L<Specifying Block Types>).
+Note that several other parameters accept a list of keywords, including 'sub' (see L<"Specifying Block Types">).
You do not need to include any sub aliases in these lists. Just include keyword 'sub' if you wish, and all aliases are automatically included.
=item B<-gal=s>, B<--grep-alias-list=s>
-This flag allows a code block following an external 'list operator' function to be formatted as if it followed one of the builtin keywords B<grep>, B<map> or B<sort>. The string B<s> contains the names of one or more such list operators, separated by spaces or commas.
+This flag allows a code block following an external 'list operator' function to be formatted as if it followed one of the built-in keywords B<grep>, B<map> or B<sort>. The string B<s> contains the names of one or more such list operators, separated by spaces or commas.
By 'list operator' is meant a function which is invoked in the form
to the output except for possible changes in line ending characters and any
pre- and post-filters. This can be useful in conjunction with a hierarchical
set of F<.perltidyrc> files to avoid unwanted code tidying. See also
-L<Skipping Selected Sections of Code> for a way to avoid tidying specific
+L<"Skipping Selected Sections of Code"> for a way to avoid tidying specific
sections of code.
=item B<-i=n>, B<--indent-columns=n>
=item B<-et=n>, B<--entab-leading-whitespace>
-This flag causes each B<n> initial space characters to be replaced by
-one tab character.
+This flag causes each B<n> leading space characters produced by the
+formatting process to be replaced by one tab character. The
+formatting process itself works with space characters. The B<-et=n> parameter is applied
+as a last step, after formatting is complete, to convert leading spaces into tabs.
+Before starting to use tabs, it is essential to first get the indentation
+controls set as desired without tabs, particularly the two parameters B<--indent-columns=n> (or B<-i=n>) and B<--continuation-indentation=n> (or B<-ci=n>).
The value of the integer B<n> can be any value but can be coordinated with the
-number of spaces used for intentation. For example, B<-et=4 -ci=4 -i=4> will
+number of spaces used for indentation. For example, B<-et=4 -ci=4 -i=4> will
produce one tab for each indentation level and and one for each continuation
indentation level. You may want to coordinate the value of B<n> with what your
display software assumes for the spacing of a tab.
option, and if these options are also given, then a warning message will
be issued and this flag will be unset. One example is the B<-lp>
option. This flag is retained for backwards compatibility, but
-if you use tabs, the B<-et=n> flag is recommended.
+if you use tabs, the B<-et=n> flag is recommended. If both B<-t> and
+B<-et=n> are set, the B<-et=n> is used.
=item B<-dt=n>, B<--default-tabsize=n>
Probably the only reason to deactivate this flag is to generate more diagnostic
messages when debugging a script.
-For another method of handling extended syntax see the section L<Skipping Selected Sections of Code>.
+For another method of handling extended syntax see the section L<"Skipping Selected Sections of Code">.
=item B<-io>, B<--indent-only>
=item B<-enc=s>, B<--character-encoding=s>
This flag indicates if the input data stream use a character encoding.
-Perltidy does not look for the encoding directives in the soure stream, such
+Perltidy does not look for the encoding directives in the source stream, such
as B<use utf8>, and instead relies on this flag to determine the encoding.
(Note that perltidy often works on snippets of code rather than complete files
so it cannot rely on B<use utf8> directives).
=item B<-eos=s>, B<--encode-output-strings=s>
-This flag has been added to resolve an issue involving the interface between
+This flag was added to resolve an issue involving the interface between
Perl::Tidy and calling programs, and in particular B<Code::TidyAll (tidyall)>.
-By default Perl::Tidy returns unencoded strings to the calling
-program, but some programs expect encoded strings. Setting this flag causes
-Perl::Tidy to return encoded output strings which it decoded. For some
-background information see
-L<https://github.com/perltidy/perltidy/issues/83> and
-L<https://github.com/houseabsolute/perl-code-tidyall/issues/84>.
-If you only run the B<perltidy> binary this flag has no effect.
+If you only run the B<perltidy> binary this flag has no effect. If you run a
+program which calls the Perl::Tidy module and receives a string in return, then
+the meaning of the flag is as follows:
+
+=over 4
+
+=item *
+
+The setting B<-eos> means Perl::Tidy should encode any string which it decodes.
+This is the default because it makes perltidy behave well as a filter,
+and is the correct setting for most programs.
-If you use B<tidyall> with encoded files and encounter irregularities such as
-B<wide character> messages you should set this flag.
+=item *
-Additional information can be found in the man pages for the B<Perl::Tidy> module.
+The setting B<-neos> means that a string should remain decoded if it was
+decoded by Perl::Tidy. This is only appropriate if the calling program will
+handle any needed encoding before outputting the string.
+
+=back
+
+The default was changed from B<-neos> to B<-eos> in versions after 20220217.
+If this change causes a program to start running incorrectly on encoded files,
+an emergency fix might be to set B<-neos>. Additional information can be found
+in the man pages for the B<Perl::Tidy> module and also in
+L<https://github.com/perltidy/perltidy/blob/master/docs/eos_flag.md>.
=item B<-gcs>, B<--use-unicode-gcstring>
indentation scheme used to create the code snippet is the same as is being used
for the current perltidy process. This is the only sensible guess that can be
made. It should be correct if this is true, but otherwise it probably won't.
-For example, if the input script was written with -i=2 and the current peltidy
+For example, if the input script was written with -i=2 and the current perltidy
flags have -i=4, the wrong initial indentation will be guessed for a code
snippet which has non-zero initial indentation. Likewise, if an entabbing
scheme is used in the input script and not in the current process then the
These flags have no effect on code BLOCKS, such as if/then/else blocks,
which always use whatever is specified with B<-i=n>.
-Some limitiations on these flags are:
+Some limitations on these flags are:
=over 4
recommended. The B<-lpxl=s> flag was the original implementation and is
only retained for backwards compatibility.
-This list B<s> for these parametes is a string with space-separated items.
+This list B<s> for these parameters is a string with space-separated items.
Each item consists of up to three pieces of information in this order: (1) an
optional letter code (2) a required container type, and (3) an optional numeric
code.
-lpil='('
-means use -lp formatting only on lists within parentheses, not lists in square-bracets or braces.
+means use -lp formatting only on lists within parentheses, not lists in square-brackets or braces.
The same thing could alternatively be specified with
-lpxl = '[ {'
token immediately before the paren. The possible letters are currently 'k',
'K', 'f', 'F', 'w', and 'W', with these meanings for matching whatever precedes an opening paren:
- 'k' matches if the previous nonblank token is a perl builtin keyword (such as 'if', 'while'),
+ 'k' matches if the previous nonblank token is a perl built-in keyword (such as 'if', 'while'),
'K' matches if 'k' does not, meaning that the previous token is not a keyword.
'f' matches if the previous token is a function other than a keyword.
'F' matches if 'f' does not.
fixit($i);
}
-Use B<-nola> to not outdent labels. To control line breaks after labels see L<bal=n, --break-after-labels=n>.
+Use B<-nola> to not outdent labels. To control line breaks after labels see L<"bal=n, --break-after-labels=n">.
=item B<Outdenting Keywords>
for my $severity ( reverse $SEVERITY_LOWEST +1 .. $SEVERITY_HIGHEST ) { ... }
To avoid subtle parsing problems like this, it is best to avoid spacing a
-binary operator asymetrically with a space on the left but not on the right.
+binary operator asymmetrically with a space on the left but not on the right.
=item B<Space between specific keywords and opening paren>
comments. By default, all code block types preceded by a keyword or
label (such as C<if>, C<sub>, and so on) will be tagged. The B<-cscl>
command changes the default list to be any selected block types; see
-L<Specifying Block Types>.
+L<"Specifying Block Types">.
For example, the following command
requests that only C<sub>'s, labels, C<BEGIN>, and C<END> blocks be
affected by any B<-csc> or B<-dcsc> operation:
Note that it may be possible to avoid the use of B<--format-skipping> for the
specific case of a comma-separated list of values, as in the above example, by
simply inserting a blank or comment somewhere between the opening and closing
-parens. See the section L<Controlling List Formatting>.
+parens. See the section L<"Controlling List Formatting">.
The following sections describe the available controls for these options. They
should not normally be needed.
The parameters in this section control breaks after
non-blank lines of code. Blank lines are controlled
-separately by parameters in the section L<Blank Line
-Control>.
+separately by parameters in the section L<"Blank Line Control">.
=over 4
lines of code in your script, set
B<-fnl>, and they will remain fixed, and the rest of the commands in
this section and sections
-L<Controlling List Formatting>,
-L<Retaining or Ignoring Existing Line Breaks>.
+L<"Controlling List Formatting">,
+L<"Retaining or Ignoring Existing Line Breaks">.
You may want to use B<-noll> with this.
Note: If you also want to keep your blank lines exactly
as they are, you can use the B<-fbl> flag which is described
-in the section L<Blank Line Control>.
+in the section L<"Blank Line Control">.
=item B<-ce>, B<--cuddled-else>
=item B<-bll=s>, B<--brace-left-list=s>
Use this parameter to change the types of block braces for which the
-B<-bl> flag applies; see L<Specifying Block Types>. For example,
+B<-bl> flag applies; see L<"Specifying Block Types">. For example,
B<-bll='if elsif else sub'> would apply it to only C<if/elsif/else>
and named sub blocks. The default is all blocks, B<-bll='*'>.
=item B<-blxl=s>, B<--brace-left-exclusion-list=s>
Use this parameter to exclude types of block braces for which the
-B<-bl> flag applies; see L<Specifying Block Types>. For example,
+B<-bl> flag applies; see L<"Specifying Block Types">. For example,
the default settings B<-bll='*'> and B<-blxl='sort map grep eval asub'>
mean all blocks except B<sort map grep eval> and anonymous sub blocks.
=item B<-blil=s>, B<--brace-left-and-indent-list=s>
Use this parameter to change the types of block braces for which the
-B<-bli> flag applies; see L<Specifying Block Types>.
+B<-bli> flag applies; see L<"Specifying Block Types">.
The default is B<-blil='if else elsif unless while for foreach do : sub'>.
=item B<-blixl=s>, B<--brace-left-and-indent-exclusion-list=s>
Use this parameter to exclude types of block braces for which the B<-bli> flag
-applies; see L<Specifying Block Types>.
+applies; see L<"Specifying Block Types">.
This might be useful in conjunction with selecting all blocks B<-blil='*'>.
The default setting is B<-blixl=' '>, which does not exclude any blocks.
container symbol. The possible letters are currently 'k', 'K', 'f', 'F',
'w', and 'W', with these meanings:
- 'k' matches if the previous nonblank token is a perl builtin keyword (such as 'if', 'while'),
+ 'k' matches if the previous nonblank token is a perl built-in keyword (such as 'if', 'while'),
'K' matches if 'k' does not, meaning that the previous token is not a keyword.
'f' matches if the previous token is a function other than a keyword.
'F' matches if 'f' does not.
the parameter B<-bbvtl=string>, or
B<--block-brace-vertical-tightness-list=string>, where B<string> is a
space-separated list of block types. For more information on the
-possible values of this string, see L<Specifying Block Types>
+possible values of this string, see L<"Specifying Block Types">
For example, if we want to just apply this style to C<if>,
C<elsif>, and C<else> blocks, we could use
=item B<bal=n, --break-after-labels=n>
This flag controls whether or not a line break occurs after a label. There
-are three possible valuse for B<n>:
+are three possible values for B<n>:
- -bal=0 break if there is a break in the input [DEFAULt]
+ -bal=0 break if there is a break in the input [DEFAULT]
-bal=1 always break after a label
-bal=2 never break after a label
of the list items will still occur if possible.
For another possibility see
-the -fs flag in L<Skipping Selected Sections of Code>.
+the -fs flag in L<"Skipping Selected Sections of Code">.
=over 4
B<--weld-nested-exclusion-list> and B<--line-up-parentheses-exclusion-list>
parameters):
- 'k' matches if the previous nonblank token is a perl builtin keyword (such as 'if', 'while'),
+ 'k' matches if the previous nonblank token is a perl built-in keyword (such as 'if', 'while'),
'K' matches if 'k' does not, meaning that the previous token is not a keyword.
'f' matches if the previous token is a function other than a keyword.
'F' matches if 'f' does not.
perltidy -kba='f('
-B<NOTE>: To match all opening curly braces, and no other opening tokens, please
-prefix the brace it with an asterisk, like this: '*{'. Otherwise a warning
-message will occur. This is necessary to avoid problems while the input scheme
-is being updated and generalized. A single bare curly brace previously matched
-all container tokens, and tentatively still does. Likewise, to match all
-closing curly braces, and no other closing tokens, use '*}'.
+B<NOTE>: A request to break before an opening container, such as B<-kbb='('>,
+will be silently ignored because it can lead to formatting instability.
+Likewise, a request to break after a closing container, such as B<-kba>=')',
+will also be silently ignored.
=item B<-iob>, B<--ignore-old-breakpoints>
B<-kgbd> or B<--keyword-group-blanks-delete> controls the deletion of any
blank lines that exist in the the group when it is first scanned. When
statements are initially scanned, any existing blank lines are included in the
-collection. Any such orignial blank lines will be deleted before any other
+collection. Any such original blank lines will be deleted before any other
insertions are made when the parameter B<-kgbd> is set. The default is not to
do this, B<-nkgbd>.
=item B<Completely turning off vertical alignment with -novalign>
-The default is to use vertical alignment, but bertical alignment can be
+The default is to use vertical alignment, but vertical alignment can be
completely turned of with the B<-novalign> flag.
A lower level of control of vertical alignment is possible with three parameters
=item B<Controlling side comment alignment with --valign-side-comments or -vsc>
The B<-vsc> flag enables alignment of side comments and is enabled by default. If side
-comment aligment is disabled with B<-nvsc> they will appear at a fixed space from the
+comment alignment is disabled with B<-nvsc> they will appear at a fixed space from the
preceding code token. The default is B<-vsc>
=item B<Controlling block comment alignment with --valign-block-comments or -vbc>
of the tokens ',', '=', and '=>', but many other alignments are possible and are given in the following list:
= **= += *= &= <<= &&= -= /= |= >>= ||= //= .= %= ^= x=
- { ( ? : , ; => && || ~~ !~~ =~ !~ // <=> ->
+ { ( ? : , ; => && || ~~ !~~ =~ !~ // <=> -> q
if unless and or err for foreach while until
-These alignments are all enabled by default, but they can be selectively disabled by including one or more of these tokens in the space-separated list B<valign-exclusion-list=s>.
+These alignment types correspond to perl symbols, operators and keywords except
+for 'q', which refers to the special case of alignment in a 'use' statement of
+qw quotes and empty parens.
+
+They are all enabled by default, but they can be selectively disabled by including one or more of these tokens in the space-separated list B<valign-exclusion-list=s>.
For example, the following would prevent alignment at B<=> and B<if>:
--valign-exclusion-list='= if'
If it is simpler to specify only the token types which are to be aligned, then
include the types which are to be aligned in the list of B<--valign-inclusion-list>.
-You may leave the B<valign-exclusion-list> undefined, or use the special symbol B<*> for the exclusion list.
+In that case you may leave the B<valign-exclusion-list> undefined, or use the special symbol B<*> for the exclusion list.
For example, the following parameters enable alignment only at commas and 'fat commas':
--valign-inclusion-list=', =>'
B<--delete-block-comments> and B<-dsc> or B<--delete-side-comments>.
(Hanging side comments will be deleted with side comments here.)
+When side comments are deleted, any special control side comments for
+non-indenting braces will be retained unless they are deactivated with
+a B<-nnib> flag.
+
The negatives of these commands also work, and are the defaults. When
block comments are deleted, any leading 'hash-bang' will be retained.
Also, if the B<-x> flag is used, any system commands before a leading
have a leading dot. Further system-dependent information will be found
in the INSTALL file distributed with perltidy.
-Under Windows, perltidy will also search for a configuration file named perltidy.ini since Windows does not allow files with a leading period (.).
+Under Windows, perltidy will also search for a configuration file named F<perltidy.ini> since Windows does not allow files with a leading period (.).
Use C<perltidy -dpro> to see the possible locations for your system.
An example might be F<C:\Documents and Settings\All Users\perltidy.ini>.
Use this flag to specify the extra file extension of the table of contents file
when html frames are used. The default is "toc".
-See L<Specifying File Extensions>.
+See L<"Specifying File Extensions">.
=item The B<-sext=s>, or B<--html-src-extension> flag
Use this flag to specify the extra file extension of the content file when html
frames are used. The default is "src".
-See L<Specifying File Extensions>.
+See L<"Specifying File Extensions">.
=item The B<-hent>, or B<--html-entities> flag
=head1 VERSION
-This man page documents perltidy version 20220217
+This man page documents perltidy version 20220613
=head1 BUG REPORTS
-A list of current bugs and issues can be found at the CPAN site L<https://rt.cpan.org/Public/Dist/Display.html?Name=Perl-Tidy>
-
-To report a new bug or problem, use the link on this page.
-
The source code repository is at L<https://github.com/perltidy/perltidy>.
+To report a new bug or problem, use the "issues" link on this page.
+
=head1 COPYRIGHT
Copyright (c) 2000-2022 by Steve Hancock
<h1>Perltidy Change Log</h1>
+<h2>2022 06 13</h2>
+
+<pre><code>- No significant bugs have been found since the last release but users
+ of programs which call the Perl::Tidy module should note the first
+ item below, which changes a default setting. The main change to
+ existing formatting is the second item below, which adds vertical
+ alignment to 'use' statements.
+
+- The flag --encode-output-strings, or -eos, is now set 'on' by default.
+ This has no effect on the use of the 'perltidy' binary script, but could
+ change the behavior of some programs which use the Perl::Tidy module on
+ files encoded in UTF-8. If any problems are noticed, an emergency fix
+ can be made by reverting to the old default by setting -neos. For
+ an explanation of why this change needs to be made see:
+
+ https://github.com/perltidy/perltidy/issues/92
+
+ https://github.com/perltidy/perltidy/blob/master/docs/eos_flag.md
+
+- Added vertical alignment for qw quotes and empty parens in 'use'
+ statements (see issue #git 93). This new alignment is 'on' by default
+ and will change formatting as shown below. If this is not wanted it can
+ be turned off with the parameter -vxl='q' (--valign-exclude-list='q').
+
+ # old default, or -vxl='q'
+ use Getopt::Long qw(GetOptions);
+ use Fcntl qw(O_RDONLY O_WRONLY O_EXCL O_CREAT);
+ use Symbol qw(gensym);
+ use Exporter ();
+
+ # new default
+ use Getopt::Long qw(GetOptions);
+ use Fcntl qw(O_RDONLY O_WRONLY O_EXCL O_CREAT);
+ use Symbol qw(gensym);
+ use Exporter ();
+
+- The parameter -kbb (--keep-break-before) now ignores a request to break
+ before an opening token, such as '('. Likewise, -kba (--keep-break-after)
+ now ignores a request to break after a closing token, such as ')'. This
+ change was made to avoid a rare instability discovered in random testing.
+
+- Previously, if a -dsc command was used to delete all side comments,
+ then any special side comments for controlling non-indenting braces got
+ deleted too. Now, these control side comments are retained when -dsc is
+ set unless a -nnib (--nonon-indenting-braces) flag is also set to
+ deactivate them.
+
+- This version runs about 10 percent faster on large files than the previous
+ release due to optimizations made with the help of Devel::NYTProf. Much
+ of the gain came from faster processing of blank tokens and comments.
+
+- This version of perltidy was stress-tested for many cpu hours with
+ random input parameters. No failures to converge, internal fault checks,
+ undefined variable references or other irregularities were seen.
+</code></pre>
+
<h2>2022 02 17</h2>
<pre><code>- A new flag, --encode-output-strings, or -eos, has been added to resolve
<pre><code> use Perl::Tidy;
Perl::Tidy::perltidy();</code></pre>
-<p>The call to <b>perltidy</b> returns a scalar <b>$error_flag</b> which is TRUE if an error caused premature termination, and FALSE if the process ran to normal completion. Additional discuss of errors is contained below in the <a href="#ERROR-HANDLING">"ERROR HANDLING"</a> section.</p>
+<p>The call to <b>perltidy</b> returns a scalar <b>$error_flag</b> which is TRUE if an error caused premature termination, and FALSE if the process ran to normal completion. Additional discuss of errors is contained below in the <a href="#ERROR-HANDLING">ERROR HANDLING</a> section.</p>
<p>The module accepts input and output streams by a variety of methods. The following list of parameters may be any of the following: a filename, an ARRAY reference, a SCALAR reference, or an object with either a <b>getline</b> or <b>print</b> method, as appropriate.</p>
<p>If the <b>destination</b> parameter is given, it will be used to define the file or memory location to receive output of perltidy.</p>
-<p><b>Important note if destination is a string or array reference</b>. Perl strings of characters which are decoded as utf8 by Perl::Tidy can be returned in either of two possible states, decoded or encoded, and it is important that the calling program and Perl::Tidy are in agreement regarding the state to be returned. A flag <b>--encode-output-strings</b>, or simply <b>-eos</b>, was added in versions of Perl::Tidy after 20220101 for this purpose. This flag should be added to the end of the <b>argv</b> paremeter (described below) if Perl::Tidy will be decoding utf8 text. The options are as follows.</p>
+<p><b>Important note if destination is a string or array reference</b>. Perl strings of characters which are decoded as utf8 by Perl::Tidy can be returned in either of two possible states, decoded or encoded, and it is important that the calling program and Perl::Tidy are in agreement regarding the state to be returned. A flag <b>--encode-output-strings</b>, or simply <b>-eos</b>, was added in Perl::Tidy version 20220217 for this purpose.</p>
<ul>
-<li><p>Use <b>-eos</b> if Perl::Tidy should encode any string which it decodes. This is probably most convenient for most programs. But do not use this setting if the calling program will encode the data too, because double encoding will corrupt data.</p>
+<li><p>Use <b>-eos</b> if Perl::Tidy should encode any string which it decodes. This is the current default because it makes perltidy behave well as a filter, and is the correct setting for most programs. But do not use this setting if the calling program will encode the data too, because double encoding will corrupt data.</p>
</li>
-<li><p>Use <b>-neos</b> if a string should remain decoded if it was decoded by Perl::Tidy. This is appropriate if the calling program will handle any needed encoding before outputting the string.</p>
-
-</li>
-<li><p>The current default is <b>-neos</b>, but <b>the default could change in a future version</b>, so <b>-neos</b> should still be set, if appropriate, to allow for the possibility of a future change in the default.</p>
+<li><p>Use <b>-neos</b> if a string should remain decoded if it was decoded by Perl::Tidy. This is only appropriate if the calling program will handle any needed encoding before outputting the string. If needed, this flag can be added to the end of the <b>argv</b> parameter passed to Perl::Tidy.</p>
</li>
</ul>
-<p>For example, to set <b>-eos</b> the following could be used</p>
+<p>For some background information see <a href="https://github.com/perltidy/perltidy/blob/master/docs/eos_flag.md">https://github.com/perltidy/perltidy/blob/master/docs/eos_flag.md</a>.</p>
+
+<p>This change in default behavior was made over a period of time as follows:</p>
-<pre><code> $argv .= " -eos" if ( $Perl::Tidy::VERSION > 20220101 );
+<ul>
+
+<li><p>For versions before 20220217 the <b>-eos</b> flag was not available and the behavior was equivalent to <b>-neos</b>.</p>
- $error_flag = Perl::Tidy::perltidy(
- argv => $argv,
- source => \$source,
- destination => \$destination,
- stderr => \$stderr,
- errorfile => \$errorfile
- );</code></pre>
+</li>
+<li><p>In version 20220217 the <b>-eos</b> flag was added but the default remained <b>-neos</b>.</p>
-<p>The test on version allows older versions of Perl::Tidy to still be used.</p>
+</li>
+<li><p>For versions after 20220217 the default was set to <b>-eos</b>.</p>
-<p>For some background information see <a href="https://github.com/perltidy/perltidy/issues/83">https://github.com/perltidy/perltidy/issues/83</a> and <a href="https://github.com/houseabsolute/perl-code-tidyall/issues/84">https://github.com/houseabsolute/perl-code-tidyall/issues/84</a>.</p>
+</li>
+</ul>
</dd>
<dt id="stderr"><b>stderr</b></dt>
<p>In the present example, we are only looking for tokens of type <b>i</b> (identifiers), so the for loop skips past all other types. When an identifier is found, its actual text is checked to see if it is one being sought. If so, the above write_line prints the token and its line number.</p>
-<p>The <b>formatter</b> feature is relatively new in perltidy, and further documentation needs to be written to complete its description. However, several example programs have been written and can be found in the <b>examples</b> section of the source distribution. Probably the best way to get started is to find one of the examples which most closely matches your application and start modifying it.</p>
+<p>The <b>examples</b> section of the source distribution has some examples of programs which use the <b>formatter</b> option.</p>
<p>For help with perltidy's peculiar way of breaking lines into tokens, you might run, from the command line,</p>
<pre><code> perltidy -D filename</code></pre>
-<p>where <i>filename</i> is a short script of interest. This will produce <i>filename.DEBUG</i> with interleaved lines of text and their token types. The <b>-D</b> flag has been in perltidy from the beginning for this purpose. If you want to see the code which creates this file, it is <code>write_debug_entry</code> in Tidy.pm.</p>
+<p>where <i>filename</i> is a short script of interest. This will produce <i>filename.DEBUG</i> with interleaved lines of text and their token types. The <b>-D</b> flag has been in perltidy from the beginning for this purpose. If you want to see the code which creates this file, it is <code>sub Perl::Tidy::Debugger::write_debug_entry</code></p>
<h1 id="EXPORT">EXPORT</h1>
<h1 id="VERSION">VERSION</h1>
-<p>This man page documents Perl::Tidy version 20220217</p>
+<p>This man page documents Perl::Tidy version 20220613</p>
<h1 id="LICENSE">LICENSE</h1>
<h1 id="BUG-REPORTS">BUG REPORTS</h1>
-<p>A list of current bugs and issues can be found at the CPAN site <a href="https://rt.cpan.org/Public/Dist/Display.html?Name=Perl-Tidy">https://rt.cpan.org/Public/Dist/Display.html?Name=Perl-Tidy</a></p>
-
-<p>To report a new bug or problem, use the link on this page.</p>
-
<p>The source code repository is at <a href="https://github.com/perltidy/perltidy">https://github.com/perltidy/perltidy</a>.</p>
+<p>To report a new bug or problem, use the "issues" link on this page.</p>
+
<h1 id="SEE-ALSO">SEE ALSO</h1>
<p>The perltidy(1) man page describes all of the features of perltidy. It can be found at http://perltidy.sourceforge.net.</p>
--- /dev/null
+# The --encode-output-strings Flag
+
+## What's this about?
+
+This is about making perltidy work better as a filter when called from other
+Perl scripts. For example, in the following example a reference to a
+string `$source` is passed to perltidy and it stores the formatted result in
+a string named `$output`:
+
+```
+ my $output;
+ my $err = Perl::Tidy::perltidy(
+ source => \$source,
+ destination => \$output,
+ argv => $argv,
+ );
+```
+
+For a filtering operation we expect to be able to directly compare the source and output strings, like this:
+
+```
+ if ($output eq $source) {print "Your formatting is unchanged\n";}
+```
+
+Or we might want to optionally skip the filtering step and pass the source
+directly on to the next stage of processing. This requires that the source
+and output strings be in the same storage mode.
+
+The problem is that in versions of perltidy prior to 2022 there was a use case
+where this was not possible. That case was when perltidy received an encoded
+source and decoded it from a utf8 but did not re-encode it before storing it in
+the output string. So the source string was in a different storage mode than
+the output string, and a direct comparison was not meaningful.
+
+This problem is an unintentional result of the historical evolution of perltidy and needs to be fixed.
+
+The same problem occurs if the destination is an array rather than a string,
+so for simplicity we can limit this discussion to string destinations, which
+are more common.
+
+## How will the problem be fixed?
+
+A fix is being phased in over a couple of steps. The first step was to
+introduce a new flag in in version 20220217. The new flag is
+**--encode-output-strings**, or **-eos**. When this is set, perltidy will fix
+the specific problem mentioned above by doing an encoding before returning.
+So perltidy will behave well as a filter when **-eos** is set.
+
+To illustrate using this flag in the above example, we could write
+
+```
+ my $output;
+
+ # Make perltidy versions after 2022 behave well as a filter
+ $argv .= " -eos" if ($Perl::Tidy::VERSION > 20220101);
+ my $err = Perl::Tidy::perltidy(
+ source => \$source,
+ destination => \$output,
+ argv => $argv,
+ );
+```
+
+With this modification we can make a meaningful direct comparison of `$source` and `$output`. The test on `$VERSION` allows this to work with older versions of perltidy (which would not recognize the flag -eos). An update such as the above can be made right now to facilitate a smooth transition to the new default.
+
+In the second step, possibly later in 2022, the new **-eos** flag will become the default.
+
+## What can go wrong?
+
+The first step is safe because the default behavior is unchanged. But the programmer has to set **-eos** for the corrected behavior to go into effect.
+
+The second step, in which **-eos** becomes the default, will have no effect on programs which do not require perltidy to decode strings, and it will make some programs start processing encoded strings correctly. But there is also the possibility of **double encoding** of the output, or in other words data corruption, in some cases. This could happen if an existing program already has already worked around this issue by encoding the output that it receives back from perltidy. It is important to check for this.
+
+To see how common this problem might be, all programs on CPAN which use Perl::Tidy as a filter were examined. Of a total of 45 programs located, one was identified for which the change in default would definitely cause double encoding, and in one program it was difficult to determine. It looked like the rest of the programs would either not be affected or would start working correctly when processing encoded files. Here is a slightly revised version of the code for the program which would have a problem with double encoding with the new default:
+
+```
+ my $output;
+ Perl::Tidy::perltidy(
+ source => \$self->{data},
+ destination => \$output,
+ stderr => \$perltidy_err,
+ errorfile => \$perltidy_err,
+ logfile => \$perltidy_log,
+ argv => $perltidy_argv,
+ );
+
+ # convert source back to raw
+ encode_utf8 $output;
+```
+
+The problem is in the last line where encoding is done after the call to perltidy. This
+encoding operation was added by the module author to compensate for the lack of an
+encoding step with the old default behavior. But if we run this code with
+**-eos**, which is the planned new default, encoding will also be done by perltidy before
+it returns, with the result that `$output` gets double encoding. This must be avoided. Here
+is one way to modify the above code to avoid double encoding:
+
+```
+ my $has_eos_flag = $Perl::Tidy::VERSION > 20220101;
+ $perltidy_argv .= ' -eos' if $has_eos_flag;
+
+ Perl::Tidy::perltidy(
+ source => \$self->{data},
+ destination => \$output,
+ stderr => \$perltidy_err,
+ errorfile => \$perltidy_err,
+ logfile => \$perltidy_log,
+ argv => $perltidy_argv,
+ );
+
+ # convert source back to raw if perltidy did not do it
+ encode_utf8($output) if ( !$has_eos_flag );
+```
+
+A related problem is if an update of Perl::Tidy is made without also updating
+a corrected version of a module such as the above. To help reduce the chance
+that this will occur the Change Log for perltidy will contain a warning to be
+alert for the double encoding problem, and how to reset the default if
+necessary. This is also the reason for waiting some time before the second step is made.
+
+If double encoding does appear to be occuring after the default change for some program which calls Perl::Tidy, then a quick emergency fix can be made by the program user by setting **-neos** to revert to the old default. A better fix can eventually be made by the program author by removing the second encoding using a technique such as illustrated above.
+
+## Summary
+
+A new flag, **-eos**, has been added to cause Perl::Tidy to behave better as a
+filter when called from other Perl scripts. This flag will eventually become
+the default setting. Programs which use Perl::Tidy as a
+filter can be tested right now with the new **-eos** flag to be sure that double
+encoding is not possible when the default is changed.
+
+## Reference
+
+This flag was originally introduced to fix a problem with the widely-used **tidyall** program (see https://github.com/houseabsolute/perl-code-tidyall/issues/84).
+
+## Appendix, a little closer look
+
+A string of text (here, a Perl script) can be stored by Perl in one of two
+internal storage formats. For simplicity let's call them 'B' mode (for 'Byte')
+mode and 'C' mode (for 'Character'). The 'B' mode can be used for text with
+single-byte characters or for storing an encoded string of multi-byte
+characters. The 'C' mode is needed for actually working with multi-byte
+characters. Thinking of a Perl script as a single long string of text, we can
+look at the mode of the text of a source script as it is processed by perltidy
+at three points:
+
+ - when it enters as a source
+ - at the intermediate stage as it is processed
+ - when it is leaves to its destination
+
+Since 'C' mode only has meaning within Perl scripts, a rule is that outside of
+the realm of Perl the text must be stored in 'B' mode.
+
+The source can only be in 'C' mode if it arrives by a call from another Perl
+program, and the destination can only be in 'C' mode if the destination is a
+Perl program. Otherwise, if the destination is a file, or object with a print
+method, then it will be assumed to be ending its existance as a Perl string and
+will be placed in an end state which is 'B' mode.
+
+Transition from a starting 'B' mode to 'C' mode is done by a decoding operation
+according to the user settings. A transition from an intermediate 'C' mode to
+an ending 'B' mode is done by an encoding operation. It never makes sense to
+transition from a starting 'C' mode to a 'B' mode, or from an intermediate 'B'
+mode to an ending 'C' mode.
+
+Let us make a list of all possible sets of string storage modes to be sure that
+all cases are covered. If each of the three stages list above (entry,
+intermedite, and exit) could be in 'B' or 'C' mode then we would have a total
+of 2 x 2 x 2 = 8 combinations of states. Each end point may either be a file
+or a string reference. Here is a list of them, with a note indicating which
+ones are possible, and when:
+
+ # modes when
+ 1 - B->B->B always ok: (file or string )->(file or string)
+ 2 - B->B->C never (trailing B->C never done)
+ 3 - B->C->B ok if destination is a file or -eos is set [NEW DEFAULT]
+ 4 - B->C->C ok if destination is a string and -neos is set [OLD DEFAULT]
+ 5 - C->B->B never (leading C->B never done)
+ 6 - C->B->C never (leading C->B and trailing B->C never done)
+ 7 - C->C->B only for string-to-file
+ 8 - C->C->C only for string-to-string
+
+So three of these cases (2, 5, and 6) cannot occur and the other five can
+occur. Of these five possible cases, only four are possible when the
+destination is a string:
+
+ 1 - B->B->B ok
+ 3 - B->C->B ok if -eos is set [NEW DEFAULt]
+ 4 - B->C->C ok if -neos is set [OLD DEFAULT]
+ 8 - C->C->C string-to-string only
+
+The first three of these may start at either a file or a string, and the last one only starts at a string.
+
+From this we can see that, if **-eos** is set, then only cases 1, 3, and 8 can occur. In that case the starting and ending states have the same storage mode for all routes through perltidy which end at a string. This verifies that perltidy will work well as a filter in all cases when the **-eos** flag is set, which is the goal here.
+
+The last case in this table, the C->C->C route, corresponds to programs which
+pass decoded strings to perltidy. This is a common usage pattern, and this
+route is not influenced by the **-eos** flag setting, since it only applies to
+strings that have been decoded by perltidy itself.
+
+Incidentally, the full name of the flag, **--encode-output-strings**, is not
+the best because it does not describe what happens in this case. It was
+difficult to find a concise name for this flag. A more correct name would have
+been **--encode-output-strings-that-you-decode**, but that is rather long. A
+more intuitive name for the flag might have been **--be-a-nice-filter**.
+
+Finally, note that case 7 in the full table, the C->C->B route, is an unusual
+but possible situation involving a source string being sent directly to a file.
+It is the only situation in which perltidy does an encoding without having done
+a corresponding previous decoding.
<h1 id="DESCRIPTION">DESCRIPTION</h1>
-<p>Perltidy reads a perl script and writes an indented, reformatted script.</p>
+<p>Perltidy reads a perl script and writes an indented, reformatted script. This document describes the parameters available for controlling this formatting.</p>
+
+<p>Perltidy is a commandline frontend to the module Perl::Tidy. For documentation describing how to call the Perl::Tidy module from other applications see the separate documentation for Perl::Tidy. It is the file Perl::Tidy.pod in the source distribution.</p>
<p>Many users will find enough information in <a href="#EXAMPLES">"EXAMPLES"</a> to get started. New users may benefit from the short tutorial which can be found at http://perltidy.sourceforge.net/tutorial.html</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>
+<p>will cause the perltidy to treat the words 'method', 'fun', '_sub' and 'M4' the same as if they were 'sub'. Note that if the alias words are separated by spaces then the string of words should be placed in quotes.</p>
<p>Note that several other parameters accept a list of keywords, including 'sub' (see <a href="#Specifying-Block-Types">"Specifying Block Types"</a>). You do not need to include any sub aliases in these lists. Just include keyword 'sub' if you wish, and all aliases are automatically included.</p>
<dt id="gal-s---grep-alias-list-s"><b>-gal=s</b>, <b>--grep-alias-list=s</b></dt>
<dd>
-<p>This flag allows a code block following an external 'list operator' function to be formatted as if it followed one of the builtin keywords <b>grep</b>, <b>map</b> or <b>sort</b>. The string <b>s</b> contains the names of one or more such list operators, separated by spaces or commas.</p>
+<p>This flag allows a code block following an external 'list operator' function to be formatted as if it followed one of the built-in keywords <b>grep</b>, <b>map</b> or <b>sort</b>. The string <b>s</b> contains the names of one or more such list operators, separated by spaces or commas.</p>
<p>By 'list operator' is meant a function which is invoked in the form</p>
<dt id="et-n---entab-leading-whitespace"><b>-et=n</b>, <b>--entab-leading-whitespace</b></dt>
<dd>
-<p>This flag causes each <b>n</b> initial space characters to be replaced by one tab character.</p>
+<p>This flag causes each <b>n</b> leading space characters produced by the formatting process to be replaced by one tab character. The formatting process itself works with space characters. The <b>-et=n</b> parameter is applied as a last step, after formatting is complete, to convert leading spaces into tabs. Before starting to use tabs, it is essential to first get the indentation controls set as desired without tabs, particularly the two parameters <b>--indent-columns=n</b> (or <b>-i=n</b>) and <b>--continuation-indentation=n</b> (or <b>-ci=n</b>).</p>
-<p>The value of the integer <b>n</b> can be any value but can be coordinated with the number of spaces used for intentation. For example, <b>-et=4 -ci=4 -i=4</b> will produce one tab for each indentation level and and one for each continuation indentation level. You may want to coordinate the value of <b>n</b> with what your display software assumes for the spacing of a tab.</p>
+<p>The value of the integer <b>n</b> can be any value but can be coordinated with the number of spaces used for indentation. For example, <b>-et=4 -ci=4 -i=4</b> will produce one tab for each indentation level and and one for each continuation indentation level. You may want to coordinate the value of <b>n</b> with what your display software assumes for the spacing of a tab.</p>
</dd>
<dt id="t---tabs"><b>-t</b>, <b>--tabs</b></dt>
<dd>
-<p>This flag causes one leading tab character to be inserted for each level of indentation. Certain other features are incompatible with this option, and if these options are also given, then a warning message will be issued and this flag will be unset. One example is the <b>-lp</b> option. This flag is retained for backwards compatibility, but if you use tabs, the <b>-et=n</b> flag is recommended.</p>
+<p>This flag causes one leading tab character to be inserted for each level of indentation. Certain other features are incompatible with this option, and if these options are also given, then a warning message will be issued and this flag will be unset. One example is the <b>-lp</b> option. This flag is retained for backwards compatibility, but if you use tabs, the <b>-et=n</b> flag is recommended. If both <b>-t</b> and <b>-et=n</b> are set, the <b>-et=n</b> is used.</p>
</dd>
<dt id="dt-n---default-tabsize-n"><b>-dt=n</b>, <b>--default-tabsize=n</b></dt>
<dt id="enc-s---character-encoding-s"><b>-enc=s</b>, <b>--character-encoding=s</b></dt>
<dd>
-<p>This flag indicates if the input data stream use a character encoding. Perltidy does not look for the encoding directives in the soure stream, such as <b>use utf8</b>, and instead relies on this flag to determine the encoding. (Note that perltidy often works on snippets of code rather than complete files so it cannot rely on <b>use utf8</b> directives).</p>
+<p>This flag indicates if the input data stream use a character encoding. Perltidy does not look for the encoding directives in the source stream, such as <b>use utf8</b>, and instead relies on this flag to determine the encoding. (Note that perltidy often works on snippets of code rather than complete files so it cannot rely on <b>use utf8</b> directives).</p>
<p>The possible values for <b>s</b> are:</p>
<dt id="eos-s---encode-output-strings-s"><b>-eos=s</b>, <b>--encode-output-strings=s</b></dt>
<dd>
-<p>This flag has been added to resolve an issue involving the interface between Perl::Tidy and calling programs, and in particular <b>Code::TidyAll (tidyall)</b>. By default Perl::Tidy returns unencoded strings to the calling program, but some programs expect encoded strings. Setting this flag causes Perl::Tidy to return encoded output strings which it decoded. For some background information see <a href="https://github.com/perltidy/perltidy/issues/83">https://github.com/perltidy/perltidy/issues/83</a> and <a href="https://github.com/houseabsolute/perl-code-tidyall/issues/84">https://github.com/houseabsolute/perl-code-tidyall/issues/84</a>.</p>
+<p>This flag was added to resolve an issue involving the interface between Perl::Tidy and calling programs, and in particular <b>Code::TidyAll (tidyall)</b>.</p>
+
+<p>If you only run the <b>perltidy</b> binary this flag has no effect. If you run a program which calls the Perl::Tidy module and receives a string in return, then the meaning of the flag is as follows:</p>
-<p>If you only run the <b>perltidy</b> binary this flag has no effect.</p>
+<ul>
-<p>If you use <b>tidyall</b> with encoded files and encounter irregularities such as <b>wide character</b> messages you should set this flag.</p>
+<li><p>The setting <b>-eos</b> means Perl::Tidy should encode any string which it decodes. This is the default because it makes perltidy behave well as a filter, and is the correct setting for most programs.</p>
-<p>Additional information can be found in the man pages for the <b>Perl::Tidy</b> module.</p>
+</li>
+<li><p>The setting <b>-neos</b> means that a string should remain decoded if it was decoded by Perl::Tidy. This is only appropriate if the calling program will handle any needed encoding before outputting the string.</p>
+
+</li>
+</ul>
+
+<p>The default was changed from <b>-neos</b> to <b>-eos</b> in versions after 20220217. If this change causes a program to start running incorrectly on encoded files, an emergency fix might be to set <b>-neos</b>. Additional information can be found in the man pages for the <b>Perl::Tidy</b> module and also in <a href="https://github.com/perltidy/perltidy/blob/master/docs/eos_flag.md">https://github.com/perltidy/perltidy/blob/master/docs/eos_flag.md</a>.</p>
</dd>
<dt id="gcs---use-unicode-gcstring"><b>-gcs</b>, <b>--use-unicode-gcstring</b></dt>
<p>By default, perltidy examines the input file and tries to determine the starting indentation level. While it is often zero, it may not be zero for a code snippet being sent from an editing session.</p>
-<p>To guess the starting indentation level perltidy simply assumes that indentation scheme used to create the code snippet is the same as is being used for the current perltidy process. This is the only sensible guess that can be made. It should be correct if this is true, but otherwise it probably won't. For example, if the input script was written with -i=2 and the current peltidy flags have -i=4, the wrong initial indentation will be guessed for a code snippet which has non-zero initial indentation. Likewise, if an entabbing scheme is used in the input script and not in the current process then the guessed indentation will be wrong.</p>
+<p>To guess the starting indentation level perltidy simply assumes that indentation scheme used to create the code snippet is the same as is being used for the current perltidy process. This is the only sensible guess that can be made. It should be correct if this is true, but otherwise it probably won't. For example, if the input script was written with -i=2 and the current perltidy flags have -i=4, the wrong initial indentation will be guessed for a code snippet which has non-zero initial indentation. Likewise, if an entabbing scheme is used in the input script and not in the current process then the guessed indentation will be wrong.</p>
<p>If the default method does not work correctly, or you want to change the starting level, use <b>-sil=n</b>, to force the starting level to be n.</p>
<p>These flags have no effect on code BLOCKS, such as if/then/else blocks, which always use whatever is specified with <b>-i=n</b>.</p>
-<p>Some limitiations on these flags are:</p>
+<p>Some limitations on these flags are:</p>
<ul>
<p>Only one of these two flags may be used. Both flags can achieve the same result, but the <b>-lpil=s</b> flag is much easier to describe and use and is recommended. The <b>-lpxl=s</b> flag was the original implementation and is only retained for backwards compatibility.</p>
-<p>This list <b>s</b> for these parametes is a string with space-separated items. Each item consists of up to three pieces of information in this order: (1) an optional letter code (2) a required container type, and (3) an optional numeric code.</p>
+<p>This list <b>s</b> for these parameters is a string with space-separated items. Each item consists of up to three pieces of information in this order: (1) an optional letter code (2) a required container type, and (3) an optional numeric code.</p>
<p>The only required piece of information is a container type, which is one of '(', '[', or '{'. For example the string</p>
<pre><code> -lpil='('</code></pre>
-<p>means use -lp formatting only on lists within parentheses, not lists in square-bracets or braces. The same thing could alternatively be specified with</p>
+<p>means use -lp formatting only on lists within parentheses, not lists in square-brackets or braces. The same thing could alternatively be specified with</p>
<pre><code> -lpxl = '[ {'</code></pre>
<p>A second optional item of information which can be given for parentheses is an alphanumeric letter which is used to limit the selection further depending on the type of token immediately before the paren. The possible letters are currently 'k', 'K', 'f', 'F', 'w', and 'W', with these meanings for matching whatever precedes an opening paren:</p>
-<pre><code> 'k' matches if the previous nonblank token is a perl builtin keyword (such as 'if', 'while'),
+<pre><code> 'k' matches if the previous nonblank token is a perl built-in keyword (such as 'if', 'while'),
'K' matches if 'k' does not, meaning that the previous token is not a keyword.
'f' matches if the previous token is a function other than a keyword.
'F' matches if 'f' does not.
<pre><code> # perltidy -nwrs='+', syntax error:
for my $severity ( reverse $SEVERITY_LOWEST +1 .. $SEVERITY_HIGHEST ) { ... }</code></pre>
-<p>To avoid subtle parsing problems like this, it is best to avoid spacing a binary operator asymetrically with a space on the left but not on the right.</p>
+<p>To avoid subtle parsing problems like this, it is best to avoid spacing a binary operator asymmetrically with a space on the left but not on the right.</p>
</dd>
<dt id="Space-between-specific-keywords-and-opening-paren"><b>Space between specific keywords and opening paren</b></dt>
<p>A third optional item of information which can be given is an alphanumeric letter which is used to limit the selection further depending on the type of token immediately before the container. If given, it goes just before the container symbol. The possible letters are currently 'k', 'K', 'f', 'F', 'w', and 'W', with these meanings:</p>
-<pre><code> 'k' matches if the previous nonblank token is a perl builtin keyword (such as 'if', 'while'),
+<pre><code> 'k' matches if the previous nonblank token is a perl built-in keyword (such as 'if', 'while'),
'K' matches if 'k' does not, meaning that the previous token is not a keyword.
'f' matches if the previous token is a function other than a keyword.
'F' matches if 'f' does not.
<dt id="bal-n---break-after-labels-n"><b>bal=n, --break-after-labels=n</b></dt>
<dd>
-<p>This flag controls whether or not a line break occurs after a label. There are three possible valuse for <b>n</b>:</p>
+<p>This flag controls whether or not a line break occurs after a label. There are three possible values for <b>n</b>:</p>
-<pre><code> -bal=0 break if there is a break in the input [DEFAULt]
+<pre><code> -bal=0 break if there is a break in the input [DEFAULT]
-bal=1 always break after a label
-bal=2 never break after a label</code></pre>
<p>It is possible to be more specific in matching parentheses by preceding them with a letter. The possible letters are 'k', 'K', 'f', 'F', 'w', and 'W', with these meanings (these are the same as used in the <b>--weld-nested-exclusion-list</b> and <b>--line-up-parentheses-exclusion-list</b> parameters):</p>
-<pre><code> 'k' matches if the previous nonblank token is a perl builtin keyword (such as 'if', 'while'),
+<pre><code> 'k' matches if the previous nonblank token is a perl built-in keyword (such as 'if', 'while'),
'K' matches if 'k' does not, meaning that the previous token is not a keyword.
'f' matches if the previous token is a function other than a keyword.
'F' matches if 'f' does not.
<pre><code> perltidy -kba='f('</code></pre>
-<p><b>NOTE</b>: To match all opening curly braces, and no other opening tokens, please prefix the brace it with an asterisk, like this: '*{'. Otherwise a warning message will occur. This is necessary to avoid problems while the input scheme is being updated and generalized. A single bare curly brace previously matched all container tokens, and tentatively still does. Likewise, to match all closing curly braces, and no other closing tokens, use '*}'.</p>
+<p><b>NOTE</b>: A request to break before an opening container, such as <b>-kbb='('</b>, will be silently ignored because it can lead to formatting instability. Likewise, a request to break after a closing container, such as <b>-kba</b>=')', will also be silently ignored.</p>
</dd>
<dt id="iob---ignore-old-breakpoints"><b>-iob</b>, <b>--ignore-old-breakpoints</b></dt>
<p><b>-kgbi</b> or <b>--keyword-group-blanks-inside</b> controls the insertion of blank lines between the first and last statement of the entire group. If there is a continuous run of a single statement type with more than the minimum threshold number (as specified with <b>-kgbs=s</b>) then this switch causes a blank line be inserted between this subgroup and the others. In the example above this happened between the <b>use</b> and <b>my</b> statements.</p>
-<p><b>-kgbd</b> or <b>--keyword-group-blanks-delete</b> controls the deletion of any blank lines that exist in the the group when it is first scanned. When statements are initially scanned, any existing blank lines are included in the collection. Any such orignial blank lines will be deleted before any other insertions are made when the parameter <b>-kgbd</b> is set. The default is not to do this, <b>-nkgbd</b>.</p>
+<p><b>-kgbd</b> or <b>--keyword-group-blanks-delete</b> controls the deletion of any blank lines that exist in the the group when it is first scanned. When statements are initially scanned, any existing blank lines are included in the collection. Any such original blank lines will be deleted before any other insertions are made when the parameter <b>-kgbd</b> is set. The default is not to do this, <b>-nkgbd</b>.</p>
<p><b>-kgbr=n</b> or <b>--keyword-group-blanks-repeat-count=n</b> specifies <b>n</b>, the maximum number of times this logic will be applied to any file. The special value <b>n=0</b> is the same as n=infinity which means it will be applied to an entire script [Default]. A value <b>n=1</b> could be used to make it apply just one time for example. This might be useful for adjusting just the <b>use</b> statements in the top part of a module for example.</p>
<dt id="Completely-turning-off-vertical-alignment-with--novalign"><b>Completely turning off vertical alignment with -novalign</b></dt>
<dd>
-<p>The default is to use vertical alignment, but bertical alignment can be completely turned of with the <b>-novalign</b> flag.</p>
+<p>The default is to use vertical alignment, but vertical alignment can be completely turned of with the <b>-novalign</b> flag.</p>
<p>A lower level of control of vertical alignment is possible with three parameters <b>-vc</b>, <b>-vsc</b>, and <b>-vbc</b>. These independently control alignment of code, side comments and block comments. They are described in the next section.</p>
<dt id="Controlling-side-comment-alignment-with---valign-side-comments-or--vsc"><b>Controlling side comment alignment with --valign-side-comments or -vsc</b></dt>
<dd>
-<p>The <b>-vsc</b> flag enables alignment of side comments and is enabled by default. If side comment aligment is disabled with <b>-nvsc</b> they will appear at a fixed space from the preceding code token. The default is <b>-vsc</b></p>
+<p>The <b>-vsc</b> flag enables alignment of side comments and is enabled by default. If side comment alignment is disabled with <b>-nvsc</b> they will appear at a fixed space from the preceding code token. The default is <b>-vsc</b></p>
</dd>
<dt id="Controlling-block-comment-alignment-with---valign-block-comments-or--vbc"><b>Controlling block comment alignment with --valign-block-comments or -vbc</b></dt>
<p>More detailed control of alignment types is available with these two parameters. Most of the vertical alignments in typical programs occur at one of the tokens ',', '=', and '=>', but many other alignments are possible and are given in the following list:</p>
<pre><code> = **= += *= &= <<= &&= -= /= |= >>= ||= //= .= %= ^= x=
- { ( ? : , ; => && || ~~ !~~ =~ !~ // <=> ->
+ { ( ? : , ; => && || ~~ !~~ =~ !~ // <=> -> q
if unless and or err for foreach while until</code></pre>
-<p>These alignments are all enabled by default, but they can be selectively disabled by including one or more of these tokens in the space-separated list <b>valign-exclusion-list=s</b>. For example, the following would prevent alignment at <b>=</b> and <b>if</b>:</p>
+<p>These alignment types correspond to perl symbols, operators and keywords except for 'q', which refers to the special case of alignment in a 'use' statement of qw quotes and empty parens.</p>
+
+<p>They are all enabled by default, but they can be selectively disabled by including one or more of these tokens in the space-separated list <b>valign-exclusion-list=s</b>. For example, the following would prevent alignment at <b>=</b> and <b>if</b>:</p>
<pre><code> --valign-exclusion-list='= if'</code></pre>
-<p>If it is simpler to specify only the token types which are to be aligned, then include the types which are to be aligned in the list of <b>--valign-inclusion-list</b>. You may leave the <b>valign-exclusion-list</b> undefined, or use the special symbol <b>*</b> for the exclusion list. For example, the following parameters enable alignment only at commas and 'fat commas':</p>
+<p>If it is simpler to specify only the token types which are to be aligned, then include the types which are to be aligned in the list of <b>--valign-inclusion-list</b>. In that case you may leave the <b>valign-exclusion-list</b> undefined, or use the special symbol <b>*</b> for the exclusion list. For example, the following parameters enable alignment only at commas and 'fat commas':</p>
<pre><code> --valign-inclusion-list=', =>'
--valign-exclusion-list='*' ( this is optional and may be omitted )</code></pre>
<p>Two commands which remove comments (but not pod) are: <b>-dbc</b> or <b>--delete-block-comments</b> and <b>-dsc</b> or <b>--delete-side-comments</b>. (Hanging side comments will be deleted with side comments here.)</p>
+<p>When side comments are deleted, any special control side comments for non-indenting braces will be retained unless they are deactivated with a <b>-nnib</b> flag.</p>
+
<p>The negatives of these commands also work, and are the defaults. When block comments are deleted, any leading 'hash-bang' will be retained. Also, if the <b>-x</b> flag is used, any system commands before a leading hash-bang will be retained (even if they are in the form of comments).</p>
</dd>
<p>These other locations are system-dependent, and may be displayed with the command <code>perltidy -dpro</code>. Under Unix systems, it will first look for an environment variable <b>PERLTIDY</b>. Then it will look for a <i>.perltidyrc</i> file in the home directory, and then for a system-wide file <i>/usr/local/etc/perltidyrc</i>, and then it will look for <i>/etc/perltidyrc</i>. Note that these last two system-wide files do not have a leading dot. Further system-dependent information will be found in the INSTALL file distributed with perltidy.</p>
-<p>Under Windows, perltidy will also search for a configuration file named perltidy.ini since Windows does not allow files with a leading period (.). Use <code>perltidy -dpro</code> to see the possible locations for your system. An example might be <i>C:\Documents and Settings\All Users\perltidy.ini</i>.</p>
+<p>Under Windows, perltidy will also search for a configuration file named <i>perltidy.ini</i> since Windows does not allow files with a leading period (.). Use <code>perltidy -dpro</code> to see the possible locations for your system. An example might be <i>C:\Documents and Settings\All Users\perltidy.ini</i>.</p>
<p>Another option is the use of the PERLTIDY environment variable. The method for setting environment variables depends upon the version of Windows that you are using. Instructions for Windows 95 and later versions can be found here:</p>
<h1 id="VERSION">VERSION</h1>
-<p>This man page documents perltidy version 20220217</p>
+<p>This man page documents perltidy version 20220613</p>
<h1 id="BUG-REPORTS">BUG REPORTS</h1>
-<p>A list of current bugs and issues can be found at the CPAN site <a href="https://rt.cpan.org/Public/Dist/Display.html?Name=Perl-Tidy">https://rt.cpan.org/Public/Dist/Display.html?Name=Perl-Tidy</a></p>
-
-<p>To report a new bug or problem, use the link on this page.</p>
-
<p>The source code repository is at <a href="https://github.com/perltidy/perltidy">https://github.com/perltidy/perltidy</a>.</p>
+<p>To report a new bug or problem, use the "issues" link on this page.</p>
+
<h1 id="COPYRIGHT">COPYRIGHT</h1>
<p>Copyright (c) 2000-2022 by Steve Hancock</p>
use strict;
use Exporter;
use Carp;
+use English qw( -no_match_vars );
use Digest::MD5 qw(md5_hex);
use Perl::Tidy::Debugger;
use Perl::Tidy::DevNull;
use Perl::Tidy::Logger;
use Perl::Tidy::Tokenizer;
use Perl::Tidy::VerticalAligner;
-local $| = 1;
+local $OUTPUT_AUTOFLUSH = 1;
-# this can be turned on for extra checking during development
-use constant DEVEL_MODE => 0;
+# DEVEL_MODE can be turned on for extra checking during development
+use constant DEVEL_MODE => 0;
+use constant EMPTY_STRING => q{};
+use constant SPACE => q{ };
use vars qw{
$VERSION
# Release version must be bumped, and it is probably past time for a
# release anyway.
- $VERSION = '20220217';
+ $VERSION = '20220613';
}
sub DESTROY {
======================================================================
EOM
exit 1;
-}
+} ## end sub AUTOLOAD
sub streamhandle {
$New = sub { undef };
confess <<EOM;
------------------------------------------------------------------------
-No 'getline' method is defined for object of class $ref
+No 'getline' method is defined for object of class '$ref'
Please check your call to Perl::Tidy::perltidy. Trace follows.
------------------------------------------------------------------------
EOM
$New = sub { undef };
confess <<EOM;
------------------------------------------------------------------------
-No 'print' method is defined for object of class $ref
+No 'print' method is defined for object of class '$ref'
Please check your call to Perl::Tidy::perltidy. Trace follows.
------------------------------------------------------------------------
EOM
$fh = $New->( $filename, $mode );
if ( !$fh ) {
- Warn("Couldn't open file:$filename in mode:$mode : $!\n");
+ Warn("Couldn't open file:$filename in mode:$mode : $ERRNO\n");
}
else {
elsif ( $filename eq '-' ) {
binmode STDOUT, ":raw:encoding(UTF-8)";
}
+ else {
+ # shouldn't happen
+ }
}
# Case 2: handle unencoded data
else {
if ( ref($fh) eq 'IO::File' ) { binmode $fh }
elsif ( $filename eq '-' ) { binmode STDOUT }
+ else { } # shouldn't happen
}
}
return $fh, ( $ref or $filename );
-}
+} ## end sub streamhandle
sub find_input_line_ending {
binmode $fh;
my $buf;
read( $fh, $buf, 1024 );
- close $fh;
+ close $fh || return $ending;
if ( $buf && $buf =~ /([\012\015]+)/ ) {
my $test = $1;
else { }
return $ending;
-}
+} ## end sub find_input_line_ending
{ ## begin closure for sub catfile
BEGIN {
eval { require File::Spec };
- $missing_file_spec = $@;
+ $missing_file_spec = $EVAL_ERROR;
}
sub catfile {
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 ( $OSNAME eq 'VMS' );
# this should work at least for Windows and Unix:
$test_file = $path . '/' . $name;
( $test_name, $test_path ) = fileparse($test_file);
return $test_file if ( $test_name eq $name );
return;
- }
+ } ## end sub catfile
} ## end closure for sub catfile
# Here is a map of the flow of data from the input source to the output
# Output Warn message and bump Warn count
sub Warn { my $msg = shift; $fh_stderr->print($msg); $Warn_count++; return }
+sub is_char_mode {
+
+ my ($string) = @_;
+
+ # Returns:
+ # true if $string is in Perl's internal character mode
+ # (also called the 'upgraded form', or UTF8=1)
+ # false if $string is in Perl's internal byte mode
+
+ # This function isolates the call to Perl's internal function
+ # utf8::is_utf8() which is true for strings represented in an 'upgraded
+ # form'. It is available after Perl version 5.8.
+ # See https://perldoc.perl.org/Encode.
+ # See also comments in Carp.pm and other modules using this function
+
+ return 1 if ( utf8::is_utf8($string) );
+ return;
+} ## end sub is_char_mode
+
sub perltidy {
my %input_hash = @_;
postfilter => undef,
);
+ # Status information which can be returned for diagnostic purposes.
+ # This is intended for testing and subject to change.
+
+ # List of "key => value" hash entries:
+
+ # Some relevant user input parameters for convenience:
+ # opt_format => value of --format: 'tidy', 'html', or 'user'
+ # opt_encoding => value of -enc flag: 'utf8', 'none', or 'guess'
+ # opt_encode_output => value of -eos flag: 'eos' or 'neos'
+ # opt_max_iterations => value of --iterations=n
+
+ # file_count => number of files processed in this call
+
+ # If multiple files are processed, then the following values will be for
+ # the last file only:
+
+ # input_name => name of the input stream
+ # output_name => name of the output stream
+
+ # The following two variables refer to Perl's two internal string modes,
+ # and have the values 0 for 'byte' mode and 1 for 'char' mode:
+ # char_mode_source => true if source is in 'char' mode. Will be false
+ # unless we received a source string ref with utf8::is_utf8() set.
+ # char_mode_used => true if text processed by perltidy in 'char' mode.
+ # Normally true for text identified as utf8, otherwise false.
+
+ # This tells if Unicode::GCString was used
+ # gcs_used => true if -gcs and Unicode::GCString found & used
+
+ # These variables tell what utf8 decoding/encoding was done:
+ # input_decoded_as => non-blank if perltidy decoded the source text
+ # output_encoded_as => non-blank if perltidy encoded before return
+
+ # These variables are related to iterations and convergence testing:
+ # iteration_count => number of iterations done
+ # ( can be from 1 to opt_max_iterations )
+ # converged => true if stopped on convergence
+ # ( can only happen if opt_max_iterations > 1 )
+ # blinking => true if stopped on blinking states
+ # ( i.e., unstable formatting, should not happen )
+
+ my $rstatus = {
+
+ file_count => 0,
+ opt_format => EMPTY_STRING,
+ opt_encoding => EMPTY_STRING,
+ opt_encode_output => EMPTY_STRING,
+ opt_max_iterations => EMPTY_STRING,
+
+ input_name => EMPTY_STRING,
+ output_name => EMPTY_STRING,
+ char_mode_source => 0,
+ char_mode_used => 0,
+ input_decoded_as => EMPTY_STRING,
+ output_encoded_as => EMPTY_STRING,
+ gcs_used => 0,
+ iteration_count => 0,
+ converged => 0,
+ blinking => 0,
+ };
+
# Fix for issue git #57
$Warn_count = 0;
local *STDERR = *STDERR;
if ( my @bad_keys = grep { !exists $defaults{$_} } keys %input_hash ) {
- local $" = ')(';
+ local $LIST_SEPARATOR = ')(';
my @good_keys = sort keys %defaults;
@bad_keys = sort @bad_keys;
confess <<EOM;
unless ( defined($dump_options_type) ) {
$dump_options_type = 'perltidyrc';
}
- unless ( $dump_options_type =~ /^(perltidyrc|full)$/ ) {
+ if ( $dump_options_type ne 'perltidyrc'
+ && $dump_options_type ne 'full' )
+ {
croak <<EOM;
------------------------------------------------------------------------
Please check value of -dump_options_type in call to perltidy;
}
}
else {
- $dump_options_type = "";
+ $dump_options_type = EMPTY_STRING;
}
if ($user_formatter) {
# string
else {
- my ( $rargv, $msg ) = parse_args($argv);
+ my ( $rargv_str, $msg ) = parse_args($argv);
if ($msg) {
Die(<<EOM);
Error parsing this string passed to to perltidy with 'argv':
$msg
EOM
}
- @ARGV = @{$rargv};
+ @ARGV = @{$rargv_str};
}
}
my $rpending_complaint;
- ${$rpending_complaint} = "";
+ ${$rpending_complaint} = EMPTY_STRING;
my $rpending_logfile_message;
- ${$rpending_logfile_message} = "";
+ ${$rpending_logfile_message} = EMPTY_STRING;
my ( $is_Windows, $Windows_type ) = look_for_Windows($rpending_complaint);
# instead of .tdy, etc. (but see also sub check_vms_filename)
my $dot;
my $dot_pattern;
- if ( $^O eq 'VMS' ) {
+ if ( $OSNAME eq 'VMS' ) {
$dot = '_';
$dot_pattern = '_';
}
$rpending_complaint, $dump_options_type,
);
- my $saw_extrude = ( grep { m/^-extrude$/ } @{$rraw_options} ) ? 1 : 0;
my $saw_pbp =
- ( grep { m/^-(pbp|perl-best-practices)$/ } @{$rraw_options} ) ? 1 : 0;
+ grep { $_ eq '-pbp' || $_ eq '-perl-best-practices' } @{$rraw_options};
#---------------------------------------------------------------
# Handle requests to dump information
$quit_now = 1;
foreach my $op ( @{$roption_string} ) {
my $opt = $op;
- my $flag = "";
+ my $flag = EMPTY_STRING;
# Examples:
# some-option=s
my %default_file_extension = (
tidy => 'tdy',
html => 'html',
- user => '',
+ user => EMPTY_STRING,
);
+ $rstatus->{'opt_format'} = $rOpts->{'format'};
+ $rstatus->{'opt_max_iterations'} = $rOpts->{'iterations'};
+ $rstatus->{'opt_encode_output'} =
+ $rOpts->{'encode-output-strings'} ? 'eos' : 'neos';
+
# be sure we have a valid output format
unless ( exists $default_file_extension{ $rOpts->{'format'} } ) {
- my $formats = join ' ',
+ my $formats = join SPACE,
sort map { "'" . $_ . "'" } keys %default_file_extension;
my $fmt = $rOpts->{'format'};
Die("-format='$fmt' but must be one of: $formats\n");
my $dh;
if ( opendir( $dh, './' ) ) {
my @files =
- grep { /$pattern/ && !-d $_ } readdir($dh);
+ grep { /$pattern/ && !-d } readdir($dh);
+ ##grep { /$pattern/ && !-d $_ } readdir($dh);
closedir($dh);
if (@files) {
unshift @ARGV, @files;
$fileroot = $input_file;
@input_file_stat = stat($input_file);
- if ( $^O eq 'VMS' ) {
+ if ( $OSNAME eq 'VMS' ) {
( $fileroot, $dot ) = check_vms_filename($fileroot);
}
my $new_path = $rOpts->{'output-path'};
unless ( -d $new_path ) {
unless ( mkdir $new_path, 0777 ) {
- Die("unable to create directory $new_path: $!\n");
+ Die("unable to create directory $new_path: $ERRNO\n");
}
}
my $path = $new_path;
my %saw_md5;
my $digest_input = 0;
- my $buf = '';
+ my $buf = EMPTY_STRING;
while ( my $line = $source_object->get_line() ) {
$buf .= $line;
}
my $remove_terminal_newline =
!$rOpts->{'add-terminal-newline'} && substr( $buf, -1, 1 ) !~ /\n/;
- # Decode the input stream if necessary requested
- my $encoding_in = "";
+ # Decode the input stream if necessary or requested
+ my $encoding_in = EMPTY_STRING;
my $rOpts_character_encoding = $rOpts->{'character-encoding'};
my $encoding_log_message;
- my $decoded_input_as = "";
-
- # Case 1. See if we already have an encoded string. In that
- # case, we have to ignore any encoding flag.
- if ( utf8::is_utf8($buf) ) {
+ my $decoded_input_as = EMPTY_STRING;
+ $rstatus->{'char_mode_source'} = 0;
+
+ # Case 1: If Perl is already in a character-oriented mode for this
+ # string rather than a byte-oriented mode. Normally, this happens if
+ # the caller has decoded a utf8 string before calling perltidy. But it
+ # could also happen if the user has done some unusual manipulations of
+ # the source. In any case, we will not attempt to decode it because
+ # that could result in an output string in a different mode.
+ if ( is_char_mode($buf) ) {
$encoding_in = "utf8";
+ $rstatus->{'char_mode_source'} = 1;
}
# Case 2. No input stream encoding requested. This is appropriate
}
# Case 3. guess input stream encoding if requested
- elsif ( $rOpts_character_encoding =~ /^guess$/i ) {
+ elsif ( lc($rOpts_character_encoding) eq 'guess' ) {
# The guessing strategy is simple: use Encode::Guess to guess
# an encoding. If and only if the guess is utf8, try decoding and
my $decoder = guess_encoding( $buf_in, 'utf8' );
if ( ref($decoder) ) {
$encoding_in = $decoder->name;
- if ( $encoding_in !~ /^(UTF-8|utf8)$/ ) {
- $encoding_in = "";
+ if ( $encoding_in ne 'UTF-8' && $encoding_in ne 'utf8' ) {
+ $encoding_in = EMPTY_STRING;
$buf = $buf_in;
$encoding_log_message .= <<EOM;
Guessed encoding '$encoding_in' is not utf8; no encoding will be used
else {
eval { $buf = $decoder->decode($buf_in); };
- if ($@) {
+ if ($EVAL_ERROR) {
$encoding_log_message .= <<EOM;
Guessed encoding '$encoding_in' but decoding was unsuccessful; no encoding is used
Warn(
"file: $input_file: bad guess to decode source as $encoding_in\n"
);
- $encoding_in = "";
+ $encoding_in = EMPTY_STRING;
$buf = $buf_in;
}
else {
}
}
}
- $encoding_log_message .= <<EOM;
-Unable to guess a character encoding
+ else {
+ $encoding_log_message .= <<EOM;
+Does not look like utf8 encoded text so processing as raw bytes
EOM
+ }
}
# Case 4. Decode with a specific encoding
$buf = Encode::decode( $encoding_in, $buf,
Encode::FB_CROAK | Encode::LEAVE_SRC );
};
- if ($@) {
+ if ($EVAL_ERROR) {
# Quit if we cannot decode by the requested encoding;
# Something is not right.
# read and write it as encoded data, and we will normalize these
# operations with utf8. If we have not decoded the data, then
# we must not treat it as encoded data.
- my $is_encoded_data = $encoding_in ? 'utf8' : "";
+ my $is_encoded_data = $encoding_in ? 'utf8' : EMPTY_STRING;
- # Define the function to determine the display width of character strings
+ $rstatus->{'input_name'} = $display_name;
+ $rstatus->{'opt_encoding'} = $rOpts_character_encoding;
+ $rstatus->{'char_mode_used'} = $encoding_in ? 1 : 0;
+ $rstatus->{'input_decoded_as'} = $decoded_input_as;
+
+ # Define the function to determine the display width of character
+ # strings
my $length_function = sub { return length( $_[0] ) };
if ($is_encoded_data) {
# requested, when the first encoded file is encountered
if ( !defined($loaded_unicode_gcstring) ) {
eval { require Unicode::GCString };
- $loaded_unicode_gcstring = !$@;
- if ( $@ && $rOpts->{'use-unicode-gcstring'} ) {
+ $loaded_unicode_gcstring = !$EVAL_ERROR;
+ if ( $EVAL_ERROR && $rOpts->{'use-unicode-gcstring'} ) {
Warn(<<EOM);
----------------------
-Unable to load Unicode::GCString: $@
+Unable to load Unicode::GCString: $EVAL_ERROR
Processing continues but some vertical alignment may be poor
To prevent this warning message, you can either:
- install module Unicode::GCString, or
$length_function = sub {
return Unicode::GCString->new( $_[0] )->columns;
};
+ $encoding_log_message .= <<EOM;
+Using 'Unicode::GCString' to measure horizontal character widths
+EOM
+ $rstatus->{'gcs_used'} = 1;
}
}
# prepare the output stream
#---------------------------------------------------------------
my $output_file = undef;
+ my $output_name = EMPTY_STRING;
my $actual_output_extension;
if ( $rOpts->{'outfile'} ) {
Die("You may not specify -o and -oext together\n");
}
$output_file = $rOpts->{outfile};
+ $output_name = $output_file;
# make sure user gives a file name after -o
if ( $output_file =~ /^-/ ) {
Die("$msg\n");
}
$output_file = '-';
+ $output_name = "<stdout>";
if ( $number_of_files <= 1 ) {
}
elsif ($destination_stream) {
$output_file = $destination_stream;
+ $output_name = "<destination_stream>";
}
elsif ($source_stream) { # source but no destination goes to stdout
$output_file = '-';
+ $output_name = "<stdout>";
}
elsif ( $input_file eq '-' ) {
$output_file = '-';
+ $output_name = "<stdout>";
}
else {
if ($in_place_modify) {
$output_file = IO::File->new_tmpfile()
- or Die("cannot open temp file for -b option: $!\n");
+ or Die("cannot open temp file for -b option: $ERRNO\n");
+ $output_name = $display_name;
}
else {
$actual_output_extension = $output_extension;
$output_file = $fileroot . $output_extension;
+ $output_name = $output_file;
}
}
+ $rstatus->{'file_count'} += 1;
+ $rstatus->{'output_name'} = $output_name;
+ $rstatus->{'iteration_count'} = 0;
+ $rstatus->{'converged'} = 0;
+
my $fh_tee;
my $tee_file = $fileroot . $dot . "TEE";
if ($teefile_stream) { $tee_file = $teefile_stream }
( $fh_tee, my $tee_filename ) =
Perl::Tidy::streamhandle( $tee_file, 'w', $is_encoded_data );
if ( !$fh_tee ) {
- Warn("couldn't open TEE file $tee_file: $!\n");
+ Warn("couldn't open TEE file $tee_file: $ERRNO\n");
}
}
# possible encoding at the end of processing.
my $destination_buffer;
my $use_destination_buffer;
- if (
- ref($destination_stream)
- && ( ref($destination_stream) eq 'SCALAR'
- || ref($destination_stream) eq 'ARRAY' )
- )
- {
+ my $encode_destination_buffer;
+ my $ref_destination_stream = ref($destination_stream);
+ if ( $ref_destination_stream && !$user_formatter ) {
$use_destination_buffer = 1;
$output_file = \$destination_buffer;
+
+ # Strings and arrays use special encoding rules
+ if ( $ref_destination_stream eq 'SCALAR'
+ || $ref_destination_stream eq 'ARRAY' )
+ {
+ $encode_destination_buffer =
+ $rOpts->{'encode-output-strings'} && $decoded_input_as;
+ }
+
+ # An object with a print method will use file encoding rules
+ elsif ( $ref_destination_stream->can('print') ) {
+ $encode_destination_buffer = $is_encoded_data;
+ }
+ else {
+ confess <<EOM;
+------------------------------------------------------------------------
+No 'print' method is defined for object of class '$ref_destination_stream'
+Please check your call to Perl::Tidy::perltidy. Trace follows.
+------------------------------------------------------------------------
+EOM
+ }
}
$sink_object = Perl::Tidy::LineSink->new(
log_file => $log_file,
warning_file => $warning_file,
fh_stderr => $fh_stderr,
- saw_extruce => $saw_extrude,
display_name => $display_name,
is_encoded_data => $is_encoded_data,
);
foreach my $iter ( 1 .. $max_iterations ) {
+ $rstatus->{'iteration_count'} += 1;
+
# send output stream to temp buffers until last iteration
my $sink_buffer;
if ( $iter < $max_iterations ) {
{
if ( $formatter->get_convergence_check() ) {
$iteration_of_formatter_convergence = $iter;
+ $rstatus->{'converged'} = 1;
}
}
# with extreme parameter values, such as very short
# maximum line lengths. We want to catch and fix
# them when they happen.
+ $rstatus->{'blinking'} = 1;
$convergence_log_message = <<EOM;
BLINKER. Output for iteration $iter same as for $saw_md5{$digest}.
EOM
$diagnostics_object->write_diagnostics(
$convergence_log_message)
if $diagnostics_object && $iterm > 2;
+ $rstatus->{'converged'} = 1;
}
}
} ## end if ($do_convergence_test)
is_encoded_data => $is_encoded_data,
);
- my $buf =
+ my $buf_post =
$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);
+ my $digest_output = $md5_hex->($buf_post);
if ( $digest_output ne $digest_input ) {
my $diff_msg =
- compare_string_buffers( $saved_input_buf, $buf,
+ compare_string_buffers( $saved_input_buf, $buf_post,
$is_encoded_data );
$logger_object->warning(<<EOM);
assertion failure: '--assert-tidy' is set but output differs from input
}
}
if ( $rOpts->{'assert-untidy'} ) {
- my $digest_output = $md5_hex->($buf);
+ my $digest_output = $md5_hex->($buf_post);
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(
- input_file => \$buf,
+ input_file => \$buf_post,
rOpts => $rOpts,
rpending_logfile_message => $rpending_logfile_message,
);
# -eos flag set: If perltidy decodes a string, regardless of
# source, it encodes before returning.
+ $rstatus->{'output_encoded_as'} = EMPTY_STRING;
- if ( $rOpts->{'encode-output-strings'} && $decoded_input_as ) {
+ if ($encode_destination_buffer) {
my $encoded_buffer;
eval {
$encoded_buffer =
Encode::encode( "UTF-8", $destination_buffer,
Encode::FB_CROAK | Encode::LEAVE_SRC );
};
- if ($@) {
+ if ($EVAL_ERROR) {
Warn(
"Error attempting to encode output string ref; encoding not done\n"
}
else {
$destination_buffer = $encoded_buffer;
+ $rstatus->{'output_encoded_as'} = 'UTF-8';
}
}
- # Final string storage
+ # Send data for SCALAR, ARRAY & OBJ refs to its final destination
if ( ref($destination_stream) eq 'SCALAR' ) {
${$destination_stream} = $destination_buffer;
}
- else {
+ elsif ($destination_buffer) {
my @lines = split /^/, $destination_buffer;
- @{$destination_stream} = @lines;
+ if ( ref($destination_stream) eq 'ARRAY' ) {
+ @{$destination_stream} = @lines;
+ }
+
+ # destination stream must be an object with print method
+ else {
+ foreach my $line (@lines) {
+ $destination_stream->print($line);
+ }
+ if ( $ref_destination_stream->can('close') ) {
+ $destination_stream->close();
+ }
+ }
+ }
+ else {
+
+ # Empty destination buffer not going to a string ... could
+ # happen for example if user deleted all pod or comments
+ }
+ }
+ else {
+
+ # output went to a file ...
+ if ($is_encoded_data) {
+ $rstatus->{'output_encoded_as'} = 'UTF-8';
}
}
if ( -f $backup_name ) {
unlink($backup_name)
or Die(
-"unable to remove previous '$backup_name' for -b option; check permissions: $!\n"
+"unable to remove previous '$backup_name' for -b option; check permissions: $ERRNO\n"
);
}
# we use copy for symlinks, move for regular files
if ( -l $input_file ) {
File::Copy::copy( $input_file, $backup_name )
- or Die("File::Copy failed trying to backup source: $!");
+ or Die("File::Copy failed trying to backup source: $ERRNO");
}
else {
rename( $input_file, $backup_name )
or Die(
-"problem renaming $input_file to $backup_name for -b option: $!\n"
+"problem renaming $input_file to $backup_name for -b option: $ERRNO\n"
);
}
$ifname = $backup_name;
# handle of an open nameless temporary file so we would lose
# everything if we closed it.
seek( $output_file, 0, 0 )
- or Die("unable to rewind a temporary file for -b option: $!\n");
+ or
+ Die("unable to rewind a temporary file for -b option: $ERRNO\n");
my ( $fout, $iname ) =
Perl::Tidy::streamhandle( $input_file, 'w', $is_encoded_data );
if ( !$fout ) {
Die(
-"problem re-opening $input_file for write for -b option; check file and directory permissions: $!\n"
+"problem re-opening $input_file for write for -b option; check file and directory permissions: $ERRNO\n"
);
}
else {
unlink($ifname)
or Die(
-"unable to remove previous '$ifname' for -b option; check permissions: $!\n"
+"unable to remove previous '$ifname' for -b option; check permissions: $ERRNO\n"
);
}
}
NORMAL_EXIT:
my $ret = $Warn_count ? 2 : 0;
- return $ret;
+ return wantarray ? ( $ret, $rstatus ) : $ret;
ERROR_EXIT:
- return 1;
-} ## end of main program perltidy
+ return wantarray ? ( 1, $rstatus ) : 1;
+
+} ## end sub perltidy
} ## end of closure for sub perltidy
sub line_diff {
# have same common characters so non-null characters indicate character
# differences.
my ( $s1, $s2 ) = @_;
- my $diff_marker = "";
+ my $diff_marker = EMPTY_STRING;
my $pos = -1;
my $pos1 = $pos;
if ( defined($s1) && defined($s2) ) {
while ( $mask =~ /[^\0]/g ) {
$count++;
my $pos_last = $pos;
- $pos = $-[0];
+ $pos = $LAST_MATCH_START[0];
if ( $count == 1 ) { $pos1 = $pos; }
- $diff_marker .= ' ' x ( $pos - $pos_last - 1 ) . '^';
+ $diff_marker .= SPACE x ( $pos - $pos_last - 1 ) . '^';
# we could continue to mark all differences, but there is no point
last;
}
}
return wantarray ? ( $diff_marker, $pos1 ) : $diff_marker;
-}
+} ## end sub line_diff
sub compare_string_buffers {
my ( $fhi, $fnamei ) = streamhandle( \$bufi, 'r', $is_encoded_data );
my ( $fho, $fnameo ) = streamhandle( \$bufo, 'r', $is_encoded_data );
return $msg unless ( $fho && $fhi ); # for safety, shouldn't happen
- my ( $linei, $lineo );
- my ( $counti, $counto ) = ( 0, 0 );
- my ( $last_nonblank_line, $last_nonblank_count ) = ( "", 0 );
+ my ( $linei, $lineo );
+ my ( $counti, $counto ) = ( 0, 0 );
+ my ( $last_nonblank_line, $last_nonblank_count ) = ( EMPTY_STRING, 0 );
my $truncate = sub {
my ( $str, $lenmax ) = @_;
if ( length($str) > $lenmax ) {
my ( $line_diff, $pos1 ) = line_diff( $linei, $lineo );
my $reason = "Files first differ at character $pos1 of line $counti";
- my ( $leading_ws_i, $leading_ws_o ) = ( "", "" );
+ my ( $leading_ws_i, $leading_ws_o ) = ( EMPTY_STRING, EMPTY_STRING );
if ( $linei =~ /^(\s+)/ ) { $leading_ws_i = $1; }
if ( $lineo =~ /^(\s+)/ ) { $leading_ws_o = $1; }
if ( $leading_ws_i ne $leading_ws_o ) {
}
}
else {
- my ( $trailing_ws_i, $trailing_ws_o ) = ( "", "" );
+ my ( $trailing_ws_i, $trailing_ws_o ) =
+ ( EMPTY_STRING, EMPTY_STRING );
if ( $linei =~ /(\s+)$/ ) { $trailing_ws_i = $1; }
if ( $lineo =~ /(\s+)$/ ) { $trailing_ws_o = $1; }
if ( $trailing_ws_i ne $trailing_ws_o ) {
# limit string display length
if ( $pos1 > 60 ) {
my $drop = $pos1 - 40;
- $linei = "..." . substr( $linei, $drop );
- $lineo = "..." . substr( $lineo, $drop );
- $line_diff = " " . substr( $line_diff, $drop );
+ $linei = "..." . substr( $linei, $drop );
+ $lineo = "..." . substr( $lineo, $drop );
+ $line_diff = SPACE x 3 . substr( $line_diff, $drop );
}
$linei = $truncate->( $linei, 72 );
$lineo = $truncate->( $lineo, 72 );
$last_nonblank_count:$last_nonblank_line
EOM
}
- $line_diff = ' ' x ( 2 + length($counto) ) . $line_diff;
+ $line_diff = SPACE x ( 2 + length($counto) ) . $line_diff;
$msg .= <<EOM;
<$counti:$linei
>$counto:$lineo
EOM
}
return $msg;
-}
+} ## end sub compare_string_buffers
sub get_stream_as_named_file {
}
}
return ( $fname, $is_tmpfile );
-}
+} ## end sub get_stream_as_named_file
sub fileglob_to_re {
$extension = $dot . $extension;
}
return $extension;
-}
+} ## end sub make_extension
sub write_logfile_header {
my (
$rOpts, $logger_object, $config_file,
$rraw_options, $Windows_type, $readable_options
) = @_;
+
+ # Note: the punctuation variable '$]' is not in older versions of
+ # English.pm so leave it as is to avoid failing installation tests.
$logger_object->write_logfile_entry(
-"perltidy version $VERSION log file on a $^O system, OLD_PERL_VERSION=$]\n"
+"perltidy version $VERSION log file on a $OSNAME system, OLD_PERL_VERSION=$]\n"
);
if ($Windows_type) {
$logger_object->write_logfile_entry("Windows type is $Windows_type\n");
}
- my $options_string = join( ' ', @{$rraw_options} );
+ my $options_string = join( SPACE, @{$rraw_options} );
if ($config_file) {
$logger_object->write_logfile_entry(
$logger_object->write_logfile_entry(
"To find error messages search for 'WARNING' with your editor\n");
return;
-}
+} ## end sub write_logfile_header
sub generate_options {
$add_option->( 'brace-left-exclusion-list', 'blxl', '=s' );
$add_option->( 'break-after-labels', 'bal', '=i' );
- ## This was an experiment mentioned in git #78. It works, but it does not
- ## look very useful. Instead, I expanded the functionality of the
- ## --keep-old-breakpoint-xxx flags.
- ##$add_option->( 'break-open-paren-list', 'bopl', '=s' );
+ # This was an experiment mentioned in git #78, originally named -bopl. I
+ # expanded it to also open logical blocks, based on git discussion #100,
+ # and renamed it -bocp. It works, but will remain commented out due to
+ # apparent lack of interest.
+ # $add_option->( 'break-open-compact-parens', 'bocp', '=s' );
########################################
$category = 6; # Controlling list formatting
$add_option->( 'dump-want-left-space', 'dwls', '!' );
$add_option->( 'dump-want-right-space', 'dwrs', '!' );
$add_option->( 'fuzzy-line-length', 'fll', '!' );
- $add_option->( 'help', 'h', '' );
+ $add_option->( 'help', 'h', EMPTY_STRING );
$add_option->( 'short-concatenation-item-length', 'scl', '=i' );
$add_option->( 'show-options', 'opt', '!' );
$add_option->( 'timestamp', 'ts', '!' );
- $add_option->( 'version', 'v', '' );
+ $add_option->( 'version', 'v', EMPTY_STRING );
$add_option->( 'memoize', 'mem', '!' );
$add_option->( 'file-size-order', 'fso', '!' );
$add_option->( 'maximum-file-size-mb', 'maxfs', '=i' );
delete-old-newlines
delete-semicolons
extended-syntax
+ encode-output-strings
function-paren-vertical-alignment
fuzzy-line-length
hanging-side-comments
\%option_category, \%option_range
);
-} ## end of generate_options
+} ## end sub generate_options
# Memoize process_command_line. Given same @ARGV passed in, return same
# values and same @ARGV back.
else {
return _process_command_line(@q);
}
-}
+} ## end sub process_command_line
# (note the underscore here)
sub _process_command_line {
# Previous configuration is reset at the exit of this routine.
my $glc;
eval { $glc = Getopt::Long::Configure() };
- unless ($@) {
+ unless ($EVAL_ERROR) {
eval { Getopt::Long::ConfigDefaults() };
}
else { $glc = undef }
my $word;
my @raw_options = ();
- my $config_file = "";
+ my $config_file = EMPTY_STRING;
my $saw_ignore_profile = 0;
my $saw_dump_profile = 0;
}
}
unless ( -e $config_file ) {
- Warn("cannot find file given with -pro=$config_file: $!\n");
- $config_file = "";
+ Warn("cannot find file given with -pro=$config_file: $ERRNO\n");
+ $config_file = EMPTY_STRING;
}
}
elsif ( $i =~ /^-(pro|profile)=?$/ ) {
# look for a config file if we don't have one yet
my $rconfig_file_chatter;
- ${$rconfig_file_chatter} = "";
+ ${$rconfig_file_chatter} = EMPTY_STRING;
$config_file =
find_config_file( $is_Windows, $Windows_type, $rconfig_file_chatter,
$rpending_complaint )
return ( \%Opts, $config_file, \@raw_options, $roption_string,
$rexpansion, $roption_category, $roption_range );
-} ## end of _process_command_line
+} ## end sub _process_command_line
sub make_grep_alias_string {
my ($rOpts) = @_;
# Defaults: list operators in List::Util
# Possible future additions: pairfirst pairgrep pairmap
- my $default_string = join ' ', qw(
+ my $default_string = join SPACE, qw(
all
any
first
}
# The special option -gaxl='*' removes all defaults
- if ( $is_excluded_word{'*'} ) { $default_string = "" }
+ if ( $is_excluded_word{'*'} ) { $default_string = EMPTY_STRING }
# combine the defaults and any input list
my $input_string = $rOpts->{'grep-alias-list'};
- if ($input_string) { $input_string .= " " . $default_string }
+ if ($input_string) { $input_string .= SPACE . $default_string }
else { $input_string = $default_string }
# Now make the final list of unique grep alias words
}
}
}
- my $joined_words = join ' ', @filtered_word_list;
+ my $joined_words = join SPACE, @filtered_word_list;
$rOpts->{'grep-alias-list'} = $joined_words;
return;
-}
+} ## end sub make_grep_alias_string
sub check_options {
}
# entab leading whitespace has priority over the older 'tabs' option
- if ( $rOpts->{'tabs'} ) { $rOpts->{'tabs'} = 0; }
+ if ( $rOpts->{'tabs'} ) {
+
+ # The following warning could be added but would annoy a lot of
+ # users who have a perltidyrc with both -t and -et=n. So instead
+ # there is a note in the manual that -et overrides -t.
+ ##Warn("-tabs and -et=n conflict; ignoring -tabs\n");
+ $rOpts->{'tabs'} = 0;
+ }
}
# set a default tabsize to be used in guessing the starting indentation
}
}
}
- $rOpts->{'sub-alias-list'} = join ' ', @filtered_word_list;
+ $rOpts->{'sub-alias-list'} = join SPACE, @filtered_word_list;
}
make_grep_alias_string($rOpts);
: $rOpts->{'tabs'} ? $rOpts->{'indent-columns'}
: $rOpts->{'default-tabsize'};
return $tabsize;
-}
+} ## end sub check_options
sub find_file_upwards {
my ( $search_dir, $search_file ) = @_;
# This return is for Perl-Critic.
# We shouldn't get out of the while loop without a return
return;
-}
+} ## end sub find_file_upwards
sub expand_command_abbreviations {
# 10 should be plenty, but it may be increased to allow deeply
# nested expansions.
my $max_passes = 10;
- my @new_argv = ();
# keep looping until all expansions have been converted into actual
# dash parameters..
# to allow abbreviations with arguments such as '-vt=1'
if ( $rexpansion->{ $abr . $flags } ) {
$abr = $abr . $flags;
- $flags = "";
+ $flags = EMPTY_STRING;
}
# if we see this dash item in the expansion hash..
# make sure we are not in an infinite loop
if ( $pass_count == $max_passes ) {
- local $" = ')(';
+ local $LIST_SEPARATOR = ')(';
Warn(<<EOM);
I'm tired. We seem to be in an infinite loop trying to expand aliases.
Here are the raw options;
} ## end of check for circular references
} ## end of loop over all passes
return;
-}
+} ## end sub expand_command_abbreviations
# Debug routine -- this will dump the expansion hash
sub dump_short_names {
For a list of all long names, use perltidy --dump-long-names (-dln).
--------------------------------------------------------------------------
EOM
- foreach my $abbrev ( sort keys %$rexpansion ) {
+ foreach my $abbrev ( sort keys %{$rexpansion} ) {
my @list = @{ $rexpansion->{$abbrev} };
print STDOUT "$abbrev --> @list\n";
}
return;
-}
+} ## end sub dump_short_names
sub check_vms_filename {
\.-?\d*$ # match . version number
/$1/x;
- # normalise filename, if there are no unescaped dots then append one
+ # normalize filename, if there are no unescaped dots then append one
$base .= '.' unless $base =~ /(?:^|[^^])\./;
# if we don't already have an extension then we just append the extension
- my $separator = ( $base =~ /\.$/ ) ? "" : "_";
+ my $separator = ( $base =~ /\.$/ ) ? EMPTY_STRING : "_";
return ( $path . $base, $separator );
-}
+} ## end sub check_vms_filename
sub Win_OS_Type {
# We need to know this to decide where to look for config files
my $rpending_complaint = shift;
- my $os = "";
- return $os unless $^O =~ /win32|dos/i; # is it a MS box?
+ my $os = EMPTY_STRING;
+ return $os unless $OSNAME =~ /win32|dos/i; # is it a MS box?
# Systems built from Perl source may not have Win32.pm
# But probably have Win32::GetOSVersion() anyway so the
# If $os is undefined, the above code is out of date. Suggested updates
# are welcome.
unless ( defined $os ) {
- $os = "";
+ $os = EMPTY_STRING;
# Deactivated this message 20180322 because it was needlessly
# causing some test scripts to fail. Need help from someone
# Unfortunately the logic used for the various versions isn't so clever..
# so we have to handle an outside case.
return ( $os eq "2000" && $major != 5 ) ? "NT4" : $os;
-}
+} ## end sub Win_OS_Type
sub is_unix {
return
- ( $^O !~ /win32|dos/i )
- && ( $^O ne 'VMS' )
- && ( $^O ne 'OS2' )
- && ( $^O ne 'MacOS' );
+ ( $OSNAME !~ /win32|dos/i )
+ && ( $OSNAME ne 'VMS' )
+ && ( $OSNAME ne 'OS2' )
+ && ( $OSNAME ne 'MacOS' );
}
sub look_for_Windows {
# determine Windows sub-type and location of
# system-wide configuration files
my $rpending_complaint = shift;
- my $is_Windows = ( $^O =~ /win32|dos/i );
+ my $is_Windows = ( $OSNAME =~ /win32|dos/i );
my $Windows_type;
$Windows_type = Win_OS_Type($rpending_complaint) if $is_Windows;
return ( $is_Windows, $Windows_type );
-}
+} ## end sub look_for_Windows
sub find_config_file {
${$rconfig_file_chatter} .= "Windows $Windows_type\n";
}
else {
- ${$rconfig_file_chatter} .= " $^O\n";
+ ${$rconfig_file_chatter} .= " $OSNAME\n";
}
# sub to check file existence and record all tests
# Check the NT/2k/XP locations, first a local machine def, then a
# network def
- push @envs, qw(USERPROFILE HOMESHARE) if $^O =~ /win32/i;
+ push @envs, qw(USERPROFILE HOMESHARE) if $OSNAME =~ /win32/i;
# Now go through the environment ...
foreach my $var (@envs) {
}
# Place to add customization code for other systems
- elsif ( $^O eq 'OS2' ) {
+ elsif ( $OSNAME eq 'OS2' ) {
}
- elsif ( $^O eq 'MacOS' ) {
+ elsif ( $OSNAME eq 'MacOS' ) {
}
- elsif ( $^O eq 'VMS' ) {
+ elsif ( $OSNAME eq 'VMS' ) {
}
# Assume some kind of Unix
# Couldn't find a config file
return;
-}
+} ## end sub find_config_file
sub Win_Config_Locs {
return unless $os;
- my $system = "";
- my $allusers = "";
+ my $system = EMPTY_STRING;
+ my $allusers = EMPTY_STRING;
if ( $os =~ /9[58]|Me/ ) {
$system = "C:/Windows";
return;
}
return wantarray ? ( $os, $system, $allusers ) : $os;
-}
+} ## end sub Win_Config_Locs
sub dump_config_file {
my ( $fh, $config_file, $rconfig_file_chatter ) = @_;
print STDOUT "# ...no config file found\n";
}
return;
-}
+} ## end sub dump_config_file
sub read_config_file {
my @config_list = ();
# file is bad if non-empty $death_message is returned
- my $death_message = "";
+ my $death_message = EMPTY_STRING;
my $name = undef;
my $line_no;
$opening_brace_line = $line_no unless ( $body && $body =~ s/\}$// );
# handle a new alias definition
- if ( ${$rexpansion}{$name} ) {
- local $" = ')(';
- my @names = sort keys %$rexpansion;
+ if ( $rexpansion->{$name} ) {
+ local $LIST_SEPARATOR = ')(';
+ my @names = sort keys %{$rexpansion};
$death_message =
"Here is a list of all installed aliases\n(@names)\n"
- . "Attempting to redefine alias ($name) in config file $config_file line $.\n";
+ . "Attempting to redefine alias ($name) in config file $config_file line $INPUT_LINE_NUMBER\n";
last;
}
- ${$rexpansion}{$name} = [];
+ $rexpansion->{$name} = [];
}
# leading opening braces not allowed
# remove leading dashes if this is an alias
foreach ( @{$rbody_parts} ) { s/^\-+//; }
- push @{ ${$rexpansion}{$name} }, @{$rbody_parts};
+ push @{ $rexpansion->{$name} }, @{$rbody_parts};
}
else {
push( @config_list, @{$rbody_parts} );
}
eval { $fh->close() };
return ( \@config_list, $death_message );
-}
+} ## end sub read_config_file
sub strip_comment {
# Strip any comment from a command line
my ( $instr, $config_file, $line_no ) = @_;
- my $msg = "";
+ my $msg = EMPTY_STRING;
# check for full-line comment
if ( $instr =~ /^\s*#/ ) {
- return ( "", $msg );
+ return ( EMPTY_STRING, $msg );
}
# nothing to do if no comments
}
# handle comments and quotes
- my $outstr = "";
- my $quote_char = "";
+ my $outstr = EMPTY_STRING;
+ my $quote_char = EMPTY_STRING;
while (1) {
# looking for ending quote character
if ($quote_char) {
if ( $instr =~ /\G($quote_char)/gc ) {
- $quote_char = "";
+ $quote_char = EMPTY_STRING;
$outstr .= $1;
}
elsif ( $instr =~ /\G(.)/gc ) {
}
}
return ( $outstr, $msg );
-}
+} ## end sub strip_comment
sub parse_args {
my ($body) = @_;
my @body_parts = ();
- my $quote_char = "";
- my $part = "";
- my $msg = "";
+ my $quote_char = EMPTY_STRING;
+ my $part = EMPTY_STRING;
+ my $msg = EMPTY_STRING;
+
+ # Check for external call with undefined $body - added to fix
+ # github issue Perl-Tidy-Sweetened issue #23
+ if ( !defined($body) ) { $body = EMPTY_STRING }
+
while (1) {
# looking for ending quote character
if ($quote_char) {
if ( $body =~ /\G($quote_char)/gc ) {
- $quote_char = "";
+ $quote_char = EMPTY_STRING;
}
elsif ( $body =~ /\G(.)/gc ) {
$part .= $1;
}
elsif ( $body =~ /\G(\s+)/gc ) {
if ( length($part) ) { push @body_parts, $part; }
- $part = "";
+ $part = EMPTY_STRING;
}
elsif ( $body =~ /\G(.)/gc ) {
$part .= $1;
}
}
return ( \@body_parts, $msg );
-}
+} ## end sub parse_args
sub dump_long_names {
foreach my $name ( sort @names ) { print STDOUT "$name\n" }
return;
-}
+} ## end sub dump_long_names
sub dump_defaults {
my @defaults = @_;
$readable_options .=
"# See utility 'perltidyrc_dump.pl' for nicer formatting.\n";
foreach my $opt ( @{$roption_string} ) {
- my $flag = "";
+ my $flag = EMPTY_STRING;
if ( $opt =~ /(.*)(!|=.*)$/ ) {
$opt = $1;
$flag = $2;
my $flag = $rGetopt_flags->{$key};
my $value = $rOpts->{$key};
my $prefix = '--';
- my $suffix = "";
+ my $suffix = EMPTY_STRING;
if ($flag) {
if ( $flag =~ /^=/ ) {
if ( $value !~ /^\d+$/ ) { $value = '"' . $value . '"' }
$readable_options .= $prefix . $key . $suffix . "\n";
}
return $readable_options;
-}
+} ## end sub readable_options
sub show_version {
print STDOUT <<"EOM";
or on the internet at http://perltidy.sourceforge.net.
EOM
return;
-}
+} ## end sub show_version
sub usage {
EOF
return;
-}
+} ## end sub usage
sub process_this_file {
if $formatter->can('finish_formatting');
return;
-}
+} ## end sub process_this_file
1;
+
=head1 NAME
Perl::Tidy - Parses and beautifies perl source
The call to B<perltidy> returns a scalar B<$error_flag> which is TRUE if an
error caused premature termination, and FALSE if the process ran to normal
-completion. Additional discuss of errors is contained below in the L<ERROR
-HANDLING> section.
+completion. Additional discuss of errors is contained below in the
+L<ERROR HANDLING|"ERROR HANDLING"> section.
The module accepts input and output streams by a variety of methods.
The following list of parameters may be any of the following: a
of two possible states, decoded or encoded, and it is important that the
calling program and Perl::Tidy are in agreement regarding the state to be
returned. A flag B<--encode-output-strings>, or simply B<-eos>, was added in
-versions of Perl::Tidy after 20220101 for this purpose. This flag should be
-added to the end of the B<argv> paremeter (described below) if Perl::Tidy
-will be decoding utf8 text. The options are as follows.
+Perl::Tidy version 20220217 for this purpose.
=over 4
=item *
-Use B<-eos> if Perl::Tidy should encode any string which it decodes.
-This is probably most convenient for most programs.
-But do not use this setting if the calling program will
-encode the data too, because double encoding will corrupt data.
+Use B<-eos> if Perl::Tidy should encode any string which it decodes. This is
+the current default because it makes perltidy behave well as a filter, and is
+the correct setting for most programs. But do not use this setting if the
+calling program will encode the data too, because double encoding will corrupt
+data.
=item *
Use B<-neos> if a string should remain decoded if it was decoded by Perl::Tidy.
-This is appropriate if
-the calling program will handle any needed encoding before outputting the string.
+This is only appropriate if the calling program will handle any needed encoding
+before outputting the string. If needed, this flag can be added to the end of
+the B<argv> parameter passed to Perl::Tidy.
-=item *
+=back
-The current default is B<-neos>, but B<the default could change in a future
-version>, so B<-neos> should still be set, if appropriate, to allow for the
-possibility of a future change in the default.
+For some background information see
+L<https://github.com/perltidy/perltidy/blob/master/docs/eos_flag.md>.
-=back
+This change in default behavior was made over a period of time as follows:
-For example, to set B<-eos> the following could be used
+=over 4
- $argv .= " -eos" if ( $Perl::Tidy::VERSION > 20220101 );
+=item *
- $error_flag = Perl::Tidy::perltidy(
- argv => $argv,
- source => \$source,
- destination => \$destination,
- stderr => \$stderr,
- errorfile => \$errorfile
- );
+For versions before 20220217 the B<-eos> flag was not available and the behavior was equivalent to B<-neos>.
-The test on version allows older versions of Perl::Tidy to still be used.
+=item *
-For some background information see
-L<https://github.com/perltidy/perltidy/issues/83> and
-L<https://github.com/houseabsolute/perl-code-tidyall/issues/84>.
+In version 20220217 the B<-eos> flag was added but the default remained B<-neos>.
+
+=item *
+
+For versions after 20220217 the default was set to B<-eos>.
+
+=back
=item B<stderr>
being sought. If so, the above write_line prints the token and its
line number.
-The B<formatter> feature is relatively new in perltidy, and further
-documentation needs to be written to complete its description. However,
-several example programs have been written and can be found in the
-B<examples> section of the source distribution. Probably the best way
-to get started is to find one of the examples which most closely matches
-your application and start modifying it.
+The B<examples> section of the source distribution has some examples of programs which use the B<formatter> option.
For help with perltidy's peculiar way of breaking lines into tokens, you
might run, from the command line,
F<filename.DEBUG> with interleaved lines of text and their token types.
The B<-D> flag has been in perltidy from the beginning for this purpose.
If you want to see the code which creates this file, it is
-C<write_debug_entry> in Tidy.pm.
+C<sub Perl::Tidy::Debugger::write_debug_entry>
=head1 EXPORT
=head1 VERSION
-This man page documents Perl::Tidy version 20220217
+This man page documents Perl::Tidy version 20220613
=head1 LICENSE
=head1 BUG REPORTS
-A list of current bugs and issues can be found at the CPAN site L<https://rt.cpan.org/Public/Dist/Display.html?Name=Perl-Tidy>
-
-To report a new bug or problem, use the link on this page.
-
The source code repository is at L<https://github.com/perltidy/perltidy>.
+To report a new bug or problem, use the "issues" link on this page.
+
=head1 SEE ALSO
The perltidy(1) man page describes all of the features of perltidy. It
package Perl::Tidy::Debugger;
use strict;
use warnings;
-our $VERSION = '20220217';
+use English qw( -no_match_vars );
+our $VERSION = '20220613';
+
+use constant EMPTY_STRING => q{};
+use constant SPACE => q{ };
sub new {
my ( $fh, $filename ) =
Perl::Tidy::streamhandle( $debug_file, 'w', $is_encoded_data );
if ( !$fh ) {
- Perl::Tidy::Warn("can't open $debug_file: $!\n");
+ Perl::Tidy::Warn("can't open $debug_file: $ERRNO\n");
}
$self->{_debug_file_opened} = 1;
$self->{_fh} = $fh;
my $rtoken_type = $line_of_tokens->{_rtoken_type};
my $rtokens = $line_of_tokens->{_rtokens};
my $rlevels = $line_of_tokens->{_rlevels};
- my $rslevels = $line_of_tokens->{_rslevels};
my $rblock_type = $line_of_tokens->{_rblock_type};
my $input_line_number = $line_of_tokens->{_line_number};
my $reconstructed_original = "$input_line_number: ";
my $block_str = "$input_line_number: ";
- my $pattern = "";
+ my $pattern = EMPTY_STRING;
my @next_char = ( '"', '"' );
my $i_next = 0;
unless ( $self->{_debug_file_opened} ) { $self->really_open_debug_file() }
# be sure there are no blank tokens (shouldn't happen)
# This can only happen if a programming error has been made
# because all valid tokens are non-blank
- if ( $type_str eq ' ' ) {
+ if ( $type_str eq SPACE ) {
$fh->print("BLANK TOKEN on the next line\n");
$type_str = $next_char[$i_next];
$i_next = 1 - $i_next;
package Perl::Tidy::DevNull;
use strict;
use warnings;
-our $VERSION = '20220217';
+our $VERSION = '20220613';
sub new { my $self = shift; return bless {}, $self }
sub print { return }
sub close { return }
package Perl::Tidy::Diagnostics;
use strict;
use warnings;
-our $VERSION = '20220217';
+use English qw( -no_match_vars );
+our $VERSION = '20220613';
+
+use constant EMPTY_STRING => q{};
sub AUTOLOAD {
my $class = shift;
return bless {
_write_diagnostics_count => 0,
- _last_diagnostic_file => "",
- _input_file => "",
+ _last_diagnostic_file => EMPTY_STRING,
+ _input_file => EMPTY_STRING,
_fh => undef,
}, $class;
}
unless ( $self->{_write_diagnostics_count} ) {
open( $self->{_fh}, ">", "DIAGNOSTICS" )
- or Perl::Tidy::Die("couldn't open DIAGNOSTICS: $!\n");
+ or Perl::Tidy::Die("couldn't open DIAGNOSTICS: $ERRNO\n");
}
my $fh = $self->{_fh};
package Perl::Tidy::FileWriter;
use strict;
use warnings;
-our $VERSION = '20220217';
+our $VERSION = '20220613';
-use constant DEVEL_MODE => 0;
+use constant DEVEL_MODE => 0;
+use constant EMPTY_STRING => q{};
sub AUTOLOAD {
# required to avoid call to AUTOLOAD in some versions of perl
}
-my $input_stream_name = "";
+my $input_stream_name = EMPTY_STRING;
# Maximum number of little messages; probably need not be changed.
-my $MAX_NAG_MESSAGES = 6;
+use constant MAX_NAG_MESSAGES => 6;
BEGIN {
$self->[_max_output_line_length_at_] = 0;
$self->[_rK_checklist_] = [];
$self->[_K_arrival_order_matches_] = 0;
- $self->[_K_sequence_error_msg_] = "";
+ $self->[_K_sequence_error_msg_] = EMPTY_STRING;
$self->[_K_last_arrival_] = -1;
# save input stream name for local error messages
- $input_stream_name = "";
+ $input_stream_name = EMPTY_STRING;
if ($logger_object) {
$input_stream_name = $logger_object->get_input_stream_name();
}
$self->[_rK_checklist_] = \@list;
}
$self->[_K_arrival_order_matches_] = 1;
- $self->[_K_sequence_error_msg_] = "";
+ $self->[_K_sequence_error_msg_] = EMPTY_STRING;
$self->[_K_last_arrival_] = -1;
return;
}
return;
}
+use constant MAX_PRINTED_CHARS => 80;
+
sub write_code_line {
my ( $self, $str, $K ) = @_;
my $K_prev = $self->[_K_last_arrival_];
if ( $K < $K_prev ) {
chomp $str;
- if ( length($str) > 80 ) {
- $str = substr( $str, 0, 80 ) . "...";
+ if ( length($str) > MAX_PRINTED_CHARS ) {
+ $str = substr( $str, 0, MAX_PRINTED_CHARS ) . "...";
}
my $msg = <<EOM;
$self->[_max_line_length_error_at_] = $output_line_number - 1;
}
- if ( $self->[_line_length_error_count_] < $MAX_NAG_MESSAGES ) {
+ if ( $self->[_line_length_error_count_] < MAX_NAG_MESSAGES ) {
$self->write_logfile_entry(
"Line length exceeded by $exceed characters\n");
}
}
else {
- my $word = ( $line_length_error_count > 1 ) ? "s" : "";
+ my $word = ( $line_length_error_count > 1 ) ? "s" : EMPTY_STRING;
$self->write_logfile_entry(
"$line_length_error_count output line$word exceeded $rOpts->{'maximum-line-length'} characters:\n"
);
- $word = ( $line_length_error_count > 1 ) ? "First" : "";
+ $word = ( $line_length_error_count > 1 ) ? "First" : EMPTY_STRING;
my $first_line_length_error = $self->[_first_line_length_error_];
my $first_line_length_error_at = $self->[_first_line_length_error_at_];
$self->write_logfile_entry(
# sub set_forced_breakpoint
# CODE SECTION 9: Process batches of code
# sub grind_batch_of_CODE
-# CODE SECTION 10: Code to break long statments
+# CODE SECTION 10: Code to break long statements
# sub break_long_lines
# CODE SECTION 11: Code to break long lists
# sub break_lists
use strict;
use warnings;
-# This flag gets switched on during automated testing for extra checking
-use constant DEVEL_MODE => 0;
+# DEVEL_MODE gets switched on during automated testing for extra checking
+use constant DEVEL_MODE => 0;
+use constant EMPTY_STRING => q{};
+use constant SPACE => q{ };
{ #<<< A non-indenting brace to contain all lexical variables
use Carp;
-our $VERSION = '20220217';
+use English qw( -no_match_vars );
+our $VERSION = '20220613';
# The Tokenizer will be loaded with the Formatter
##use Perl::Tidy::Tokenizer; # for is_keyword()
======================================================================
EOM
exit 1;
-}
+} ## end sub AUTOLOAD
sub DESTROY {
my $self = shift;
# We shouldn't get here, but this return is to keep Perl-Critic from
# complaining.
return;
-}
+} ## end sub Fault
sub Exit {
my ($msg) = @_;
$rOpts_break_at_old_logical_breakpoints,
$rOpts_break_at_old_semicolon_breakpoints,
$rOpts_break_at_old_ternary_breakpoints,
- $rOpts_break_open_paren_list,
+ $rOpts_break_open_compact_parens,
$rOpts_closing_side_comments,
$rOpts_closing_side_comment_else_flag,
$rOpts_closing_side_comment_maximum_text,
%is_if_unless_while_until_for_foreach,
%is_last_next_redo_return,
%is_if_unless,
+ %is_if_elsif,
+ %is_if_unless_elsif,
+ %is_if_unless_elsif_else,
+ %is_elsif_else,
%is_and_or,
%is_chain_operator,
%is_block_without_semicolon,
%is_closing_type,
%is_opening_token,
%is_closing_token,
+ %is_ternary,
%is_equal_or_fat_comma,
%is_counted_type,
%is_opening_sequence_token,
%is_closing_sequence_token,
%is_container_label_type,
+ %is_die_confess_croak_warn,
+ %is_my_our_local,
@all_operators,
# Initialized in check_options. These are constants and could
# just as well be initialized in a BEGIN block.
%is_do_follower,
- %is_if_brace_follower,
- %is_else_brace_follower,
%is_anon_sub_brace_follower,
%is_anon_sub_1_brace_follower,
%is_other_brace_follower,
# Initialized in sub prepare_cuddled_block_types
$rcuddled_block_types,
- # Initialized and configured in check_optioms
+ # Initialized and configured in check_options
%outdent_keyword,
%keyword_paren_inner_tightness,
$max_index_to_go,
@block_type_to_go,
@type_sequence_to_go,
- @bond_strength_to_go,
@forced_breakpoint_to_go,
@token_lengths_to_go,
@summed_lengths_to_go,
@levels_to_go,
@leading_spaces_to_go,
@reduced_spaces_to_go,
- @standard_spaces_to_go,
@mate_index_to_go,
@ci_levels_to_go,
@nesting_depth_to_go,
@iprev_to_go,
@parent_seqno_to_go,
+ # forced breakpoint variables associated with each batch of code
+ $forced_breakpoint_count,
+ $forced_breakpoint_undo_count,
+ $index_max_forced_break,
);
BEGIN {
_roverride_cab3_ => $i++,
_ris_assigned_structure_ => $i++,
+ _rseqno_non_indenting_brace_by_ix_ => $i++,
+ _rreduce_vertical_tightness_by_seqno_ => $i++,
+
_LAST_SELF_INDEX_ => $i - 1,
};
}
_ri_last_ => $i++,
_do_not_pad_ => $i++,
_peak_batch_size_ => $i++,
- _max_index_to_go_ => $i++,
_batch_count_ => $i++,
_rix_seqno_controlling_ci_ => $i++,
_batch_CODE_type_ => $i++,
use constant WS_NO => -1;
# Token bond strengths.
- use constant NO_BREAK => 10000;
+ use constant NO_BREAK => 10_000;
use constant VERY_STRONG => 100;
use constant STRONG => 2.1;
use constant NOMINAL => 1.1;
# Map related block names into a common name to allow vertical alignment
# used by sub make_alignment_patterns. Note: this is normally unchanged,
- # but it contains 'grep' and can be re-initized in
+ # but it contains 'grep' and can be re-initialized in
# sub initialize_grep_and_friends in a testing mode.
%block_type_map = (
'unless' => 'if',
@q = qw(if unless);
@is_if_unless{@q} = (1) x scalar(@q);
+ @q = qw(if elsif);
+ @is_if_elsif{@q} = (1) x scalar(@q);
+
+ @q = qw(if unless elsif);
+ @is_if_unless_elsif{@q} = (1) x scalar(@q);
+
+ @q = qw(if unless elsif else);
+ @is_if_unless_elsif_else{@q} = (1) x scalar(@q);
+
+ @q = qw(elsif else);
+ @is_elsif_else{@q} = (1) x scalar(@q);
+
@q = qw(and or err);
@is_and_or{@q} = (1) x scalar(@q);
@q = qw< } ) ] >;
@is_closing_token{@q} = (1) x scalar(@q);
+ @q = qw( ? : );
+ @is_ternary{@q} = (1) x scalar(@q);
+
@q = qw< { ( [ ? >;
@is_opening_sequence_token{@q} = (1) x scalar(@q);
@q = qw( k => && || ? : . );
@is_container_label_type{@q} = (1) x scalar(@q);
+ @q = qw( die confess croak warn );
+ @is_die_confess_croak_warn{@q} = (1) x scalar(@q);
+
+ @q = qw( my our local );
+ @is_my_our_local{@q} = (1) x scalar(@q);
+
# Braces -bbht etc must follow these. Note: experimentation with
# including a simple comma shows that it adds little and can lead
# to poor formatting in complex lists.
diagnostics_object => undef,
logger_object => undef,
length_function => sub { return length( $_[0] ) },
- is_encoded_data => "",
+ is_encoded_data => EMPTY_STRING,
fh_tee => undef,
);
my %args = ( %defaults, @args );
initialize_final_indentation_adjustment();
initialize_postponed_breakpoint();
initialize_batch_variables();
- initialize_forced_breakpoint_vars();
initialize_write_line();
my $vertical_aligner_object = Perl::Tidy::VerticalAligner->new(
$self->[_roverride_cab3_] = {};
$self->[_ris_assigned_structure_] = {};
+ $self->[_rseqno_non_indenting_brace_by_ix_] = {};
+ $self->[_rreduce_vertical_tightness_by_seqno_] = {};
+
# This flag will be updated later by a call to get_save_logfile()
$self->[_save_logfile_] = defined($logger_object);
"Attempt to create more than 1 object in $class, which is not a true class yet\n";
}
return $self;
-}
+} ## end sub new
######################################
# CODE SECTION 2: Some Basic Utilities
# by making calls to this routine at different locations in
# sub 'finish_formatting'.
$Klimit = 'undef' if ( !defined($Klimit) );
- $msg = "" unless $msg;
+ $msg = EMPTY_STRING unless $msg;
Fault("$msg ERROR: rLL has num=$num but Klimit='$Klimit'\n");
}
return;
-}
+} ## end sub check_rLL
sub check_keys {
my ( $rtest, $rvalid, $msg, $exact_match ) = @_;
my $error = @unknown_keys;
if ($exact_match) { $error ||= @missing_keys }
if ($error) {
- local $" = ')(';
+ local $LIST_SEPARATOR = ')(';
my @expected_keys = sort keys %{$rvalid};
@unknown_keys = sort @unknown_keys;
Fault(<<EOM);
EOM
}
return;
-}
+} ## end sub check_keys
sub check_token_array {
my $self = shift;
# when the DEVEL_MODE flag is set, so this Fault will only occur
# during code development.
my $rLL = $self->[_rLL_];
- for ( my $KK = 0 ; $KK < @{$rLL} ; $KK++ ) {
+ foreach my $KK ( 0 .. @{$rLL} - 1 ) {
my $nvars = @{ $rLL->[$KK] };
if ( $nvars != _NVARS ) {
my $NVARS = _NVARS;
}
}
return;
-}
+} ## end sub check_token_array
{ ## begin closure check_line_hashes
"Checkpoint: line number =$iline, line_type=$line_type", 1 );
}
return;
- }
+ } ## end sub check_line_hashes
} ## end closure check_line_hashes
{ ## begin closure for logger routines
}
sub get_input_stream_name {
- my $input_stream_name = "";
+ my $input_stream_name = EMPTY_STRING;
if ($logger_object) {
$input_stream_name = $logger_object->get_input_stream_name();
}
$str =~ s/\s+$//;
$str =~ s/^\s+//;
return split( /\s+/, $str );
-}
+} ## end sub split_words
###########################################
# CODE SECTION 3: Check and process options
if ( $rOpts->{'delete-closing-side-comments'} ) {
$rOpts->{'delete-closing-side-comments'} = 0;
$rOpts->{'closing-side-comments'} = 1;
- $rOpts->{'closing-side-comment-interval'} = 100000000;
+ $rOpts->{'closing-side-comment-interval'} = 100_000_000;
}
}
}
}
+ # Require -msp > 0 to avoid future parsing problems (issue c147)
+ for ( $rOpts->{'minimum-space-to-comment'} ) {
+ if ( !$_ || $_ <= 0 ) { $_ = 1 }
+ }
+
# implement outdenting preferences for keywords
%outdent_keyword = ();
my @okw = split_words( $rOpts->{'outdent-keyword-list'} );
}
# Coordinate ?/: breaks, which must be similar
+ # The small strength 0.01 which is added is 1% of the strength of one
+ # indentation level and seems to work okay.
if ( !$want_break_before{':'} ) {
$want_break_before{'?'} = $want_break_before{':'};
$right_bond_strength{'?'} = $right_bond_strength{':'} + 0.01;
}
}
- #-------------------------------------------------------------------
- # The combination -xlp and -vmll can be unstable unless -iscl is set
- #-------------------------------------------------------------------
- # This is a temporary fix for issue b1302. See also b1306, b1310.
- # FIXME: look for a better fix.
- if ( $rOpts->{'variable-maximum-line-length'}
- && $rOpts->{'extended-line-up-parentheses'}
- && !$rOpts->{'ignore-side-comment-lengths'} )
- {
- $rOpts->{'ignore-side-comment-lengths'} = 1;
-
- # we could write a warning here
- }
-
#-----------------------------------------------------------
# The combination -lp -vmll can be unstable if -ci<2 (b1267)
#-----------------------------------------------------------
if ( defined($opt) && $opt > 0 && $break_before_container_types{$tok} )
{
- # (1) -lp is not compatable with opt=2, silently set to opt=0
+ # (1) -lp is not compatible with opt=2, silently set to opt=0
# (2) opt=0 and 2 give same result if -i=-ci; but opt=0 is faster
if ( $opt == 2 ) {
if ( $rOpts->{'line-up-parentheses'}
push @dof, ',';
@is_do_follower{@dof} = (1) x scalar(@dof);
- # What tokens may follow the closing brace of an if or elsif block?
- # Not used. Previously used for cuddled else, but no longer needed.
- %is_if_brace_follower = ();
-
- # nothing can follow the closing curly of an else { } block:
- %is_else_brace_follower = ();
-
# what can follow a multi-line anonymous sub definition closing curly:
my @asf = qw# ; : => or and && || ~~ !~~ ) #;
push @asf, ',';
$right_bond_strength{'{'} = WEAK;
$left_bond_strength{'{'} = VERY_STRONG;
- # make -l=0 equal to -l=infinite
+ # make -l=0 equal to -l=infinite
if ( !$rOpts->{'maximum-line-length'} ) {
- $rOpts->{'maximum-line-length'} = 1000000;
+ $rOpts->{'maximum-line-length'} = 1_000_000;
}
- # make -lbl=0 equal to -lbl=infinite
+ # make -lbl=0 equal to -lbl=infinite
if ( !$rOpts->{'long-block-line-count'} ) {
- $rOpts->{'long-block-line-count'} = 1000000;
+ $rOpts->{'long-block-line-count'} = 1_000_000;
}
my $ole = $rOpts->{'output-line-ending'};
else {
$ole = lc $ole;
unless ( $rOpts->{'output-line-ending'} = $endings{$ole} ) {
- my $str = join " ", keys %endings;
+ my $str = join SPACE, keys %endings;
Die(<<EOM);
Unrecognized line ending '$ole'; expecting one of: $str
EOM
push @conflicts, '--break-at-old-semicolon-breakpoints (-bos)';
}
if ( $rOpts->{'keep-old-breakpoints-before'} ) {
- $rOpts->{'keep-old-breakpoints-before'} = "";
+ $rOpts->{'keep-old-breakpoints-before'} = EMPTY_STRING;
push @conflicts, '--keep-old-breakpoints-before (-kbb)';
}
if ( $rOpts->{'keep-old-breakpoints-after'} ) {
- $rOpts->{'keep-old-breakpoints-after'} = "";
+ $rOpts->{'keep-old-breakpoints-after'} = EMPTY_STRING;
push @conflicts, '--keep-old-breakpoints-after (-kba)';
}
$rOpts->{'break-at-old-semicolon-breakpoints'};
$rOpts_break_at_old_ternary_breakpoints =
$rOpts->{'break-at-old-ternary-breakpoints'};
- $rOpts_break_open_paren_list = $rOpts->{'break-open-paren-list'};
- $rOpts_closing_side_comments = $rOpts->{'closing-side-comments'};
+ $rOpts_break_open_compact_parens = $rOpts->{'break-open-compact-parens'};
+ $rOpts_closing_side_comments = $rOpts->{'closing-side-comments'};
$rOpts_closing_side_comment_else_flag =
$rOpts->{'closing-side-comment-else-flag'};
$rOpts_closing_side_comment_maximum_text =
# level only. If a line has continuation indentation, then that space must
# be subtracted from the table value. This table is used for preliminary
# estimates in welding, extended_ci, BBX, and marking short blocks.
- my $level_max = 1000;
+ use constant LEVEL_TABLE_MAX => 1000;
# The basic scheme:
- foreach my $level ( 0 .. $level_max ) {
+ foreach my $level ( 0 .. LEVEL_TABLE_MAX ) {
my $indent = $level * $rOpts_indent_columns;
$maximum_line_length_at_level[$level] = $rOpts_maximum_line_length;
$maximum_text_length_at_level[$level] =
$rOpts_whitespace_cycle = $rOpts->{'whitespace-cycle'};
if ($rOpts_whitespace_cycle) {
if ( $rOpts_whitespace_cycle > 0 ) {
- foreach my $level ( 0 .. $level_max ) {
+ foreach my $level ( 0 .. LEVEL_TABLE_MAX ) {
my $level_mod = $level % $rOpts_whitespace_cycle;
my $indent = $level_mod * $rOpts_indent_columns;
$maximum_text_length_at_level[$level] =
# Correct the tables if the -vmll flag is used. These values override the
# previous values.
if ($rOpts_variable_maximum_line_length) {
- foreach my $level ( 0 .. $level_max ) {
+ foreach my $level ( 0 .. LEVEL_TABLE_MAX ) {
$maximum_text_length_at_level[$level] = $rOpts_maximum_line_length;
$maximum_line_length_at_level[$level] =
$rOpts_maximum_line_length + $level * $rOpts_indent_columns;
# formatting features.
# Put a reasonable upper limit on stress level (say 100) in case the
# whitespace-cycle variable is used.
- my $stress_level_limit = min( 100, $level_max );
+ my $stress_level_limit = min( 100, LEVEL_TABLE_MAX );
# Find stress_level_alpha, targeted at very short maximum line lengths.
$stress_level_alpha = $stress_level_limit + 1;
$stress_level_beta = $level;
}
- initialize_weld_nested_exclusion_rules($rOpts);
+ initialize_weld_nested_exclusion_rules();
%line_up_parentheses_control_hash = ();
$line_up_parentheses_control_is_lxpl = 1;
}
return;
-}
+} ## end sub check_options
use constant ALIGN_GREP_ALIASES => 0;
}
}
return;
-}
+} ## end sub initialize_grep_and_friends
sub initialize_weld_nested_exclusion_rules {
- my ($rOpts) = @_;
%weld_nested_exclusion_rules = ();
my $opt_name = 'weld-nested-exclusion-list';
EOM
}
return;
-}
+} ## end sub initialize_weld_nested_exclusion_rules
sub initialize_line_up_parentheses_control_hash {
my ( $str, $opt_name ) = @_;
}
}
if ($all_off) {
- $rOpts->{'line-up-parentheses'} = "";
+ $rOpts->{'line-up-parentheses'} = EMPTY_STRING;
}
}
return;
-}
+} ## end sub initialize_line_up_parentheses_control_hash
use constant DEBUG_KB => 0;
my %flags = ();
my @list = split_words($str);
if ( DEBUG_KB && @list ) {
- local $" = ' ';
+ local $LIST_SEPARATOR = SPACE;
print <<EOM;
DEBUG_KB entering for '$short_name' with str=$str\n";
list is: @list;
EOM
}
- # - pull out any any leading container code, like f( or *{
- foreach (@list) {
- if ( $_ =~ /^( [ \w\* ] )( [ \{\(\[\}\)\] ] )$/x ) {
- $_ = $2;
+ # Ignore kbb='(' and '[' and '{': can cause unstable math formatting
+ # (issues b1346, b1347, b1348) and likewise ignore kba=')' and ']' and '}'
+ if ( $short_name eq 'kbb' ) {
+ @list = grep { !m/[\(\[\{]/ } @list;
+ }
+ elsif ( $short_name eq 'kba' ) {
+ @list = grep { !m/[\)\]\}]/ } @list;
+ }
+
+ # pull out any any leading container code, like f( or *{
+ # For example: 'f(' becomes flags hash entry '(' => 'f'
+ foreach my $item (@list) {
+ if ( $item =~ /^( [ \w\* ] )( [ \{\(\[\}\)\] ] )$/x ) {
+ $item = $2;
$flags{$2} = $1;
}
}
if (@unknown_types) {
my $num = @unknown_types;
- local $" = ' ';
+ local $LIST_SEPARATOR = SPACE;
Warn(<<EOM);
$num unrecognized token types were input with --$short_name :
@unknown_types
$rkeep_break_hash->{$key} = $flag;
}
- # Temporary patch and warning during changeover from using type to token for
- # containers . This can be eliminated after one or two future releases.
- if ( $rkeep_break_hash->{'{'}
- && $rkeep_break_hash->{'{'} eq '1'
- && !$rkeep_break_hash->{'('}
- && !$rkeep_break_hash->{'['} )
- {
- $rkeep_break_hash->{'('} = 1;
- $rkeep_break_hash->{'['} = 1;
- Warn(<<EOM);
-Sorry, but the format for the -kbb and -kba flags is changing a little.
-You entered '{' which currently matches '{' '(' and '[',
-but in the future it will only match '{'.
-To prevent this message please do one of the following:
- use '{ ( [' if you want to match all opening containers, or
- use '(' or '[' to match just those containers, or
- use '*{' to match only opening braces
-EOM
- }
-
- if ( $rkeep_break_hash->{'}'}
- && $rkeep_break_hash->{'}'} eq '1'
- && !$rkeep_break_hash->{')'}
- && !$rkeep_break_hash->{']'} )
- {
- $rkeep_break_hash->{'('} = 1;
- $rkeep_break_hash->{'['} = 1;
- Warn(<<EOM);
-Sorry, but the format for the -kbb and -kba flags is changing a little.
-You entered '}' which currently matches each of '}' ')' and ']',
-but in the future it will only match '}'.
-To prevent this message please do one of the following:
- use '} ) ]' if you want to match all closing containers, or
- use ')' or ']' to match just those containers, or
- use '*}' to match only closing braces
-EOM
- }
-
if ( DEBUG_KB && @list ) {
my @tmp = %flags;
- local $" = ' ';
+ local $LIST_SEPARATOR = SPACE;
print <<EOM;
DEBUG_KB -$short_name flag: $str
return;
-}
+} ## end sub initialize_keep_old_breakpoints
sub initialize_whitespace_hashes {
$binary_ws_rules{'w'}{'{'} = WS_YES;
return;
-} ## end initialize_whitespace_hashes
+} ## end sub initialize_whitespace_hashes
-# The following hash is used to skip over needless if tests.
-# Be sure to update it when adding new checks in its block.
my %is_special_ws_type;
+my %is_wCUG;
+my %is_wi;
BEGIN {
+
+ # The following hash is used to skip over needless if tests.
+ # Be sure to update it when adding new checks in its block.
my @q = qw(k w i C m - Q);
push @q, '#';
@is_special_ws_type{@q} = (1) x scalar(@q);
+
+ # These hashes replace slower regex tests
+ @q = qw( w C U G );
+ @is_wCUG{@q} = (1) x scalar(@q);
+
+ @q = qw( w i );
+ @is_wi{@q} = (1) x scalar(@q);
}
use constant DEBUG_WHITE => 0;
my %is_for_foreach = ( 'for' => 1, 'foreach' => 1 );
- my ( $rtokh, $token, $type );
- my ( $rtokh_last, $last_token, $last_type );
+ my ( $rtokh, $token, $type );
+ my $rtokh_last = $rLL->[0];
+ my $rtokh_last_last = $rtokh_last;
+
+ my $last_type = EMPTY_STRING;
+ my $last_token = EMPTY_STRING;
my $j_tight_closing_paren = -1;
$rtokh = [ @{ $rLL->[0] } ];
- $token = ' ';
+ $token = SPACE;
$type = 'b';
$rtokh->[_TOKEN_] = $token;
$rtokh->[_TYPE_] = $type;
- $rtokh->[_TYPE_SEQUENCE_] = '';
+ $rtokh->[_TYPE_SEQUENCE_] = EMPTY_STRING;
$rtokh->[_LINE_INDEX_] = 0;
- my ($ws);
-
# This is some logic moved to a sub to avoid deep nesting of if stmts
my $ws_in_container = sub {
my ( $ws_1, $ws_2, $ws_3, $ws_4 );
# main loop over all tokens to define the whitespace flags
- for ( my $j = 0 ; $j <= $jmax ; $j++ ) {
+ foreach my $j ( 0 .. $jmax ) {
if ( $rLL->[$j]->[_TYPE_] eq 'b' ) {
$rwhitespace_flags->[$j] = WS_OPTIONAL;
next;
}
+ $rtokh_last_last = $rtokh_last;
+
$rtokh_last = $rtokh;
$last_token = $token;
$last_type = $type;
$token = $rtokh->[_TOKEN_];
$type = $rtokh->[_TYPE_];
- $ws = undef;
+ my $ws;
#---------------------------------------------------------------
# Whitespace Rules Section 1:
}
else { $tightness = $tightness{$last_token} }
- #=============================================================
- # Patch for test problem <<snippets/fabrice_bug.in>>
- # We must always avoid spaces around a bare word beginning
- # with ^ as in:
- # my $before = ${^PREMATCH};
- # Because all of the following cause an error in perl:
- # my $before = ${ ^PREMATCH };
- # my $before = ${ ^PREMATCH};
- # my $before = ${^PREMATCH };
- # So if brace tightness flag is -bt=0 we must temporarily reset
- # to bt=1. Note that here we must set tightness=1 and not 2 so
- # that the closing space
- # is also avoided (via the $j_tight_closing_paren flag in coding)
+ #=============================================================
+ # Patch for test problem <<snippets/fabrice_bug.in>>
+ # We must always avoid spaces around a bare word beginning
+ # with ^ as in:
+ # my $before = ${^PREMATCH};
+ # Because all of the following cause an error in perl:
+ # my $before = ${ ^PREMATCH };
+ # my $before = ${ ^PREMATCH};
+ # my $before = ${^PREMATCH };
+ # So if brace tightness flag is -bt=0 we must temporarily reset
+ # to bt=1. Note that here we must set tightness=1 and not 2 so
+ # that the closing space is also avoided
+ # (via the $j_tight_closing_paren flag in coding)
if ( $type eq 'w' && $token =~ /^\^/ ) { $tightness = 1 }
#=============================================================
#---------------------------------------------------------------
# Whitespace Rules Section 2:
+ # Special checks for certain types ...
+ #---------------------------------------------------------------
+ # The hash '%is_special_ws_type' significantly speeds up this routine,
+ # but be sure to update it if a new check is added.
+ # Currently has types: qw(k w i C m - Q #)
+ if ( $is_special_ws_type{$type} ) {
+ if ( $type eq 'i' ) {
+
+ # never a space before ->
+ if ( substr( $token, 0, 2 ) eq '->' ) {
+ $ws = WS_NO;
+ }
+ }
+
+ elsif ( $type eq 'k' ) {
+
+ # Keywords 'for', 'foreach' are special cases for -kpit since
+ # the opening paren does not always immediately follow the
+ # keyword. So we have to search forward for the paren in this
+ # case. I have limited the search to 10 tokens ahead, just in
+ # case somebody has a big file and no opening paren. This
+ # should be enough for all normal code. Added the level check
+ # to fix b1236.
+ if ( $is_for_foreach{$token}
+ && %keyword_paren_inner_tightness
+ && defined( $keyword_paren_inner_tightness{$token} )
+ && $j < $jmax )
+ {
+ my $level = $rLL->[$j]->[_LEVEL_];
+ my $jp = $j;
+ ## NOTE: we might use the KNEXT variable to avoid this loop
+ ## but profiling shows that little would be saved
+ foreach my $inc ( 1 .. 9 ) {
+ $jp++;
+ last if ( $jp > $jmax );
+ last if ( $rLL->[$jp]->[_LEVEL_] != $level ); # b1236
+ next unless ( $rLL->[$jp]->[_TOKEN_] eq '(' );
+ my $seqno_p = $rLL->[$jp]->[_TYPE_SEQUENCE_];
+ $set_container_ws_by_keyword->( $token, $seqno_p );
+ last;
+ }
+ }
+ }
+
+ # retain any space between '-' and bare word
+ elsif ( $type eq 'w' || $type eq 'C' ) {
+ $ws = WS_OPTIONAL if $last_type eq '-';
+
+ # never a space before ->
+ if ( substr( $token, 0, 2 ) eq '->' ) {
+ $ws = WS_NO;
+ }
+ }
+
+ # retain any space between '-' and bare word; for example
+ # avoid space between 'USER' and '-' here: <<snippets/space2.in>>
+ # $myhash{USER-NAME}='steve';
+ elsif ( $type eq 'm' || $type eq '-' ) {
+ $ws = WS_OPTIONAL if ( $last_type eq 'w' );
+ }
+
+ # always space before side comment
+ elsif ( $type eq '#' ) { $ws = WS_YES if $j > 0 }
+
+ # space_backslash_quote; RT #123774 <<snippets/rt123774.in>>
+ # allow a space between a backslash and single or double quote
+ # to avoid fooling html formatters
+ elsif ( $last_type eq '\\' && $type eq 'Q' && $token =~ /^[\"\']/ )
+ {
+ if ($rOpts_space_backslash_quote) {
+ if ( $rOpts_space_backslash_quote == 1 ) {
+ $ws = WS_OPTIONAL;
+ }
+ elsif ( $rOpts_space_backslash_quote == 2 ) { $ws = WS_YES }
+ else { } # shouldnt happen
+ }
+ else {
+ $ws = WS_NO;
+ }
+ }
+ } ## end elsif ( $is_special_ws_type{$type} ...
+
+ #---------------------------------------------------------------
+ # Whitespace Rules Section 3:
# Handle space on inside of closing brace pairs.
#---------------------------------------------------------------
# /[\}\)\]R]/
- if ( $is_closing_type{$type} ) {
+ elsif ( $is_closing_type{$type} ) {
my $seqno = $rtokh->[_TYPE_SEQUENCE_];
if ( $j == $j_tight_closing_paren ) {
} ## end setting space flag inside closing tokens
#---------------------------------------------------------------
- # Whitespace Rules Section 3:
- # Handle some special cases.
+ # Whitespace Rules Section 4:
#---------------------------------------------------------------
-
# /^[L\{\(\[]$/
elsif ( $is_opening_type{$type} ) {
my $seqno = $rtokh->[_TYPE_SEQUENCE_];
- # This will have to be tweaked as tokenization changes.
- # We usually want a space at '} (', for example:
- # <<snippets/space1.in>>
- # map { 1 * $_; } ( $y, $M, $w, $d, $h, $m, $s );
- #
- # But not others:
- # &{ $_->[1] }( delete $_[$#_]{ $_->[0] } );
- # At present, the above & block is marked as type L/R so this case
- # won't go through here.
+ # This will have to be tweaked as tokenization changes.
+ # We usually want a space at '} (', for example:
+ # <<snippets/space1.in>>
+ # map { 1 * $_; } ( $y, $M, $w, $d, $h, $m, $s );
+ #
+ # But not others:
+ # &{ $_->[1] }( delete $_[$#_]{ $_->[0] } );
+ # At present, the above & block is marked as type L/R so this
+ # case won't go through here.
if ( $last_type eq '}' && $last_token ne ')' ) { $ws = WS_YES }
- # NOTE: some older versions of Perl had occasional problems if
- # spaces are introduced between keywords or functions and opening
- # parens. So the default is not to do this except is certain
- # cases. The current Perl seems to tolerate spaces.
+ # NOTE: some older versions of Perl had occasional problems if
+ # spaces are introduced between keywords or functions and
+ # opening parens. So the default is not to do this except is
+ # certain cases. The current Perl seems to tolerate spaces.
# Space between keyword and '('
elsif ( $last_type eq 'k' ) {
# myfun( &myfun( ->myfun(
# -----------------------------------------------------
- # Note that at this point an identifier may still have a leading
- # arrow, but the arrow will be split off during token respacing.
- # After that, the token may become a bare word without leading
- # arrow. The point is, it is best to mark function call parens
- # right here before that happens.
- # Patch: added 'C' to prevent blinker, case b934, i.e. 'pi()'
- # NOTE: this would be the place to allow spaces between repeated
- # parens, like () () (), as in case c017, but I decided that would
- # not be a good idea.
+ # Note that at this point an identifier may still have a
+ # leading arrow, but the arrow will be split off during token
+ # respacing. After that, the token may become a bare word
+ # without leading arrow. The point is, it is best to mark
+ # function call parens right here before that happens.
+ # Patch: added 'C' to prevent blinker, case b934, i.e. 'pi()'
+ # NOTE: this would be the place to allow spaces between
+ # repeated parens, like () () (), as in case c017, but I
+ # decided that would not be a good idea.
elsif (
- ( $last_type =~ /^[wCUG]$/ )
- || ( $last_type =~ /^[wi]$/ && $last_token =~ /^([\&]|->)/ )
+ ##$last_type =~ /^[wCUG]$/
+ $is_wCUG{$last_type}
+ || (
+ ##$last_type =~ /^[wi]$/
+ $is_wi{$last_type}
+
+ && (
+ $last_token =~ /^([\&]|->)/
+
+ # or -> or & split from bareword by newline (b1337)
+ || (
+ $last_token =~ /^\w/
+ && (
+ $rtokh_last_last->[_TYPE_] eq '->'
+ || ( $rtokh_last_last->[_TYPE_] eq 't'
+ && $rtokh_last_last->[_TOKEN_] =~
+ /^\&\s*$/ )
+ )
+ )
+ )
+ )
)
{
$ws = $rOpts_space_function_paren ? WS_YES : WS_NO;
$ris_function_call_paren->{$seqno} = 1;
}
- # space between something like $i and ( in <<snippets/space2.in>>
- # for $i ( 0 .. 20 ) {
- # FIXME: eventually, type 'i' could be split into multiple
- # token types so this can be a hardwired rule.
+ # space between something like $i and ( in 'snippets/space2.in'
+ # for $i ( 0 .. 20 ) {
+ # FIXME: eventually, type 'i' could be split into multiple
+ # token types so this can be a hardwired rule.
elsif ( $last_type eq 'i' && $last_token =~ /^[\$\%\@]/ ) {
$ws = WS_YES;
}
}
} ## end if ( $is_opening_type{$type} ) {
- # Special checks for certain other types ...
- # the hash '%is_special_ws_type' significantly speeds up this routine,
- # but be sure to update it if a new check is added.
- # Currently has types: qw(k w i C m - Q #)
- elsif ( $is_special_ws_type{$type} ) {
- if ( $type eq 'i' ) {
-
- # never a space before ->
- if ( substr( $token, 0, 2 ) eq '->' ) {
- $ws = WS_NO;
- }
- }
-
- elsif ( $type eq 'k' ) {
-
- # Keywords 'for', 'foreach' are special cases for -kpit since
- # the opening paren does not always immediately follow the
- # keyword. So we have to search forward for the paren in this
- # case. I have limited the search to 10 tokens ahead, just in
- # case somebody has a big file and no opening paren. This
- # should be enough for all normal code. Added the level check
- # to fix b1236.
- if ( $is_for_foreach{$token}
- && %keyword_paren_inner_tightness
- && defined( $keyword_paren_inner_tightness{$token} )
- && $j < $jmax )
- {
- my $level = $rLL->[$j]->[_LEVEL_];
- my $jp = $j;
- for ( my $inc = 1 ; $inc < 10 ; $inc++ ) {
- $jp++;
- last if ( $jp > $jmax );
- last if ( $rLL->[$jp]->[_LEVEL_] != $level ); # b1236
- next unless ( $rLL->[$jp]->[_TOKEN_] eq '(' );
- my $seqno_p = $rLL->[$jp]->[_TYPE_SEQUENCE_];
- $set_container_ws_by_keyword->( $token, $seqno_p );
- last;
- }
- }
- }
-
- # retain any space between '-' and bare word
- elsif ( $type eq 'w' || $type eq 'C' ) {
- $ws = WS_OPTIONAL if $last_type eq '-';
-
- # never a space before ->
- if ( substr( $token, 0, 2 ) eq '->' ) {
- $ws = WS_NO;
- }
- }
-
- # retain any space between '-' and bare word; for example
- # avoid space between 'USER' and '-' here: <<snippets/space2.in>>
- # $myhash{USER-NAME}='steve';
- elsif ( $type eq 'm' || $type eq '-' ) {
- $ws = WS_OPTIONAL if ( $last_type eq 'w' );
- }
-
- # always space before side comment
- elsif ( $type eq '#' ) { $ws = WS_YES if $j > 0 }
-
- # space_backslash_quote; RT #123774 <<snippets/rt123774.in>>
- # allow a space between a backslash and single or double quote
- # to avoid fooling html formatters
- elsif ( $last_type eq '\\' && $type eq 'Q' && $token =~ /^[\"\']/ )
- {
- if ($rOpts_space_backslash_quote) {
- if ( $rOpts_space_backslash_quote == 1 ) {
- $ws = WS_OPTIONAL;
- }
- elsif ( $rOpts_space_backslash_quote == 2 ) { $ws = WS_YES }
- else { } # shouldnt happen
- }
- else {
- $ws = WS_NO;
- }
- }
- } ## end elsif ( $is_special_ws_type{$type} ...
-
# always preserver whatever space was used after a possible
# filehandle (except _) or here doc operator
if (
# Apply default rules not covered above.
#---------------------------------------------------------------
- # If we fall through to here, look at the pre-defined hash tables for
- # the two tokens, and:
- # if (they are equal) use the common value
- # if (either is zero or undef) use the other
- # if (either is -1) use it
- # That is,
- # left vs right
- # 1 vs 1 --> 1
- # 0 vs 0 --> 0
- # -1 vs -1 --> -1
- #
- # 0 vs -1 --> -1
- # 0 vs 1 --> 1
- # 1 vs 0 --> 1
- # -1 vs 0 --> -1
- #
- # -1 vs 1 --> -1
- # 1 vs -1 --> -1
+ # If we fall through to here, look at the pre-defined hash tables
+ # for the two tokens, and:
+ # if (they are equal) use the common value
+ # if (either is zero or undef) use the other
+ # if (either is -1) use it
+ # That is,
+ # left vs right
+ # 1 vs 1 --> 1
+ # 0 vs 0 --> 0
+ # -1 vs -1 --> -1
+ #
+ # 0 vs -1 --> -1
+ # 0 vs 1 --> 1
+ # 1 vs 0 --> 1
+ # -1 vs 0 --> -1
+ #
+ # -1 vs 1 --> -1
+ # 1 vs -1 --> -1
if ( !defined($ws) ) {
my $wl = $want_left_space{$type};
my $wr = $want_right_space{$last_type};
if (DEBUG_WHITE) {
my $str = substr( $last_token, 0, 15 );
- $str .= ' ' x ( 16 - length($str) );
+ $str .= SPACE x ( 16 - length($str) );
if ( !defined($ws_1) ) { $ws_1 = "*" }
if ( !defined($ws_2) ) { $ws_2 = "*" }
if ( !defined($ws_3) ) { $ws_3 = "*" }
sub dump_want_left_space {
my $fh = shift;
- local $" = "\n";
+ local $LIST_SEPARATOR = "\n";
$fh->print(<<EOM);
These values are the main control of whitespace to the left of a token type;
They may be altered with the -wls parameter.
$fh->print("$key\t$want_left_space{$key}\n");
}
return;
-}
+} ## end sub dump_want_left_space
sub dump_want_right_space {
my $fh = shift;
- local $" = "\n";
+ local $LIST_SEPARATOR = "\n";
$fh->print(<<EOM);
These values are the main control of whitespace to the right of a token type;
They may be altered with the -wrs parameter.
$fh->print("$key\t$want_right_space{$key}\n");
}
return;
-}
+} ## end sub dump_want_right_space
{ ## begin closure is_essential_whitespace
@is_for_foreach{@q} = (1) x scalar(@q);
@q = qw(
- .. :: << >> ** && .. || // -> => += -= .= %= &= |= ^= *= <>
+ .. :: << >> ** && || // -> => += -= .= %= &= |= ^= *= <>
<= >= == =~ !~ != ++ -- /= x= ~~ ~. |. &. ^.
);
@is_digraph{@q} = (1) x scalar(@q);
# { ... }
# Also, I prefer not to put a ? and # together because ? used to be
- # a pattern delmiter and spacing was used if guessing was needed.
+ # a pattern delimiter and spacing was used if guessing was needed.
if ( $typer eq '#' ) {
# keep a space between a token ending in '$' and any word;
# this caused trouble: "die @$ if $@"
- ##|| $typel eq 'i' && $tokenl =~ /\$$/
|| $typel eq 'i' && substr( $tokenl, -1, 1 ) eq '$'
# don't combine $$ or $# with any alphanumeric
# (testfile mangle.t with --mangle)
- ##|| $tokenl =~ /^\$[\$\#]$/
|| $tokenl eq '$$'
|| $tokenl eq '$#'
# perl is very fussy about spaces before <<
|| substr( $tokenr, 0, 2 ) eq '<<'
- ##|| $tokenr =~ /^\<\</
# avoid combining tokens to create new meanings. Example:
# $a+ +$b must not become $a++$b
# be careful with a space around ++ and --, to avoid ambiguity as to
# which token it applies
- ##|| $typer =~ /^(pp|mm)$/ && $tokenl !~ /^[\;\{\(\[]/
|| ( $typer eq 'pp' || $typer eq 'mm' ) && $tokenl !~ /^[\;\{\(\[]/
|| ( $typel eq '++' || $typel eq '--' )
&& $tokenr !~ /^[\;\}\)\]]/
- ##|| $typel =~ /^(\+\+|\-\-)$/ && $tokenr !~ /^[\;\}\)\]]/
# need space after foreach my; for example, this will fail in
# older versions of Perl:
$tokenl eq 'my'
&& substr( $tokenr, 0, 1 ) eq '$'
- ##&& $tokenr =~ /^\$/
# /^(for|foreach)$/
&& $is_for_foreach{$tokenll}
; # the value of this long logic sequence is the result we want
return $result;
- }
+ } ## end sub is_essential_whitespace
} ## end closure is_essential_whitespace
{ ## begin closure new_secret_operator_whitespace
# real tokens
$right_bond_strength{'b'} = NO_BREAK;
- # try not to break on exponentation
+ # try not to break on exponentiation
@q = qw# ** .. ... <=> #;
@left_bond_strength{@q} = (STRONG) x scalar(@q);
@right_bond_strength{@q} = (STRONG) x scalar(@q);
my ($self) = @_;
- my $rK_weld_right = $self->[_rK_weld_right_];
- my $rK_weld_left = $self->[_rK_weld_left_];
+ my $rbond_strength_to_go = [];
+
+ my $rLL = $self->[_rLL_];
+ my $rK_weld_right = $self->[_rK_weld_right_];
+ my $rK_weld_left = $self->[_rK_weld_left_];
+ my $ris_list_by_seqno = $self->[_ris_list_by_seqno_];
# patch-its always ok to break at end of line
$nobreak_to_go[$max_index_to_go] = 0;
my $code_bias = -.01; # bias for closing block braces
my $type = 'b';
- my $token = ' ';
+ my $token = SPACE;
my $token_length = 1;
my $last_type;
my $last_nonblank_type = $type;
# strength on both sides of a blank is the same
if ( $type eq 'b' && $last_type ne 'b' ) {
- $bond_strength_to_go[$i] = $bond_strength_to_go[ $i - 1 ];
+ $rbond_strength_to_go->[$i] = $rbond_strength_to_go->[ $i - 1 ];
$nobreak_to_go[$i] ||= $nobreak_to_go[ $i - 1 ]; # fix for b1257
next;
}
# this will cause good preceding breaks to be retained
if ( $i_next_nonblank > $max_index_to_go ) {
$bsl = NOMINAL;
+
+ # But weaken the bond at a 'missing terminal comma'. If an
+ # optional comma is missing at the end of a broken list, use
+ # the strength of a comma anyway to make formatting the same as
+ # if it were there. Fixes issue c133.
+ if ( !defined($bsr) || $bsr > VERY_WEAK ) {
+ my $seqno_px = $parent_seqno_to_go[$max_index_to_go];
+ if ( $ris_list_by_seqno->{$seqno_px} ) {
+ my $KK = $K_to_go[$max_index_to_go];
+ my $Kn = $self->K_next_nonblank($KK);
+ my $seqno_n = $rLL->[$Kn]->[_TYPE_SEQUENCE_];
+ if ( $seqno_n && $seqno_n eq $seqno_px ) {
+ $bsl = VERY_WEAK;
+ }
+ }
+ }
}
# define right bond strengths of certain keywords
# In any case if the user places a break at either the = or the ||
# it should remain there.
if ( $type eq '||' || $type eq 'k' && $token eq 'or' ) {
- if ( $next_nonblank_token =~ /^(die|confess|croak|warn)$/ ) {
+
+ # /^(die|confess|croak|warn)$/
+ if ( $is_die_confess_croak_warn{$next_nonblank_token} ) {
if ( $want_break_before{$token} && $i > 0 ) {
- $bond_strength_to_go[ $i - 1 ] -= $delta_bias;
+ $rbond_strength_to_go->[ $i - 1 ] -= $delta_bias;
# keep bond strength of a token and its following blank
# the same
if ( $types_to_go[ $i - 1 ] eq 'b' && $i > 2 ) {
- $bond_strength_to_go[ $i - 2 ] -= $delta_bias;
+ $rbond_strength_to_go->[ $i - 2 ] -= $delta_bias;
}
}
else {
}
- # good to break before 'if', 'unless', etc
- if ( $is_if_brace_follower{$next_nonblank_token} ) {
- $bond_str = VERY_WEAK;
- }
-
if ( $next_nonblank_type eq 'k' && $type ne 'CORE::' ) {
if ( $is_keyword_returning_list{$next_nonblank_token} ) {
: $next_nonblank_token
: $next_nonblank_type;
- if ( $type eq ',' ) {
-
- # add any bias set by sub break_lists at old comma break points
- $bond_str += $bond_strength_to_go[$i];
-
- }
-
# bias left token
- elsif ( defined( $bias{$left_key} ) ) {
+ if ( defined( $bias{$left_key} ) ) {
if ( !$want_break_before{$left_key} ) {
$bias{$left_key} += $delta_bias;
$bond_str += $bias{$left_key};
# always break after side comment
if ( $type eq '#' ) { $strength = 0 }
- $bond_strength_to_go[$i] = $strength;
+ $rbond_strength_to_go->[$i] = $strength;
# Fix for case c001: be sure NO_BREAK's are enforced by later
# routines, except at a '?' because '?' as quote delimiter is
DEBUG_BOND && do {
my $str = substr( $token, 0, 15 );
- $str .= ' ' x ( 16 - length($str) );
+ $str .= SPACE x ( 16 - length($str) );
print STDOUT
"BOND: i=$i $str $type $next_nonblank_type depth=$total_nesting_depth strength=$bond_str_1 -> $bond_str_2 -> $bond_str_3 -> $bond_str_4 $bond_str -> $strength \n";
};
} ## end main loop
- return;
+ return $rbond_strength_to_go;
} ## end sub set_bond_strengths
} ## end closure set_bond_strengths
# by this program.
my ($pattern) = @_;
eval "'##'=~/$pattern/";
- return $@;
+ return $EVAL_ERROR;
}
{ ## begin closure prepare_cuddled_block_types
# Include keywords here which should not be cuddled
- my $cuddled_string = "";
+ my $cuddled_string = EMPTY_STRING;
if ( $rOpts->{'cuddled-else'} ) {
# set the default
# Add users other blocks to be cuddled
my $cuddled_block_list = $rOpts->{'cuddled-block-list'};
if ($cuddled_block_list) {
- $cuddled_string .= " " . $cuddled_block_list;
+ $cuddled_string .= SPACE . $cuddled_block_list;
}
}
}
}
return;
- }
-} ## begin closure prepare_cuddled_block_types
+ } ## end sub prepare_cuddled_block_types
+} ## end closure prepare_cuddled_block_types
sub dump_cuddled_block_list {
my ($fh) = @_;
# },
# };
- # SIMPLFIED METHOD: the simplified method uses a wildcard for
+ # SIMPLIFIED METHOD: the simplified method uses a wildcard for
# the starting block type and puts all cuddled blocks together:
# my $rcuddled_block_types = {
# '*' => {
# easier to manage.
my $cuddled_string = $rOpts->{'cuddled-block-list'};
- $cuddled_string = '' unless $cuddled_string;
+ $cuddled_string = EMPTY_STRING unless $cuddled_string;
- my $flags = "";
+ my $flags = EMPTY_STRING;
$flags .= "-ce" if ( $rOpts->{'cuddled-else'} );
$flags .= " -cbl='$cuddled_string'";
------------------------------------------------------------------------
EOM
return;
-}
+} ## end sub dump_cuddled_block_list
sub make_static_block_comment_pattern {
$static_block_comment_pattern = $pattern;
}
return;
-}
+} ## end sub make_static_block_comment_pattern
sub make_format_skipping_pattern {
my ( $opt_name, $default ) = @_;
);
}
return $pattern;
-}
+} ## end sub make_format_skipping_pattern
sub make_non_indenting_brace_pattern {
$non_indenting_brace_pattern = $pattern;
}
return;
-}
+} ## end sub make_non_indenting_brace_pattern
sub make_closing_side_comment_list_pattern {
make_block_pattern( '-cscl', $rOpts->{'closing-side-comment-list'} );
}
return;
-}
+} ## end sub make_closing_side_comment_list_pattern
sub make_sub_matching_pattern {
$ASUB_PATTERN =~ s/sub/\($sub_alias_list\)/;
}
return;
-}
+} ## end sub make_sub_matching_pattern
sub make_bl_pattern {
$bl_exclusion_pattern =
make_block_pattern( '-blxl', $bl_exclusion_list_string );
return;
-}
+} ## end sub make_bl_pattern
sub make_bli_pattern {
# default list of block types for which -bli would apply
my $bli_list_string = 'if else elsif unless while for foreach do : sub';
- my $bli_exclusion_list_string = ' ';
+ my $bli_exclusion_list_string = SPACE;
if ( defined( $rOpts->{'brace-left-and-indent-list'} )
&& $rOpts->{'brace-left-and-indent-list'} )
$bli_exclusion_pattern =
make_block_pattern( '-blixl', $bli_exclusion_list_string );
return;
-}
+} ## end sub make_bli_pattern
sub make_keyword_group_list_pattern {
# turn any input list into a regex for recognizing selected block types.
# Here are the defaults:
$keyword_group_list_pattern = '^(our|local|my|use|require|)$';
- $keyword_group_list_comment_pattern = '';
+ $keyword_group_list_comment_pattern = EMPTY_STRING;
if ( defined( $rOpts->{'keyword-group-blanks-list'} )
&& $rOpts->{'keyword-group-blanks-list'} )
{
my @keyword_list;
my @comment_list;
foreach my $word (@words) {
- if ( $word =~ /^(BC|SBC)$/ ) {
+ if ( $word eq 'BC' || $word eq 'SBC' ) {
push @comment_list, $word;
if ( $word eq 'SBC' ) { push @comment_list, 'SBCX' }
}
$keyword_group_list_pattern =
make_block_pattern( '-kgbl', $rOpts->{'keyword-group-blanks-list'} );
$keyword_group_list_comment_pattern =
- make_block_pattern( '-kgbl', join( ' ', @comment_list ) );
+ make_block_pattern( '-kgbl', join( SPACE, @comment_list ) );
}
return;
-}
+} ## end sub make_keyword_group_list_pattern
sub make_block_brace_vertical_tightness_pattern {
$rOpts->{'block-brace-vertical-tightness-list'} );
}
return;
-}
+} ## end sub make_block_brace_vertical_tightness_pattern
sub make_blank_line_pattern {
make_block_pattern( '-blaol', $rOpts->{$key} );
}
return;
-}
+} ## end sub make_blank_line_pattern
sub make_block_pattern {
if ( !@words ) { push @words, "1 " }
my $pattern = '(' . join( '|', @words ) . ')$';
- my $sub_patterns = "";
+ my $sub_patterns = EMPTY_STRING;
if ( $seen{'sub'} ) {
$sub_patterns .= '|' . $SUB_PATTERN;
}
}
$pattern = '^' . $pattern;
return $pattern;
-}
+} ## end sub make_block_pattern
sub make_static_side_comment_pattern {
$static_side_comment_pattern = $pattern;
}
return;
-}
+} ## end sub make_static_side_comment_pattern
sub make_closing_side_comment_prefix {
$rOpts->{'closing-side-comment-prefix'} = $csc_prefix;
$closing_side_comment_prefix_pattern = $csc_prefix_pattern;
return;
-}
+} ## end sub make_closing_side_comment_prefix
##################################################
# CODE SECTION 4: receive lines from the tokenizer
%saw_closing_seqno = ();
return;
- }
+ } ## end sub initialize_write_line
sub check_sequence_numbers {
my $seqno = $rtype_sequence->[$j];
my $token = $rtokens->[$j];
my $type = $rtoken_type->[$j];
+ $seqno = EMPTY_STRING unless ( defined($seqno) );
my $err_msg =
"Error at j=$j, line number $input_line_no, seqno='$seqno', type='$type', tok='$token':\n";
}
}
return;
- }
+ } ## end sub check_sequence_numbers
sub write_line {
# Data needed by Logger
$line_of_tokens->{_level_0} = 0;
$line_of_tokens->{_ci_level_0} = 0;
- $line_of_tokens->{_nesting_blocks_0} = "";
- $line_of_tokens->{_nesting_tokens_0} = "";
+ $line_of_tokens->{_nesting_blocks_0} = EMPTY_STRING;
+ $line_of_tokens->{_nesting_tokens_0} = EMPTY_STRING;
# Needed to avoid trimming quotes
$line_of_tokens->{_ended_in_blank_token} = undef;
my $line_type = $line_of_tokens_old->{_line_type};
my $line_number = $line_of_tokens_old->{_line_number};
- my $CODE_type = "";
+ my $CODE_type = EMPTY_STRING;
my $tee_output;
# Handle line of non-code
# Handle line of code
else {
- my $rtokens = $line_of_tokens_old->{_rtokens};
- my $rtoken_type = $line_of_tokens_old->{_rtoken_type};
- my $rblock_type = $line_of_tokens_old->{_rblock_type};
- my $rcontainer_type = $line_of_tokens_old->{_rcontainer_type};
- my $rcontainer_environment =
- $line_of_tokens_old->{_rcontainer_environment};
- my $rtype_sequence = $line_of_tokens_old->{_rtype_sequence};
- my $rlevels = $line_of_tokens_old->{_rlevels};
- my $rslevels = $line_of_tokens_old->{_rslevels};
- my $rci_levels = $line_of_tokens_old->{_rci_levels};
- my $rnesting_blocks = $line_of_tokens_old->{_rnesting_blocks};
- my $rnesting_tokens = $line_of_tokens_old->{_rnesting_tokens};
+ my $rtokens = $line_of_tokens_old->{_rtokens};
+ my $rtoken_type = $line_of_tokens_old->{_rtoken_type};
+ my $rblock_type = $line_of_tokens_old->{_rblock_type};
+ my $rtype_sequence = $line_of_tokens_old->{_rtype_sequence};
+ my $rlevels = $line_of_tokens_old->{_rlevels};
+ my $rci_levels = $line_of_tokens_old->{_rci_levels};
my $jmax = @{$rtokens} - 1;
if ( $jmax >= 0 ) {
push @{$rSS}, $sign * $seqno;
}
+ else {
+ $seqno = EMPTY_STRING unless ( defined($seqno) );
+ }
my @tokary;
@tokary[
$line_of_tokens->{_ended_in_blank_token} =
$rtoken_type->[$jmax] eq 'b';
- $line_of_tokens->{_level_0} = $rlevels->[0];
- $line_of_tokens->{_ci_level_0} = $rci_levels->[0];
- $line_of_tokens->{_nesting_blocks_0} = $rnesting_blocks->[0];
- $line_of_tokens->{_nesting_tokens_0} = $rnesting_tokens->[0];
+ $line_of_tokens->{_level_0} = $rlevels->[0];
+ $line_of_tokens->{_ci_level_0} = $rci_levels->[0];
+ $line_of_tokens->{_nesting_blocks_0} =
+ $line_of_tokens_old->{_nesting_blocks_0};
+ $line_of_tokens->{_nesting_tokens_0} =
+ $line_of_tokens_old->{_nesting_tokens_0};
+
} ## end if ( $jmax >= 0 )
$tee_output ||=
push @{$rlines_new}, $line_of_tokens;
return;
- }
+ } ## end sub write_line
} ## end closure write_line
#############################################
$self->[_save_logfile_] = $logger_object->get_save_logfile();
}
- $self->set_CODE_type();
+ my $rix_side_comments = $self->set_CODE_type();
+
+ $self->find_non_indenting_braces($rix_side_comments);
+
+ # Handle any requested side comment deletions. It is easier to get
+ # this done here rather than farther down the pipeline because IO
+ # lines take a different route, and because lines with deleted HSC
+ # become BL lines. We have already handled any tee requests in sub
+ # getline, so it is safe to delete side comments now.
+ $self->delete_side_comments($rix_side_comments)
+ if ( $rOpts_delete_side_comments
+ || $rOpts_delete_closing_side_comments );
# Verify that the line hash does not have any unknown keys.
$self->check_line_hashes() if (DEVEL_MODE);
# A final routine to tie up any loose ends
$self->wrapup();
return;
-}
+} ## end sub finish_formatting
sub set_CODE_type {
my ($self) = @_;
- # This routine performs two tasks:
-
- # TASK 1: Examine each line of code and set a flag '$CODE_type' to describe
- # any special processing that it requires.
-
- # TASK 2: Delete side comments if requested.
+ # Examine each line of code and set a flag '$CODE_type' to describe it.
+ # Also return a list of lines with side comments.
my $rLL = $self->[_rLL_];
my $Klimit = $self->[_Klimit_];
my ( $Kfirst, $Klast );
my $CODE_type;
- #------------------------------
- # TASK 1: Loop to set CODE_type
- #------------------------------
+ # Loop to set CODE_type
# Possible CODE_types
# 'VB' = Verbatim - line goes out verbatim (a quote)
# 'IO' = Indent Only - line goes out unchanged except for indentation
# 'NIN' = No Internal Newlines - line does not get broken
# 'VER' = VERSION statement
- # '' = ordinary line of code with no restructions
+ # '' = ordinary line of code with no restrictions
my $ix_line = -1;
foreach my $line_of_tokens ( @{$rlines} ) {
( $Kfirst, $Klast ) = @{$rK_range};
my $last_CODE_type = $CODE_type;
- $CODE_type = "";
+ $CODE_type = EMPTY_STRING;
my $input_line = $line_of_tokens->{_line_text};
my $jmax = defined($Kfirst) ? $Klast - $Kfirst : -1;
&& ( substr( $rLL->[$Kfirst]->[_TOKEN_], 0, 4 ) eq '#>>>'
|| $rOpts_format_skipping_end )
- && ( $rLL->[$Kfirst]->[_TOKEN_] . " " ) =~
+ && ( $rLL->[$Kfirst]->[_TOKEN_] . SPACE ) =~
/$format_skipping_pattern_end/
)
{
|| $rOpts_format_skipping_begin )
&& $rOpts_format_skipping
- && ( $rLL->[$Kfirst]->[_TOKEN_] . " " ) =~
+ && ( $rLL->[$Kfirst]->[_TOKEN_] . SPACE ) =~
/$format_skipping_pattern_begin/
)
{
# require Exporter; our $VERSION = $Exporter::VERSION;
# where both statements must be on a single line for MakeMaker
- my $is_VERSION_statement = 0;
if ( !$Saw_VERSION_in_this_file
&& $jmax < 80
&& $input_line =~
push @ix_side_comments, $ix_line;
}
- return
- if ( !$rOpts_delete_side_comments
- && !$rOpts_delete_closing_side_comments );
+ return \@ix_side_comments;
+} ## end sub set_CODE_type
- #-------------------------------------
- # TASK 2: Loop to delete side comments
- #-------------------------------------
+sub find_non_indenting_braces {
- # Handle any requested side comment deletions. It is easier to get
- # this done here rather than farther down the pipeline because IO
- # lines take a different route, and because lines with deleted HSC
- # become BL lines. We have already handled any tee requests in sub
- # getline, so it is safe to delete side comments now.
+ my ( $self, $rix_side_comments ) = @_;
+ return unless ( $rOpts->{'non-indenting-braces'} );
+ my $rLL = $self->[_rLL_];
+ my $Klimit = $self->[_Klimit_];
+ return unless ( defined($rLL) && @{$rLL} );
+ my $rlines = $self->[_rlines_];
+ my $rblock_type_of_seqno = $self->[_rblock_type_of_seqno_];
+ my $rseqno_non_indenting_brace_by_ix =
+ $self->[_rseqno_non_indenting_brace_by_ix_];
+
+ foreach my $ix ( @{$rix_side_comments} ) {
+ my $line_of_tokens = $rlines->[$ix];
+ my $line_type = $line_of_tokens->{_line_type};
+ if ( $line_type ne 'CODE' ) {
+
+ # shouldn't happen
+ next;
+ }
+ my $CODE_type = $line_of_tokens->{_code_type};
+ my $rK_range = $line_of_tokens->{_rK_range};
+ my ( $Kfirst, $Klast ) = @{$rK_range};
+ unless ( defined($Kfirst) && $rLL->[$Klast]->[_TYPE_] eq '#' ) {
+
+ # shouldn't happen
+ next;
+ }
+ next unless ( $Klast > $Kfirst ); # maybe HSC
+ my $token_sc = $rLL->[$Klast]->[_TOKEN_];
+ my $K_m = $Klast - 1;
+ my $type_m = $rLL->[$K_m]->[_TYPE_];
+ if ( $type_m eq 'b' && $K_m > $Kfirst ) {
+ $K_m--;
+ $type_m = $rLL->[$K_m]->[_TYPE_];
+ }
+ my $seqno_m = $rLL->[$K_m]->[_TYPE_SEQUENCE_];
+ if ($seqno_m) {
+ my $block_type_m = $rblock_type_of_seqno->{$seqno_m};
+
+ # The pattern ends in \s but we have removed the newline, so
+ # we added it back for the match. That way we require an exact
+ # match to the special string and also allow additional text.
+ $token_sc .= "\n";
+ if ( $block_type_m
+ && $is_opening_type{$type_m}
+ && $token_sc =~ /$non_indenting_brace_pattern/ )
+ {
+ $rseqno_non_indenting_brace_by_ix->{$ix} = $seqno_m;
+ }
+ }
+ }
+ return;
+} ## end sub find_non_indenting_braces
- # Also, we can get this done efficiently here.
+sub delete_side_comments {
+ my ( $self, $rix_side_comments ) = @_;
- foreach my $ix (@ix_side_comments) {
+ # Given a list of indexes of lines with side comments, handle any
+ # requested side comment deletions.
+
+ my $rLL = $self->[_rLL_];
+ my $rlines = $self->[_rlines_];
+ my $rblock_type_of_seqno = $self->[_rblock_type_of_seqno_];
+ my $rseqno_non_indenting_brace_by_ix =
+ $self->[_rseqno_non_indenting_brace_by_ix_];
+
+ foreach my $ix ( @{$rix_side_comments} ) {
my $line_of_tokens = $rlines->[$ix];
my $line_type = $line_of_tokens->{_line_type};
# side comments in the TASK 1 loop above.
if ( $line_type ne 'CODE' ) {
if (DEVEL_MODE) {
+ my $lno = $ix + 1;
Fault(<<EOM);
-Hit unexpected line_type = '$line_type' while deleting side comments, should be 'CODE'
+Hit unexpected line_type = '$line_type' near line $lno while deleting side comments, should be 'CODE'
EOM
}
next;
my $CODE_type = $line_of_tokens->{_code_type};
my $rK_range = $line_of_tokens->{_rK_range};
my ( $Kfirst, $Klast ) = @{$rK_range};
+
+ unless ( defined($Kfirst) && $rLL->[$Klast]->[_TYPE_] eq '#' ) {
+ if (DEVEL_MODE) {
+ my $lno = $ix + 1;
+ Fault(<<EOM);
+Did not find side comment near line $lno while deleting side comments
+EOM
+ }
+ next;
+ }
+
my $delete_side_comment =
$rOpts_delete_side_comments
- && defined($Kfirst)
- && $rLL->[$Klast]->[_TYPE_] eq '#'
&& ( $Klast > $Kfirst || $CODE_type eq 'HSC' )
&& (!$CODE_type
|| $CODE_type eq 'HSC'
|| $CODE_type eq 'IO'
|| $CODE_type eq 'NIN' );
+ # Do not delete special control side comments
+ if ( $rseqno_non_indenting_brace_by_ix->{$ix} ) {
+ $delete_side_comment = 0;
+ }
+
if (
$rOpts_delete_closing_side_comments
&& !$delete_side_comment
- && defined($Kfirst)
&& $Klast > $Kfirst
- && $rLL->[$Klast]->[_TYPE_] eq '#'
&& ( !$CODE_type
|| $CODE_type eq 'HSC'
|| $CODE_type eq 'IO'
# This may produce multiple blanks in a row, but sub respace_tokens
# will check for this and fix it.
$rLL->[$Klast]->[_TYPE_] = 'b';
- $rLL->[$Klast]->[_TOKEN_] = ' ';
+ $rLL->[$Klast]->[_TOKEN_] = SPACE;
# The -io option outputs the line text, so we have to update
# the line text so that the comment does not reappear.
if ( $CODE_type eq 'IO' ) {
- my $line = "";
+ my $line = EMPTY_STRING;
foreach my $KK ( $Kfirst .. $Klast - 1 ) {
$line .= $rLL->[$KK]->[_TOKEN_];
}
if ( $CODE_type eq 'HSC' ) { $line_of_tokens->{_code_type} = 'BL' }
}
}
-
return;
-}
+} ## end sub delete_side_comments
sub dump_verbatim {
my $self = shift;
my %is_sigil;
my %is_nonlist_keyword;
my %is_nonlist_type;
-my %is_special_check_type;
my %is_s_y_m_slash;
my %is_unexpected_equals;
my $Klast_old_code; # K of last token if side comment
my $Kmax = @{$rLL} - 1;
- my $CODE_type = "";
- my $line_type = "";
+ my $CODE_type = EMPTY_STRING;
+ my $line_type = EMPTY_STRING;
# Set the whitespace flags, which indicate the token spacing preference.
my $rwhitespace_flags = $self->set_whitespace_flags();
my $last_nonblank_code_type = ';';
my $last_nonblank_code_token = ';';
- my $last_nonblank_block_type = '';
+ my $last_nonblank_block_type = EMPTY_STRING;
my $last_last_nonblank_code_type = ';';
my $last_last_nonblank_code_token = ';';
# This will be the index of this item in the new array
my $KK_new = @{$rLL_new};
+ #------------------------------------------------------------------
+ # NOTE: called once per token so coding efficiency is critical here
+ #------------------------------------------------------------------
+
my $type = $item->[_TYPE_];
my $is_blank = $type eq 'b';
- my $block_type = "";
+ my $block_type = EMPTY_STRING;
# Do not output consecutive blanks. This situation should have been
# prevented earlier, but it is worth checking because later routines
# if the tokenizer has been changed to mark some other
# tokens with sequence numbers.
if (DEVEL_MODE) {
- my $type = $item->[_TYPE_];
Fault(
"Unexpected token type with sequence number: type='$type', seqno='$type_sequence'"
);
{
my $rcopy = [ @{$item} ];
$rcopy->[_TYPE_] = 'b';
- $rcopy->[_TOKEN_] = ' ';
- $rcopy->[_TYPE_SEQUENCE_] = '';
+ $rcopy->[_TOKEN_] = SPACE;
+ $rcopy->[_TYPE_SEQUENCE_] = EMPTY_STRING;
$rcopy->[_LINE_INDEX_] =
$rLL_new->[-1]->[_LINE_INDEX_];
# convert the blank into a semicolon..
# be careful: we are working on the new stack top
# on a token which has been stored.
- my $rcopy = copy_token_as_type( $rLL_new->[$Ktop], 'b', ' ' );
+ my $rcopy = copy_token_as_type( $rLL_new->[$Ktop], 'b', SPACE );
# Convert the existing blank to:
# a phantom semicolon for one_line_block option = 0 or 1
# a real semicolon for one_line_block option = 2
- my $tok = '';
+ my $tok = EMPTY_STRING;
my $len_tok = 0;
if ( $rOpts_one_line_block_semicolons == 2 ) {
$tok = ';';
}
}
- my $rcopy = copy_token_as_type( $rLL_new->[$Kp], ';', '' );
+ my $rcopy =
+ copy_token_as_type( $rLL_new->[$Kp], ';', EMPTY_STRING );
$store_token->($rcopy);
push @{$rK_phantom_semicolons}, @{$rLL_new} - 1;
}
# '$var = s/xxx/yyy/;'
# in case it should have been '$var =~ s/xxx/yyy/;'
- # Start by looking for a token begining with one of: s y m / tr
+ # Start by looking for a token beginning with one of: s y m / tr
return
unless ( $is_s_y_m_slash{ substr( $token, 0, 1 ) }
|| substr( $token, 0, 2 ) eq 'tr' );
my $previous_nonblank_token = $rLL_new->[$Kp]->[_TOKEN_];
my $previous_nonblank_type_2 = 'b';
- my $previous_nonblank_token_2 = "";
+ my $previous_nonblank_token_2 = EMPTY_STRING;
my $Kpp = $self->K_previous_nonblank( $Kp, $rLL_new );
if ( defined($Kpp) ) {
$previous_nonblank_type_2 = $rLL_new->[$Kpp]->[_TYPE_];
$previous_nonblank_token_2 = $rLL_new->[$Kpp]->[_TOKEN_];
}
- my $next_nonblank_token = "";
+ my $next_nonblank_token = EMPTY_STRING;
my $Kn = $KK + 1;
if ( $Kn <= $Kmax && $rLL->[$Kn]->[_TYPE_] eq 'b' ) { $Kn += 1 }
if ( $Kn <= $Kmax ) {
&& $next_nonblank_token =~ /^[; \)\}]$/
# scalar is not declared
- && !( $type_0 eq 'k' && $token_0 =~ /^(my|our|local)$/ )
+ ## =~ /^(my|our|local)$/
+ && !( $type_0 eq 'k' && $is_my_our_local{$token_0} )
)
{
my $lno = 1 + $rLL_new->[$Kp]->[_LINE_INDEX_];
# An error here means that sub write_line() did not correctly
# package the tokenized lines as it received them. If we
# get a fault here it has not output a continuous sequence
- # of K values. Or a line of CODE may have been mismarked as
+ # of K values. Or a line of CODE may have been mis-marked as
# something else. There is no good way to continue after such an
# error.
# FIXME: Calling Fault will produce zero output; it would be best to
if ( $CODE_type eq 'HSC' ) {
# Safety Check: This must be a line with one token (a comment)
- my $rtoken_vars = $rLL->[$Kfirst];
- if ( $Kfirst == $Klast && $rtoken_vars->[_TYPE_] eq '#' ) {
+ my $rvars_Kfirst = $rLL->[$Kfirst];
+ if ( $Kfirst == $Klast && $rvars_Kfirst->[_TYPE_] eq '#' ) {
# Note that even if the flag 'noadd-whitespace' is set, we
# will make an exception here and allow a blank to be
# hanging side comment from getting converted to a block
# comment if whitespace gets deleted, as for example with
# the -extrude and -mangle options.
- my $rcopy = copy_token_as_type( $rtoken_vars, 'q', '' );
+ my $rcopy =
+ copy_token_as_type( $rvars_Kfirst, 'q', EMPTY_STRING );
$store_token->($rcopy);
- $rcopy = copy_token_as_type( $rtoken_vars, 'b', ' ' );
+ $rcopy = copy_token_as_type( $rvars_Kfirst, 'b', SPACE );
$store_token->($rcopy);
- $store_token->($rtoken_vars);
+ $store_token->($rvars_Kfirst);
next;
}
else {
"Program bug. A hanging side comment has been mismarked"
) if (DEVEL_MODE);
- $CODE_type = "";
+ $CODE_type = EMPTY_STRING;
$line_of_tokens->{_code_type} = $CODE_type;
}
}
{
# Copy this first token as blank, but use previous line number
- my $rcopy = copy_token_as_type( $rLL->[$Kfirst], 'b', ' ' );
+ my $rcopy = copy_token_as_type( $rLL->[$Kfirst], 'b', SPACE );
$rcopy->[_LINE_INDEX_] =
$rLL_new->[-1]->[_LINE_INDEX_];
# Loop to copy all tokens on this line, with any changes
#-------------------------------------------------------
my $type_sequence;
- for ( my $KK = $Kfirst ; $KK <= $Klast ; $KK++ ) {
+ foreach my $KK ( $Kfirst .. $Klast ) {
$Ktoken_vars = $KK;
$rtoken_vars = $rLL->[$KK];
my $token = $rtoken_vars->[_TOKEN_];
}
# make it just one character
- $rtoken_vars->[_TOKEN_] = ' ';
+ $rtoken_vars->[_TOKEN_] = SPACE;
$store_token->($rtoken_vars);
next;
}
&& $want_left_space{'->'} == WS_YES )
{
my $rcopy =
- copy_token_as_type( $rtoken_vars, 'b', ' ' );
+ copy_token_as_type( $rtoken_vars, 'b', SPACE );
$store_token->($rcopy);
}
# store a blank after the arrow if requested
# added for issue git #33
if ( $want_right_space{'->'} == WS_YES ) {
- my $rcopy =
- copy_token_as_type( $rtoken_vars, 'b', ' ' );
- $store_token->($rcopy);
+ my $rcopy_b =
+ copy_token_as_type( $rtoken_vars, 'b', SPACE );
+ $store_token->($rcopy_b);
}
# then reset the current token to be the remainder,
# witch
# () # prototype may be on new line ...
# ...
- my $ord = ord( substr( $token, -1, 1 ) );
+ my $ord_ch = ord( substr( $token, -1, 1 ) );
if (
# quick check for possible ending space
- $ord > 0 && ( $ord < ORD_PRINTABLE_MIN
- || $ord > ORD_PRINTABLE_MAX )
+ $ord_ch > 0 && ( $ord_ch < ORD_PRINTABLE_MIN
+ || $ord_ch > ORD_PRINTABLE_MAX )
)
{
$token =~ s/\s+$//g;
# Remove unnecessary semicolons, but not after bare
# blocks, where it could be unsafe if the brace is
- # mistokenized.
+ # mis-tokenized.
if (
$rOpts->{'delete-semicolons'}
&& (
}
# Store this token with possible previous blank
- $store_token_and_space->(
- $rtoken_vars, $rwhitespace_flags->[$KK] == WS_YES
- );
+ if ( $rwhitespace_flags->[$KK] == WS_YES ) {
+ $store_token_and_space->( $rtoken_vars, 1 );
+ }
+ else {
+ $store_token->($rtoken_vars);
+ }
} # End token loop
} # End line loop
# Walk backwards through the tokens, making forward links to sequence items.
if ( @{$rLL_new} ) {
my $KNEXT;
- for ( my $KK = @{$rLL_new} - 1 ; $KK >= 0 ; $KK-- ) {
+ foreach my $KK ( reverse( 0 .. @{$rLL_new} - 1 ) ) {
$rLL_new->[$KK]->[_KNEXT_SEQ_ITEM_] = $KNEXT;
if ( $rLL_new->[$KK]->[_TYPE_SEQUENCE_] ) { $KNEXT = $KK }
}
# We will define a list to be a container with one or more commas
# and no semicolons. Note that we have included the semicolons
- # in a 'for' container in the simicolon count to keep c-style for
+ # in a 'for' container in the semicolon count to keep c-style for
# statements from being formatted as lists.
if ( ( $comma_count || $fat_comma_count ) && !$semicolon_count ) {
$is_list = 1;
- # We need to do one more check for a perenthesized list:
+ # We need to do one more check for a parenthesized list:
# At an opening paren following certain tokens, such as 'if',
# we do not want to format the contents as a list.
if ( $rLL_new->[$K_opening]->[_TOKEN_] eq '(' ) {
# container. This fixes case b1085. To find the corresponding code in
# Tokenizer.pm search for 'b1085' with an editor.
my $block_type = $rblock_type_of_seqno->{$seqno};
- if ( $block_type && substr( $block_type, -1, 1 ) eq ' ' ) {
+ if ( $block_type && substr( $block_type, -1, 1 ) eq SPACE ) {
# Always remove the trailing space
$block_type =~ s/\s+$//;
# Try to filter out parenless sub calls
- my ( $Knn1, $Knn2 );
- my ( $type_nn1, $type_nn2 ) = ( 'b', 'b' );
- $Knn1 = $self->K_next_nonblank( $K_opening, $rLL_new );
- $Knn2 = $self->K_next_nonblank( $Knn1, $rLL_new ) if defined($Knn1);
- $type_nn1 = $rLL_new->[$Knn1]->[_TYPE_] if ( defined($Knn1) );
- $type_nn2 = $rLL_new->[$Knn2]->[_TYPE_] if ( defined($Knn2) );
+ my $Knn1 = $self->K_next_nonblank( $K_opening, $rLL_new );
+ my $Knn2;
+ if ( defined($Knn1) ) {
+ $Knn2 = $self->K_next_nonblank( $Knn1, $rLL_new );
+ }
+ my $type_nn1 = defined($Knn1) ? $rLL_new->[$Knn1]->[_TYPE_] : 'b';
+ my $type_nn2 = defined($Knn2) ? $rLL_new->[$Knn2]->[_TYPE_] : 'b';
# if ( $type_nn1 =~ /^[wU]$/ && $type_nn2 =~ /^[wiqQGCZ]$/ ) {
if ( $wU{$type_nn1} && $wiq{$type_nn2} ) {
# Convert to a hash brace if it looks like it holds a list
if ($is_list) {
- $block_type = "";
+ $block_type = EMPTY_STRING;
$rLL_new->[$K_opening]->[_CI_LEVEL_] = 1;
$rLL_new->[$K_closing]->[_CI_LEVEL_] = 1;
$self->resync_lines_and_tokens();
return;
-}
+} ## end sub respace_tokens
sub copy_token_as_type {
# slightly modifying an existing token.
my ( $rold_token, $type, $token ) = @_;
if ( $type eq 'b' ) {
- $token = " " unless defined($token);
+ $token = SPACE unless defined($token);
}
elsif ( $type eq 'q' ) {
- $token = '' unless defined($token);
+ $token = EMPTY_STRING unless defined($token);
}
elsif ( $type eq '->' ) {
$token = '->' unless defined($token);
my @rnew_token = @{$rold_token};
$rnew_token[_TYPE_] = $type;
$rnew_token[_TOKEN_] = $token;
- $rnew_token[_TYPE_SEQUENCE_] = '';
+ $rnew_token[_TYPE_SEQUENCE_] = EMPTY_STRING;
return \@rnew_token;
-}
+} ## end sub copy_token_as_type
sub Debug_dump_tokens {
$K++;
}
return;
-}
+} ## end sub Debug_dump_tokens
sub K_next_code {
my ( $self, $KK, $rLL ) = @_;
$Knnb++;
}
return;
-}
+} ## end sub K_next_code
sub K_next_nonblank {
my ( $self, $KK, $rLL ) = @_;
$Knnb++;
}
return;
-}
+} ## end sub K_next_nonblank
sub K_previous_code {
$Kpnb--;
}
return;
-}
+} ## end sub K_previous_code
sub K_previous_nonblank {
$Kpnb--;
}
return;
-}
+} ## end sub K_previous_nonblank
sub parent_seqno_by_K {
}
$parent_seqno = SEQ_ROOT unless ( defined($parent_seqno) );
return $parent_seqno;
-}
+} ## end sub parent_seqno_by_K
sub is_in_block_by_i {
my ( $self, $i ) = @_;
return 1 if ( !$seqno || $seqno eq SEQ_ROOT );
return 1 if ( $self->[_rblock_type_of_seqno_]->{$seqno} );
return;
-}
+} ## end sub is_in_block_by_i
sub is_in_list_by_i {
my ( $self, $i ) = @_;
return 1;
}
return;
-}
+} ## end sub is_in_list_by_i
sub is_list_by_K {
# blank spaces). It must have set a bad old line index.
if ( DEVEL_MODE && defined($Klimit) ) {
my $iline = $rLL->[0]->[_LINE_INDEX_];
- for ( my $KK = 1 ; $KK <= $Klimit ; $KK++ ) {
+ foreach my $KK ( 1 .. $Klimit ) {
my $iline_last = $iline;
$iline = $rLL->[$KK]->[_LINE_INDEX_];
if ( $iline < $iline_last ) {
$is_assignment_or_fat_comma{'=>'} = 1;
my $ris_essential_old_breakpoint =
$self->[_ris_essential_old_breakpoint_];
- my $iline = -1;
my ( $Kfirst, $Klast );
foreach my $line_of_tokens ( @{$rlines} ) {
- $iline++;
my $line_type = $line_of_tokens->{_line_type};
if ( $line_type ne 'CODE' ) {
( $Kfirst, $Klast ) = ( undef, undef );
}
}
return;
-}
+} ## end sub resync_lines_and_tokens
sub keep_old_line_breaks {
);
}
return;
-}
+} ## end sub keep_old_line_breaks
sub weld_containers {
# flags.
my ($self) = @_;
- # This count is used to eliminate needless calls for weld checks elsewere
+ # This count is used to eliminate needless calls for weld checks elsewhere
$total_weld_count = 0;
return if ( $rOpts->{'indent-only'} );
}
return;
-}
+} ## end sub weld_containers
sub cumulative_length_before_K {
my ( $self, $KK ) = @_;
}
}
return;
-}
+} ## end sub weld_cuddled_blocks
sub find_nested_pairs {
my $self = shift;
# Count nonblank characters separating them.
if ( $K_diff < 0 ) { next } # Shouldn't happen
- my $Kn = $K_outer_opening;
my $nonblank_count = 0;
my $type;
my $is_name;
my $Kn_first = $K_outer_opening;
my $Kn_last_nonblank;
my $saw_comment;
- for (
- my $Kn = $K_outer_opening + 1 ;
- $Kn <= $K_inner_opening ;
- $Kn += 1
- )
- {
+ foreach my $Kn ( $K_outer_opening + 1 .. $K_inner_opening ) {
next if ( $rLL->[$Kn]->[_TYPE_] eq 'b' );
if ( !$nonblank_count ) { $Kn_first = $Kn }
if ( $Kn eq $K_inner_opening ) { $nonblank_count++; last; }
sort { $a->[2] <=> $b->[2] } @nested_pairs;
return \@nested_pairs;
-}
+} ## end sub find_nested_pairs
sub match_paren_flag {
elsif ( $flag eq 'w' ) { $match = $is_w }
elsif ( $flag eq 'W' ) { $match = !$is_w }
return $match;
-}
+} ## end sub match_paren_flag
sub is_excluded_weld {
return 0 unless ( defined($flag) );
return 1 if $flag eq '*';
return $self->match_paren_flag( $KK, $flag );
-}
+} ## end sub is_excluded_weld
# hashes to simplify welding logic
my %type_ok_after_bareword;
-my %is_ternary;
my %has_tight_paren;
BEGIN {
my @q = qw# => -> { ( [ #;
@type_ok_after_bareword{@q} = (1) x scalar(@q);
- @q = qw( ? : );
- @is_ternary{@q} = (1) x scalar(@q);
-
# these types do not 'like' to be separated from a following paren
@q = qw(w i q Q G C Z U);
@{has_tight_paren}{@q} = (1) x scalar(@q);
my $starting_ci;
my $starting_lentot;
my $maximum_text_length;
- my $msg = "";
+ my $msg = EMPTY_STRING;
my $iline_oo = $rLL->[$Kouter_opening]->[_LINE_INDEX_];
my $rK_range = $rlines->[$iline_oo]->{_rK_range};
# Fix for b1144 and b1112: backup to the first nonblank
# character before the =>, or to the start of its line.
if ( $type_prev eq '=>' ) {
- my $iline_prev = $rLL->[$Kprev]->[_LINE_INDEX_];
- my $rK_range = $rlines->[$iline_prev]->{_rK_range};
- my ( $Kfirst, $Klast ) = @{$rK_range};
- for ( my $KK = $Kref - 1 ; $KK >= $Kfirst ; $KK-- ) {
+ my $iline_prev = $rLL->[$Kprev]->[_LINE_INDEX_];
+ my $rK_range_prev = $rlines->[$iline_prev]->{_rK_range};
+ my ( $Kfirst_prev, $Klast_prev ) = @{$rK_range_prev};
+ foreach my $KK ( reverse( $Kfirst_prev .. $Kref - 1 ) ) {
next if ( $rLL->[$KK]->[_TYPE_] eq 'b' );
$Kref = $KK;
last;
}
}
return ( $new_weld_ok, $maximum_text_length, $starting_lentot, $msg );
-}
+} ## end sub setup_new_weld_measurements
sub excess_line_length_for_Krange {
my ( $self, $Kfirst, $Klast ) = @_;
&& print
"Kfirst=$Kfirst, Klast=$Klast, Kend=$Kend, level=$level, ci=$ci_level, max_text_length=$max_text_length, length=$length\n";
return ($excess_length);
-}
+} ## end sub excess_line_length_for_Krange
sub weld_nested_containers {
my ($self) = @_;
# Return unless there are nested pairs to weld
return unless defined($rnested_pairs) && @{$rnested_pairs};
+ # NOTE: It would be nice to apply RULE 5 right here by deleting unwanted
+ # pairs. But it isn't clear if this is possible because we don't know
+ # which sequences might actually start a weld.
+
+ # Setup a hash to avoid instabilities with combination -lp -wn -pvt=2.
+ # We do this by reducing -vt=2 to -vt=1 where there could be a conflict
+ # with welding at the same tokens.
+ # See issues b1338, b1339, b1340, b1341, b1342, b1343.
+ if ($rOpts_line_up_parentheses) {
+
+ # NOTE: just parens for now but this could be applied to all types if
+ # necessary.
+ if ( $opening_vertical_tightness{'('} == 2 ) {
+ my $rreduce_vertical_tightness_by_seqno =
+ $self->[_rreduce_vertical_tightness_by_seqno_];
+ foreach my $item ( @{$rnested_pairs} ) {
+ my ( $inner_seqno, $outer_seqno ) = @{$item};
+ if ( !$ris_excluded_lp_container->{$outer_seqno} ) {
+
+ # Set a flag which means that if a token has -vt=2
+ # then reduce it to -vt=1.
+ $rreduce_vertical_tightness_by_seqno->{$outer_seqno} = 1;
+ }
+ }
+ }
+ }
+
my $rOpts_break_at_old_method_breakpoints =
$rOpts->{'break-at-old-method-breakpoints'};
$previous_pair = $item;
my $do_not_weld_rule = 0;
- my $Msg = "";
+ my $Msg = EMPTY_STRING;
my $is_one_line_weld;
my $iline_oo = $outer_opening->[_LINE_INDEX_];
# more complicated method has been developed.
# We are trying to avoid creating bad two-line welds when we are
- # working on long, previously unwelded input text, such as
+ # working on long, previously un-welded input text, such as
# INPUT (example of a long input line weld candidate):
## $mutation->transpos( $self->RNA->position($mutation->label, $atg_label));
# if unbalanced (b1232)
if ( $Kouter_opening > $Kfirst && $level_oo > $level_first ) {
$Kstart = $Kouter_opening;
- for (
- my $KK = $Kouter_opening - 1 ;
- $KK > $Kfirst ;
- $KK -= 1
- )
+
+ foreach
+ my $KK ( reverse( $Kfirst + 1 .. $Kouter_opening - 1 ) )
{
next if ( $rLL->[$KK]->[_TYPE_] eq 'b' );
last if ( $rLL->[$KK]->[_LEVEL_] < $level_oo );
if ( $dlevel != 0 ) {
my $Kstart = $Kinner_opening;
my $Kstop = $Kinner_closing;
- for ( my $KK = $Kstart ; $KK <= $Kstop ; $KK++ ) {
+ foreach my $KK ( $Kstart .. $Kstop ) {
$rLL->[$KK]->[_LEVEL_] += $dlevel;
}
}
return;
-}
+} ## end sub weld_nested_containers
sub weld_nested_quotes {
);
# OK: This is a candidate for welding
- my $Msg = "";
+ my $Msg = EMPTY_STRING;
my $do_not_weld;
my $Kouter_opening = $K_opening_container->{$outer_seqno};
}
if (DEBUG_WELD) {
- if ( !$is_old_weld ) { $is_old_weld = "" }
+ if ( !$is_old_weld ) { $is_old_weld = EMPTY_STRING }
$Msg .=
"excess=$excess>=$excess_max, multiline_tol=$multiline_tol, is_old_weld='$is_old_weld'\n";
}
}
}
return;
-}
+} ## end sub weld_nested_quotes
sub is_welded_at_seqno {
return unless defined($KK_o);
return defined( $self->[_rK_weld_left_]->{$KK_o} )
|| defined( $self->[_rK_weld_right_]->{$KK_o} );
-}
+} ## end sub is_welded_at_seqno
sub mark_short_nested_blocks {
}
return;
-}
+} ## end sub mark_short_nested_blocks
sub adjust_indentation_levels {
}
# First set adjusted levels for any non-indenting braces.
- $self->non_indenting_braces();
+ $self->do_non_indenting_braces();
# Adjust breaks and indentation list containers
$self->break_before_list_opening_containers();
$self->clip_adjusted_levels();
return;
-}
+} ## end sub adjust_indentation_levels
sub clip_adjusted_levels {
return unless defined($radjusted_levels) && @{$radjusted_levels};
foreach ( @{$radjusted_levels} ) { $_ = 0 if ( $_ < 0 ) }
return;
-}
+} ## end sub clip_adjusted_levels
-sub non_indenting_braces {
+sub do_non_indenting_braces {
# Called once per file to handle the --non-indenting-braces parameter.
# Remove indentation within marked braces if requested
my ($self) = @_;
- return unless ( $rOpts->{'non-indenting-braces'} );
- my $rLL = $self->[_rLL_];
- return unless ( defined($rLL) && @{$rLL} );
+ # Any non-indenting braces have been found by sub find_non_indenting_braces
+ # and are defined by the following hash:
+ my $rseqno_non_indenting_brace_by_ix =
+ $self->[_rseqno_non_indenting_brace_by_ix_];
+ return unless ( %{$rseqno_non_indenting_brace_by_ix} );
- my $Klimit = $self->[_Klimit_];
- my $rblock_type_of_seqno = $self->[_rblock_type_of_seqno_];
+ my $rLL = $self->[_rLL_];
+ my $rlines = $self->[_rlines_];
my $K_opening_container = $self->[_K_opening_container_];
my $K_closing_container = $self->[_K_closing_container_];
my $rspecial_side_comment_type = $self->[_rspecial_side_comment_type_];
# First locate all of the marked blocks
my @K_stack;
- foreach my $seqno ( keys %{$rblock_type_of_seqno} ) {
- my $KK = $K_opening_container->{$seqno};
-
- # followed by a comment
- my $K_sc = $KK + 1;
- $K_sc += 1
- if ( $K_sc <= $Klimit && $rLL->[$K_sc]->[_TYPE_] eq 'b' );
- next unless ( $K_sc <= $Klimit );
- my $type_sc = $rLL->[$K_sc]->[_TYPE_];
- next unless ( $type_sc eq '#' );
-
- # on the same line
- my $line_index = $rLL->[$KK]->[_LINE_INDEX_];
- my $line_index_sc = $rLL->[$K_sc]->[_LINE_INDEX_];
- next unless ( $line_index_sc == $line_index );
-
- # get the side comment text
- my $token_sc = $rLL->[$K_sc]->[_TOKEN_];
-
- # The pattern ends in \s but we have removed the newline, so
- # we added it back for the match. That way we require an exact
- # match to the special string and also allow additional text.
- $token_sc .= "\n";
- next unless ( $token_sc =~ /$non_indenting_brace_pattern/ );
- $rspecial_side_comment_type->{$K_sc} = 'NIB';
+ foreach my $ix ( keys %{$rseqno_non_indenting_brace_by_ix} ) {
+ my $seqno = $rseqno_non_indenting_brace_by_ix->{$ix};
+ my $KK = $K_opening_container->{$seqno};
+ my $line_of_tokens = $rlines->[$ix];
+ my $rK_range = $line_of_tokens->{_rK_range};
+ my ( $Kfirst, $Klast ) = @{$rK_range};
+ $rspecial_side_comment_type->{$Klast} = 'NIB';
push @K_stack, [ $KK, 1 ];
my $Kc = $K_closing_container->{$seqno};
push @K_stack, [ $Kc, -1 ] if ( defined($Kc) );
$KK_last = $KK;
}
return;
-}
+} ## end sub do_non_indenting_braces
sub whitespace_cycle_adjustment {
my $whitespace_last_level = -1;
my @whitespace_level_stack = ();
my $last_nonblank_type = 'b';
- my $last_nonblank_token = '';
+ my $last_nonblank_token = EMPTY_STRING;
foreach my $KK ( 0 .. $Kmax ) {
my $level_abs = $radjusted_levels->[$KK];
my $level = $level_abs;
}
}
return;
-}
+} ## end sub whitespace_cycle_adjustment
use constant DEBUG_BBX => 0;
# break if this list contains a broken list with line-ending comma
my $ok_to_break;
- my $Msg = "";
+ my $Msg = EMPTY_STRING;
if ($has_list_with_lec) {
$ok_to_break = 1;
DEBUG_BBX && do { $Msg = "has list with lec;" };
next;
}
- # -bbxi=2 ...
+ # -bbxi=2: This option changes the level ...
+ # This option can conflict with -xci in some cases. We can turn off
+ # -xci for this container to avoid blinking. For now, only do this if
+ # -vmll is set. ( fixes b1335, b1336 )
+ if ($rOpts_variable_maximum_line_length) {
+ $rno_xci_by_seqno->{$seqno} = 1;
+ }
#----------------------------------------------------------------
# Part 2: Perform tests before committing to changing ci and level
}
# The last check we can make is to see if this container could fit on a
- # single line. Use the least possble indentation in the estmate (ci=0),
+ # single line. Use the least possible indentation estimate, ci=0,
# so we are not subtracting $ci * $rOpts_continuation_indentation from
- # tablulated $maximum_text_length value.
+ # tabulated $maximum_text_length value.
my $maximum_text_length = $maximum_text_length_at_level[$level];
my $K_closing = $K_closing_container->{$seqno};
my $length = $self->cumulative_length_before_K($K_closing) -
$rbreak_before_container_by_seqno;
$self->[_rwant_reduced_ci_] = $rwant_reduced_ci;
return;
-}
+} ## end sub break_before_list_opening_containers
use constant DEBUG_XCI => 0;
# The following variable can be used to allow a little extra space to
# avoid blinkers. A value $len_tol = 20 fixed the following
# fixes cases: b1025 b1026 b1027 b1028 b1029 b1030 but NOT b1031.
- # It turned out that the real problem was misparsing a list brace as
+ # It turned out that the real problem was mis-parsing a list brace as
# a code block in a 'use' statement when the line length was extremely
# small. A value of 0 works now, but a slightly larger value can
# be used to minimize the chance of a blinker.
my $space = $available_space{$seqno_top};
my $length = $rLL->[$KLAST]->[_CUMULATIVE_LENGTH_];
my $count = 0;
- for ( my $Kt = $KLAST + 1 ; $Kt < $KNEXT ; $Kt++ ) {
+ foreach my $Kt ( $KLAST + 1 .. $KNEXT - 1 ) {
# But do not include tokens which might exceed the line length
# and are not in a list.
$seqno_top = $seqno;
}
return;
-}
+} ## end sub extended_ci
sub braces_left_setup {
}
}
return;
-}
+} ## end sub braces_left_setup
sub bli_adjustment {
}
}
return;
-}
+} ## end sub bli_adjustment
sub find_multiline_qw {
# works well but is currently only activated when the -xci flag is set.
# The reason is to avoid unexpected changes in formatting.
if ($rOpts_extended_continuation_indentation) {
- while ( my ( $qw_seqno, $rKrange ) =
+ while ( my ( $qw_seqno_x, $rKrange ) =
each %{$rKrange_multiline_qw_by_seqno} )
{
my ( $Kbeg, $Kend ) = @{$rKrange};
}
# set flag for -wn option, which will remove the level
- $rmultiline_qw_has_extra_level->{$qw_seqno} = 1;
+ $rmultiline_qw_has_extra_level->{$qw_seqno_x} = 1;
}
}
# multiline quotes
if ( $rOpts_line_up_parentheses && !$rOpts_extended_line_up_parentheses ) {
- while ( my ( $qw_seqno, $rKrange ) =
+ while ( my ( $qw_seqno_x, $rKrange ) =
each %{$rKrange_multiline_qw_by_seqno} )
{
my ( $Kbeg, $Kend ) = @{$rKrange};
$self->[_rmultiline_qw_has_extra_level_] = $rmultiline_qw_has_extra_level;
return;
-}
+} ## end sub find_multiline_qw
use constant DEBUG_COLLAPSED_LENGTHS => 0;
# Minimum space reserved for contents of a code block. A value of 40 has given
# reasonable results. With a large line length, say -l=120, this will not
-# normally be noticable but it will prevent making a mess in some edge cases.
+# normally be noticeable but it will prevent making a mess in some edge cases.
use constant MIN_BLOCK_LEN => 40;
my %is_handle_type;
# limit.
# The basic idea is that at each node in the tree we imagine that we have a
- # fork with a handle and collapsable prongs:
+ # fork with a handle and collapsible prongs:
#
# |------------
# |--------
my $ris_permanently_broken = $self->[_ris_permanently_broken_];
my $ris_list_by_seqno = $self->[_ris_list_by_seqno_];
my $rhas_broken_list = $self->[_rhas_broken_list_];
+ my $rtype_count_by_seqno = $self->[_rtype_count_by_seqno_];
my $K_start_multiline_qw;
my $level_start_multiline_qw = 0;
my $max_prong_len = 0;
- my $handle_len = 0;
+ my $handle_len_x = 0;
my @stack;
my $len = 0;
my $last_nonblank_type = 'b';
push @stack,
- [ $max_prong_len, $handle_len, SEQ_ROOT, undef, undef, undef, undef ];
+ [ $max_prong_len, $handle_len_x, SEQ_ROOT, undef, undef, undef, undef ];
my $iline = -1;
foreach my $line_of_tokens ( @{$rlines} ) {
$level_start_multiline_qw =
$rLL->[$K_start_multiline_qw]->[_LEVEL_];
}
+ else {
+
+ # Fix for b1319, b1320
+ goto NOT_MULTILINE_QW;
+ }
}
}
next if ( $K_begin_loop > $K_last );
}
+
+ NOT_MULTILINE_QW:
$K_start_multiline_qw = undef;
# Find the terminal token, before any side comment
&& $K_terminal > $K_first );
}
- # Use length to terminal comma if interrupded list rule applies
+ # Use length to terminal comma if interrupted list rule applies
if ( @stack && $stack[-1]->[_interrupted_list_rule_] ) {
my $K_c = $stack[-1]->[_K_c_];
if (
defined($K_c)
&& $rLL->[$K_terminal]->[_TYPE_] eq ','
- # Ignore a terminal comma, causes instability (b1297)
- && ( $K_c - $K_terminal > 2
- || $rLL->[ $K_terminal + 1 ]->[_TYPE_] eq 'b' )
+ # Ignore if terminal comma, causes instability (b1297, b1330)
+ && (
+ $K_c - $K_terminal > 2
+ || ( $K_c - $K_terminal == 2
+ && $rLL->[ $K_terminal + 1 ]->[_TYPE_] ne 'b' )
+ )
)
{
my $Kend = $K_terminal;
## $Kend = $K_last;
##}
- $len = $rLL->[$Kend]->[_CUMULATIVE_LENGTH_] -
+ # changed from $len to my $leng to fix b1302 b1306 b1317 b1321
+ my $leng = $rLL->[$Kend]->[_CUMULATIVE_LENGTH_] -
$rLL->[ $K_first - 1 ]->[_CUMULATIVE_LENGTH_];
- if ( $len > $max_prong_len ) { $max_prong_len = $len }
+ # Fix for b1331: at a broken => item, include the length of
+ # the previous half of the item plus one for the missing space
+ if ( $last_nonblank_type eq '=>' ) {
+ $leng += $len + 1;
+ }
+
+ if ( $leng > $max_prong_len ) { $max_prong_len = $leng }
}
}
#----------------------------
# Entering a new container...
#----------------------------
- if ( $is_opening_token{$token} ) {
+ if ( $is_opening_token{$token}
+ && defined( $K_closing_container->{$seqno} ) )
+ {
# save current prong length
$stack[-1]->[_max_prong_len_] = $max_prong_len;
# stabilize by itself after one or two iterations.
# - So, not doing this for now
+ # Turn off the interrupted list rule if -vmll is set and a
+ # list has '=>' characters. This avoids instabilities due
+ # to dependence on old line breaks; issue b1325.
+ if ( $interrupted_list_rule
+ && $rOpts_variable_maximum_line_length )
+ {
+ my $rtype_count = $rtype_count_by_seqno->{$seqno};
+ if ( $rtype_count && $rtype_count->{'=>'} ) {
+ $interrupted_list_rule = 0;
+ }
+ }
+
# Include length to a comma ending this line
if ( $interrupted_list_rule
&& $rLL->[$K_terminal]->[_TYPE_] eq ',' )
{
my $Kend = $K_terminal;
- if ( $Kend < $K_last
- && !$rOpts_ignore_side_comment_lengths )
- {
- $Kend = $K_last;
- }
+
+ # fix for b1332: side comments handled at end of loop
+ ##if ( $Kend < $K_last
+ ## && !$rOpts_ignore_side_comment_lengths )
+ ##{
+ ## $Kend = $K_last;
+ ##}
# Measure from the next blank if any (fixes b1301)
my $Kbeg = $KK;
$Kbeg++;
}
- my $len = $rLL->[$Kend]->[_CUMULATIVE_LENGTH_] -
+ my $leng = $rLL->[$Kend]->[_CUMULATIVE_LENGTH_] -
$rLL->[$Kbeg]->[_CUMULATIVE_LENGTH_];
- if ( $len > $max_prong_len ) { $max_prong_len = $len }
+ if ( $leng > $max_prong_len ) { $max_prong_len = $leng }
}
my $K_c = $K_closing_container->{$seqno};
if ( $seqno_o ne $seqno ) {
- # Shouldn't happen - must have skipped some lines.
- # Not fatal but -lp formatting could get messed up.
- if (DEVEL_MODE) {
+ # This can happen if input file has brace errors.
+ # Otherwise it shouldn't happen. Not fatal but -lp
+ # formatting could get messed up.
+ if ( DEVEL_MODE && !get_saw_brace_error() ) {
Fault(<<EOM);
sequence numbers differ; at CLOSING line $iline, seq=$seqno, Kc=$KK .. at OPENING line $iline_o, seq=$seqno_o, Ko=$K_o, expecting Kc=$K_c_expect
EOM
#------------------------------------------
# Some test cases:
# c098/x107 x108 x110 x112 x114 x115 x117 x118 x119
- if ( $rblock_type_of_seqno->{$seqno} ) {
+ my $block_type = $rblock_type_of_seqno->{$seqno};
+ if ($block_type) {
my $K_c = $KK;
my $block_length = MIN_BLOCK_LEN;
my $is_one_line_block;
my $level = $rLL->[$K_o]->[_LEVEL_];
if ( defined($K_o) && defined($K_c) ) {
- my $block_length =
+
+ # note: fixed 3 May 2022 (removed 'my')
+ $block_length =
$rLL->[ $K_c - 1 ]->[_CUMULATIVE_LENGTH_] -
$rLL->[$K_o]->[_CUMULATIVE_LENGTH_];
$is_one_line_block = $iline == $iline_o;
# extremely long. We do not need to do a precise
# check here, because if it breaks then it will
# stay broken on later iterations.
- elsif ($is_one_line_block
+ elsif (
+ $is_one_line_block
&& $block_length <
- $maximum_line_length_at_level[$level] )
+ $maximum_line_length_at_level[$level]
+
+ # But skip this for sort/map/grep/eval blocks
+ # because they can reform (b1345)
+ && !$is_sort_map_grep_eval{$block_type}
+ )
{
$collapsed_len = $block_length;
}
if ( $len > $max_prong_len ) { $max_prong_len = $len }
# but only include one => per item
- if ( $last_nonblank_type eq '=>' ) { $len = $token_length }
+ $len = $token_length;
}
- # include everthing to end of line after a here target
+ # include everything to end of line after a here target
elsif ( $type eq 'h' ) {
$len = $rLL->[$K_last]->[_CUMULATIVE_LENGTH_] -
$rLL->[ $KK - 1 ]->[_CUMULATIVE_LENGTH_];
}
return;
-}
+} ## end sub collapsed_lengths
sub is_excluded_lp {
}
}
return $match_flag2;
-}
+} ## end sub is_excluded_lp
sub set_excluded_lp_containers {
}
}
return;
-}
+} ## end sub set_excluded_lp_containers
######################################
# CODE SECTION 6: Process line-by-line
# set locations for blanks around long runs of keywords
my $rwant_blank_line_after = $self->keyword_group_scan();
- my $line_type = "";
+ my $line_type = EMPTY_STRING;
my $i_last_POD_END = -10;
my $i = -1;
foreach my $line_of_tokens ( @{$rlines} ) {
# Turn this option off so that this message does not keep repeating
# during iterations and other files.
- $rOpts->{'keyword-group-blanks-size'} = "";
+ $rOpts->{'keyword-group-blanks-size'} = EMPTY_STRING;
return $rhash_of_desires;
}
$Opt_size_min = 1 unless ($Opt_size_min);
# Definitions:
# ($ibeg, $iend) = starting and ending line indexes of this entire group
# $count = total number of keywords seen in this entire group
- # $level_beg = indententation level of this group
+ # $level_beg = indentation level of this group
# @group = [ $i, $token, $count ] =list of all keywords & blanks
# @subgroup = $j, index of group where token changes
# @iblanks = line indexes of blank lines in input stream in this group
push @subgroup, scalar @group;
my $kbeg = 1;
my $kend = @subgroup - 1;
- for ( my $k = $kbeg ; $k <= $kend ; $k++ ) {
+ foreach my $k ( $kbeg .. $kend ) {
# index j runs through all keywords found
my $j_b = $subgroup[ $k - 1 ];
# delete line $i if it is blank
return unless ( $i >= 0 && $i < @{$rlines} );
- my $line_type = $rlines->[$i]->{_line_type};
- return if ( $line_type ne 'CODE' );
+ return if ( $rlines->[$i]->{_line_type} ne 'CODE' );
my $code_type = $rlines->[$i]->{_code_type};
if ( $code_type eq 'BL' ) { $rhash_of_desires->{$i} = 2; }
return;
if ( $Opt_repeat_count > 0
&& $number_of_groups_seen >= $Opt_repeat_count );
- $CODE_type = "";
+ $CODE_type = EMPTY_STRING;
$K_first = undef;
$K_last = undef;
$line_type = $line_of_tokens->{_line_type};
elsif ( $ibeg >= 0 ) {
# - bail out on a large level change; we may have walked into a
- # data structure or anoymous sub code.
+ # data structure or anonymous sub code.
if ( $level > $level_beg + 1 || $level < $level_beg ) {
$end_group->(1);
next;
# past stored nonblank tokens and flags
my (
- $K_last_nonblank_code, $K_last_last_nonblank_code,
- $looking_for_else, $is_static_block_comment,
- $batch_CODE_type, $last_line_had_side_comment,
- $next_parent_seqno, $next_slevel,
+ $K_last_nonblank_code, $looking_for_else,
+ $is_static_block_comment, $last_CODE_type,
+ $last_line_had_side_comment, $next_parent_seqno,
+ $next_slevel,
);
# Called once at the start of a new file
sub initialize_process_line_of_CODE {
$K_last_nonblank_code = undef;
- $K_last_last_nonblank_code = undef;
$looking_for_else = 0;
$is_static_block_comment = 0;
- $batch_CODE_type = "";
$last_line_had_side_comment = 0;
$next_parent_seqno = SEQ_ROOT;
$next_slevel = undef;
# Called before the start of each new batch
sub initialize_batch_variables {
- $max_index_to_go = UNDEFINED_INDEX;
- @summed_lengths_to_go = @nesting_depth_to_go = (0);
+ $max_index_to_go = UNDEFINED_INDEX;
+ $summed_lengths_to_go[0] = 0;
+ $nesting_depth_to_go[0] = 0;
+ ##@summed_lengths_to_go = @nesting_depth_to_go = (0);
$ri_starting_one_line_block = [];
# The initialization code for the remaining batch arrays is as follows
0 && do { #<<<
@block_type_to_go = ();
@type_sequence_to_go = ();
- @bond_strength_to_go = ();
@forced_breakpoint_to_go = ();
@token_lengths_to_go = ();
@levels_to_go = ();
$rbrace_follower = undef;
$ending_in_quote = 0;
- destroy_one_line_block();
+
+ # These get re-initialized by calls to sub destroy_one_line_block():
+ $index_start_one_line_block = UNDEFINED_INDEX;
+ $semicolons_before_block_self_destruct = 0;
+
+ # initialize forced breakpoint vars associated with each output batch
+ $forced_breakpoint_count = 0;
+ $index_max_forced_break = UNDEFINED_INDEX;
+ $forced_breakpoint_undo_count = 0;
+
return;
- }
+ } ## end sub initialize_batch_variables
sub leading_spaces_to_go {
return 0 if ( $ii < 0 );
my $indentation = $leading_spaces_to_go[$ii];
return ref($indentation) ? $indentation->get_spaces() : $indentation;
- }
+ } ## end sub leading_spaces_to_go
sub create_one_line_block {
( $index_start_one_line_block, $semicolons_before_block_self_destruct )
# $rtoken_vars = $rLL->[$Ktoken_vars] = the corresponding token values
# unless they are temporarily being overridden
+ #------------------------------------------------------------------
+ # NOTE: called once per token so coding efficiency is critical here
+ #------------------------------------------------------------------
+
my $type = $rtoken_vars->[_TYPE_];
# Check for emergency flush...
# if ( $_ =~ /PENCIL/ ) { $pencil_flag= 1 } ; ;
# $yy=1;
if ( $max_index_to_go >= 0 ) {
- my $Klast = $K_to_go[$max_index_to_go];
- if ( $Ktoken_vars != $Klast + 1 ) {
+ if ( $Ktoken_vars != $K_to_go[$max_index_to_go] + 1 ) {
$self->flush_batch_of_CODE();
}
if ( $type eq 'b' ) { return }
}
- ++$max_index_to_go;
- $batch_CODE_type = $CODE_type;
- $K_to_go[$max_index_to_go] = $Ktoken_vars;
+ #----------------------------
+ # add this token to the batch
+ #----------------------------
+ $K_to_go[ ++$max_index_to_go ] = $Ktoken_vars;
$types_to_go[$max_index_to_go] = $type;
$old_breakpoint_to_go[$max_index_to_go] = 0;
$mate_index_to_go[$max_index_to_go] = -1;
my $token = $tokens_to_go[$max_index_to_go] = $rtoken_vars->[_TOKEN_];
+
my $ci_level = $ci_levels_to_go[$max_index_to_go] =
$rtoken_vars->[_CI_LEVEL_];
my $seqno = $type_sequence_to_go[$max_index_to_go] =
$rtoken_vars->[_TYPE_SEQUENCE_];
+ my $in_continued_quote =
+ ( $Ktoken_vars == $K_first ) && $line_of_tokens->{_starting_in_quote};
+
+ # Initializations for first token of new batch
if ( $max_index_to_go == 0 ) {
+ $starting_in_quote = $in_continued_quote;
+
# Update the next parent sequence number for each new batch.
- #------------------------------------------
- # Begin coding from sub parent_seqno_from_K
- #------------------------------------------
+ #----------------------------------------
+ # Begin coding from sub parent_seqno_by_K
+ #----------------------------------------
+
+ # The following is equivalent to this call but much faster:
+ # $next_parent_seqno = $self->parent_seqno_by_K($Ktoken_vars);
- ## $next_parent_seqno = $self->parent_seqno_by_K($Ktoken_vars);
$next_parent_seqno = SEQ_ROOT;
if ($seqno) {
$next_parent_seqno = $rparent_of_seqno->{$seqno};
else {
my $Kt = $rLL->[$Ktoken_vars]->[_KNEXT_SEQ_ITEM_];
if ( defined($Kt) ) {
- my $type_sequence = $rLL->[$Kt]->[_TYPE_SEQUENCE_];
- my $type = $rLL->[$Kt]->[_TYPE_];
+ my $type_sequence_t = $rLL->[$Kt]->[_TYPE_SEQUENCE_];
+ my $type_t = $rLL->[$Kt]->[_TYPE_];
# if next container token is closing, it is the parent seqno
- if ( $is_closing_type{$type} ) {
- $next_parent_seqno = $type_sequence;
+ if ( $is_closing_type{$type_t} ) {
+ $next_parent_seqno = $type_sequence_t;
}
# otherwise we want its parent container
else {
$next_parent_seqno =
- $rparent_of_seqno->{$type_sequence};
+ $rparent_of_seqno->{$type_sequence_t};
}
}
}
$next_parent_seqno = SEQ_ROOT
unless ( defined($next_parent_seqno) );
- #----------------------------------------
- # End coding from sub parent_seqno_from_K
- #----------------------------------------
+ #--------------------------------------
+ # End coding from sub parent_seqno_by_K
+ #--------------------------------------
$next_slevel = $rdepth_of_opening_seqno->[$next_parent_seqno] + 1;
}
# Initialize some sequence-dependent variables to their normal values
- my $parent_seqno = $next_parent_seqno;
- my $slevel = $next_slevel;
- my $block_type = "";
+ $parent_seqno_to_go[$max_index_to_go] = $next_parent_seqno;
+ $nesting_depth_to_go[$max_index_to_go] = $next_slevel;
+ $block_type_to_go[$max_index_to_go] = EMPTY_STRING;
# Then fix them at container tokens:
if ($seqno) {
+
+ $block_type_to_go[$max_index_to_go] =
+ $rblock_type_of_seqno->{$seqno}
+ if ( $rblock_type_of_seqno->{$seqno} );
+
if ( $is_opening_token{$token} ) {
+
+ my $slevel = $rdepth_of_opening_seqno->[$seqno];
+ $nesting_depth_to_go[$max_index_to_go] = $slevel;
+ $next_slevel = $slevel + 1;
+
$next_parent_seqno = $seqno;
- $slevel = $rdepth_of_opening_seqno->[$seqno];
- $next_slevel = $slevel + 1;
- $block_type = $rblock_type_of_seqno->{$seqno};
+
}
elsif ( $is_closing_token{$token} ) {
- $next_slevel = $rdepth_of_opening_seqno->[$seqno];
- $slevel = $next_slevel + 1;
- $block_type = $rblock_type_of_seqno->{$seqno};
- $parent_seqno = $rparent_of_seqno->{$seqno};
- $parent_seqno = SEQ_ROOT unless defined($parent_seqno);
- $next_parent_seqno = $parent_seqno;
+
+ $next_slevel = $rdepth_of_opening_seqno->[$seqno];
+ my $slevel = $next_slevel + 1;
+ $nesting_depth_to_go[$max_index_to_go] = $slevel;
+
+ my $parent_seqno = $rparent_of_seqno->{$seqno};
+ $parent_seqno = SEQ_ROOT unless defined($parent_seqno);
+ $parent_seqno_to_go[$max_index_to_go] = $parent_seqno;
+ $next_parent_seqno = $parent_seqno;
+
}
else {
# ternary token: nothing to do
}
- $block_type = "" unless ( defined($block_type) );
}
- $parent_seqno_to_go[$max_index_to_go] = $parent_seqno;
- $nesting_depth_to_go[$max_index_to_go] = $slevel;
- $block_type_to_go[$max_index_to_go] = $block_type;
- $nobreak_to_go[$max_index_to_go] = $no_internal_newlines;
+ $nobreak_to_go[$max_index_to_go] = $no_internal_newlines;
my $length = $rtoken_vars->[_TOKEN_LENGTH_];
# but we will use the character count to have a defined value. In the
# future, it would be nicer to have 'respace_tokens' convert the lines
# to quotes and get correct lengths.
- if ( !defined($length) ) { $length = length($token) }
+ if ( !defined($length) ) {
+ $length = length($token);
+ }
$token_lengths_to_go[$max_index_to_go] = $length;
$summed_lengths_to_go[ $max_index_to_go + 1 ] =
$summed_lengths_to_go[$max_index_to_go] + $length;
- my $in_continued_quote =
- ( $Ktoken_vars == $K_first ) && $line_of_tokens->{_starting_in_quote};
- if ( $max_index_to_go == 0 ) {
- $starting_in_quote = $in_continued_quote;
- }
-
# Define the indentation that this token will have in two cases:
# Without CI = reduced_spaces_to_go
# With CI = leading_spaces_to_go
$reduced_spaces_to_go[$max_index_to_go] = 0;
}
else {
- $reduced_spaces_to_go[$max_index_to_go] = my $reduced_spaces =
- $rOpts_indent_columns * $radjusted_levels->[$Ktoken_vars];
$leading_spaces_to_go[$max_index_to_go] =
- $reduced_spaces + $rOpts_continuation_indentation * $ci_level;
+ $reduced_spaces_to_go[$max_index_to_go] =
+ $rOpts_indent_columns * $radjusted_levels->[$Ktoken_vars];
+
+ $leading_spaces_to_go[$max_index_to_go] +=
+ $rOpts_continuation_indentation * $ci_level
+ if ($ci_level);
}
- $standard_spaces_to_go[$max_index_to_go] =
- $leading_spaces_to_go[$max_index_to_go];
DEBUG_STORE && do {
my ( $a, $b, $c ) = caller();
"STORE: from $a $c: storing token $token type $type lev=$level at $max_index_to_go\n";
};
return;
- }
+ } ## end sub store_token_to_go
sub flush_batch_of_CODE {
# This must be the only call to grind_batch_of_CODE()
my ($self) = @_;
- return unless ( $max_index_to_go >= 0 );
+ if ( $max_index_to_go >= 0 ) {
+
+ # Create an array to hold variables for this batch
+ my $this_batch = [];
+
+ $this_batch->[_starting_in_quote_] = 1 if ($starting_in_quote);
+ $this_batch->[_ending_in_quote_] = 1 if ($ending_in_quote);
- # Create an array to hold variables for this batch
- my $this_batch = [];
- $this_batch->[_starting_in_quote_] = $starting_in_quote;
- $this_batch->[_ending_in_quote_] = $ending_in_quote;
- $this_batch->[_max_index_to_go_] = $max_index_to_go;
- $this_batch->[_batch_CODE_type_] = $batch_CODE_type;
+ if ( $CODE_type || $last_CODE_type ) {
+ $this_batch->[_batch_CODE_type_] =
+ $K_to_go[$max_index_to_go] >= $K_first
+ ? $CODE_type
+ : $last_CODE_type;
+ }
- # The flag $is_static_block_comment applies to the line which just
- # arrived. So it only applies if we are outputting that line.
- $this_batch->[_is_static_block_comment_] =
- defined($K_first)
- && $max_index_to_go == 0
- && $K_to_go[0] == $K_first ? $is_static_block_comment : 0;
+ $last_line_had_side_comment =
+ ( $max_index_to_go > 0 && $types_to_go[$max_index_to_go] eq '#' );
- $this_batch->[_ri_starting_one_line_block_] =
- $ri_starting_one_line_block;
+ # The flag $is_static_block_comment applies to the line which just
+ # arrived. So it only applies if we are outputting that line.
+ if ( $is_static_block_comment && !$last_line_had_side_comment ) {
+ $this_batch->[_is_static_block_comment_] =
+ $K_to_go[0] == $K_first;
+ }
- $self->[_this_batch_] = $this_batch;
+ $this_batch->[_ri_starting_one_line_block_] =
+ $ri_starting_one_line_block;
- $last_line_had_side_comment =
- $max_index_to_go > 0 && $types_to_go[$max_index_to_go] eq '#';
+ $self->[_this_batch_] = $this_batch;
- $self->grind_batch_of_CODE();
+ $self->grind_batch_of_CODE();
- # Done .. this batch is history
- $self->[_this_batch_] = [];
+ # Done .. this batch is history
+ $self->[_this_batch_] = undef;
- initialize_batch_variables();
- initialize_forced_breakpoint_vars();
+ initialize_batch_variables();
+ }
return;
- }
+ } ## end sub flush_batch_of_CODE
sub end_batch {
if ( $max_index_to_go < 0 ) {
- # This is harmless but should be elimintated in development
+ # This is harmless but should be eliminated in development
if (DEVEL_MODE) {
Fault("End batch called with nothing to do; please fix\n");
}
$self->flush_batch_of_CODE();
return;
- }
+ } ## end sub end_batch
sub flush_vertical_aligner {
my ($self) = @_;
# flush is called to output any tokens in the pipeline, so that
# an alternate source of lines can be written in the correct order
sub flush {
- my ( $self, $CODE_type ) = @_;
+ my ( $self, $CODE_type_flush ) = @_;
# end the current batch with 1 exception
# Exception: if we are flushing within the code stream only to insert
# blank line(s), then we can keep the batch intact at a weld. This
# improves formatting of -ce. See test 'ce1.ce'
- if ( $CODE_type && $CODE_type eq 'BL' ) {
+ if ( $CODE_type_flush && $CODE_type_flush eq 'BL' ) {
$self->end_batch() if ( $max_index_to_go >= 0 );
}
$self->flush_vertical_aligner();
return;
- }
+ } ## end sub flush
sub process_line_of_CODE {
# So this routine is just making an initial set of required line
# breaks, basically regardless of the maximum requested line length.
- # The subsequent stage of formating make additional line breaks
+ # The subsequent stage of formatting make additional line breaks
# appropriate for lists and logical structures, and to keep line
# lengths below the requested maximum line length.
# begin initialize closure variables
#-----------------------------------
$line_of_tokens = $my_line_of_tokens;
- $CODE_type = $line_of_tokens->{_code_type};
my $rK_range = $line_of_tokens->{_rK_range};
- ( $K_first, $K_last ) = @{$rK_range};
- if ( !defined($K_first) ) {
+ if ( !defined( $rK_range->[0] ) ) {
# Empty line: This can happen if tokens are deleted, for example
# with the -mangle parameter
return;
}
+
+ ( $K_first, $K_last ) = @{$rK_range};
+ $last_CODE_type = $CODE_type;
+ $CODE_type = $line_of_tokens->{_code_type};
+
$rLL = $self->[_rLL_];
$radjusted_levels = $self->[_radjusted_levels_];
$rparent_of_seqno = $self->[_rparent_of_seqno_];
my $input_line = $line_of_tokens->{_line_text};
- my $is_comment =
- ( $K_first == $K_last && $rLL->[$K_first]->[_TYPE_] eq '#' );
+ my ( $is_block_comment, $has_side_comment );
+ if ( $rLL->[$K_last]->[_TYPE_] eq '#' ) {
+ if ( $K_last == $K_first ) { $is_block_comment = 1 }
+ else { $has_side_comment = 1 }
+ }
+
my $is_static_block_comment_without_leading_space =
$CODE_type eq 'SBCX';
$is_static_block_comment =
$CODE_type eq 'SBC' || $is_static_block_comment_without_leading_space;
- my $is_hanging_side_comment = $CODE_type eq 'HSC';
- my $is_VERSION_statement = $CODE_type eq 'VER';
- if ($is_VERSION_statement) {
+ # check for a $VERSION statement
+ if ( $CODE_type eq 'VER' ) {
$self->[_saw_VERSION_in_this_file_] = 1;
$no_internal_newlines = 2;
}
# Add interline blank if any
my $last_old_nonblank_type = "b";
- my $first_new_nonblank_token = "";
+ my $first_new_nonblank_token = EMPTY_STRING;
my $K_first_true = $K_first;
if ( $max_index_to_go >= 0 ) {
$last_old_nonblank_type = $types_to_go[$max_index_to_go];
$first_new_nonblank_token = $rLL->[$K_first]->[_TOKEN_];
- if ( !$is_comment
+ if ( !$is_block_comment
&& $types_to_go[$max_index_to_go] ne 'b'
&& $K_first > 0
&& $rLL->[ $K_first - 1 ]->[_TYPE_] eq 'b' )
#------------------------------------
# Handle a block (full-line) comment.
#------------------------------------
- if ($is_comment) {
+ if ($is_block_comment) {
if ( $rOpts->{'delete-block-comments'} ) {
$self->flush();
return;
}
- # compare input/output indentation except for continuation lines
- # (because they have an unknown amount of initial blank space)
- # and lines which are quotes (because they may have been outdented)
+ # Compare input/output indentation except for:
+ # - hanging side comments
+ # - continuation lines (have unknown amount of initial blank space)
+ # - and lines which are quotes (because they may have been outdented)
my $guessed_indentation_level =
$line_of_tokens->{_guessed_indentation_level};
- unless ( $is_hanging_side_comment
+
+ unless ( $CODE_type eq 'HSC'
|| $rtok_first->[_CI_LEVEL_] > 0
|| $guessed_indentation_level == 0 && $rtok_first->[_TYPE_] eq 'Q' )
{
# if we do not see another elseif or an else.
if ($looking_for_else) {
- unless ( $rLL->[$K_first]->[_TOKEN_] =~ /^(elsif|else)$/ ) {
+ ## /^(elsif|else)$/
+ if ( !$is_elsif_else{ $rLL->[$K_first_true]->[_TOKEN_] } ) {
write_logfile_entry("(No else block)\n");
}
$looking_for_else = 0;
#--------------------------------------
# We do not want a leading blank if the previous batch just got output
+
if ( $max_index_to_go < 0 && $rLL->[$K_first]->[_TYPE_] eq 'b' ) {
$K_first++;
}
foreach my $Ktoken_vars ( $K_first .. $K_last ) {
my $rtoken_vars = $rLL->[$Ktoken_vars];
- my $type = $rtoken_vars->[_TYPE_];
+
+ #--------------
+ # handle blanks
+ #--------------
+ if ( $rtoken_vars->[_TYPE_] eq 'b' ) {
+ $self->store_token_to_go( $Ktoken_vars, $rtoken_vars );
+ next;
+ }
+
+ #------------------
+ # handle non-blanks
+ #------------------
+ my $type = $rtoken_vars->[_TYPE_];
# If we are continuing after seeing a right curly brace, flush
# buffer unless we see what we are looking for, as in
# } else ...
- if ( $rbrace_follower && $type ne 'b' ) {
+ if ($rbrace_follower) {
my $token = $rtoken_vars->[_TOKEN_];
unless ( $rbrace_follower->{$token} ) {
$self->end_batch() if ( $max_index_to_go >= 0 );
$is_opening_BLOCK, $is_closing_BLOCK,
$nobreak_BEFORE_BLOCK
);
+
if ( $rtoken_vars->[_TYPE_SEQUENCE_] ) {
my $token = $rtoken_vars->[_TOKEN_];
}
}
- # Find next nonblank token on this line and look for a side comment
- my ( $Knnb, $side_comment_follows );
-
- # if before last token ...
- if ( $Ktoken_vars < $K_last ) {
- $Knnb = $Ktoken_vars + 1;
- if ( $Knnb < $K_last
- && $rLL->[$Knnb]->[_TYPE_] eq 'b' )
- {
- $Knnb++;
- }
-
- if ( $rLL->[$Knnb]->[_TYPE_] eq '#' ) {
- $side_comment_follows = 1;
-
- # Do not allow breaks which would promote a side comment to
- # a block comment.
- $no_internal_newlines = 2;
- }
- }
-
# if at last token ...
- else {
+ if ( $Ktoken_vars == $K_last ) {
#---------------------
# handle side comments
#---------------------
- if ( $type eq '#' ) {
+ if ($has_side_comment) {
$self->store_token_to_go( $Ktoken_vars, $rtoken_vars );
next;
}
}
- #--------------
- # handle blanks
- #--------------
- if ( $type eq 'b' ) {
- $self->store_token_to_go( $Ktoken_vars, $rtoken_vars );
- next;
+ # if before last token ... do not allow breaks which would promote
+ # a side comment to a block comment
+ elsif (
+ $has_side_comment
+ && ( $Ktoken_vars == $K_last - 1
+ || $Ktoken_vars == $K_last - 2
+ && $rLL->[ $K_last - 1 ]->[_TYPE_] eq 'b' )
+ )
+ {
+ $no_internal_newlines = 2;
}
# Process non-blank and non-comment tokens ...
if ( $type eq ';' ) {
my $next_nonblank_token_type = 'b';
- my $next_nonblank_token = '';
- if ( defined($Knnb) ) {
+ my $next_nonblank_token = EMPTY_STRING;
+ if ( $Ktoken_vars < $K_last ) {
+ my $Knnb = $Ktoken_vars + 1;
+ $Knnb++ if ( $rLL->[$Knnb]->[_TYPE_] eq 'b' );
$next_nonblank_token = $rLL->[$Knnb]->[_TOKEN_];
$next_nonblank_token_type = $rLL->[$Knnb]->[_TYPE_];
}
&& $Ktoken_vars < $K_last )
|| ( $next_nonblank_token eq '}' )
);
-
}
#-----------
elsif ($is_closing_BLOCK) {
my $next_nonblank_token_type = 'b';
- my $next_nonblank_token = '';
- if ( defined($Knnb) ) {
+ my $next_nonblank_token = EMPTY_STRING;
+ my $Knnb;
+ if ( $Ktoken_vars < $K_last ) {
+ $Knnb = $Ktoken_vars + 1;
+ $Knnb++ if ( $rLL->[$Knnb]->[_TYPE_] eq 'b' );
$next_nonblank_token = $rLL->[$Knnb]->[_TOKEN_];
$next_nonblank_token_type = $rLL->[$Knnb]->[_TYPE_];
}
# brace then we must include its length in the length test
# ... unless the -issl flag is set (fixes b1307-1309).
# Assume a minimum of 1 blank space to the comment.
- my $added_length =
- $side_comment_follows
- && !$rOpts_ignore_side_comment_lengths
- ? 1 + $rLL->[$Knnb]->[_TOKEN_LENGTH_]
- : 0;
+ my $added_length = 0;
+ if ( $has_side_comment
+ && !$rOpts_ignore_side_comment_lengths
+ && $next_nonblank_token_type eq '#' )
+ {
+ $added_length = 1 + $rLL->[$K_last]->[_TOKEN_LENGTH_];
+ }
# we have to terminate it if..
if (
# set string indicating what we need to look for brace follower
# tokens
- if ( $block_type eq 'do' ) {
+ if ( $is_if_unless_elsif_else{$block_type} ) {
+ $rbrace_follower = undef;
+ }
+ elsif ( $block_type eq 'do' ) {
$rbrace_follower = \%is_do_follower;
if (
$self->tight_paren_follows( $K_to_go[0], $Ktoken_vars )
)
{
$rbrace_follower = { ')' => 1 };
- }
- }
- elsif ( $block_type =~ /^(if|elsif|unless)$/ ) {
- $rbrace_follower = \%is_if_brace_follower;
- }
- elsif ( $block_type eq 'else' ) {
- $rbrace_follower = \%is_else_brace_follower;
+ }
}
# added eval for borris.t
$looking_for_else = 1; # ok, check on next line
}
else {
-
- unless ( $next_nonblank_token =~ /^(elsif|else)$/ ) {
+ ## /^(elsif|else)$/
+ if ( !$is_elsif_else{$next_nonblank_token} ) {
write_logfile_entry("No else block :(\n");
}
}
# keep going
}
- # if no more tokens, postpone decision until re-entring
+ # if no more tokens, postpone decision until re-entering
elsif ( ( $next_nonblank_token_type eq 'b' )
&& $rOpts_add_newlines )
{
unless ($rbrace_follower) {
$self->end_batch()
- unless ($no_internal_newlines);
+ unless ( $no_internal_newlines
+ || $max_index_to_go < 0 );
}
}
-
elsif ($rbrace_follower) {
unless ( $rbrace_follower->{$next_nonblank_token} ) {
$self->store_token_to_go( $Ktoken_vars, $rtoken_vars );
# break after a label if requested
- if ( $type eq 'J' && $rOpts_break_after_labels == 1 ) {
+ if ( $rOpts_break_after_labels
+ && $type eq 'J'
+ && $rOpts_break_after_labels == 1 )
+ {
$self->end_batch()
unless ($no_internal_newlines);
}
}
- # remember two previous nonblank, non-comment OUTPUT tokens
- $K_last_last_nonblank_code = $K_last_nonblank_code;
- $K_last_nonblank_code = $Ktoken_vars;
+ # remember previous nonblank, non-comment OUTPUT token
+ $K_last_nonblank_code = $Ktoken_vars;
} ## end of loop over all tokens in this line
- my $type = $rLL->[$K_last]->[_TYPE_];
- my $break_flag = $self->[_rbreak_after_Klast_]->{$K_last};
-
- # we have to flush ..
- if (
+ # if there is anything left in the output buffer ...
+ if ( $max_index_to_go >= 0 ) {
- # if there is a side comment...
- $type eq '#'
-
- # if this line ends in a quote
- # NOTE: This is critically important for insuring that quoted lines
- # do not get processed by things like -sot and -sct
- || $in_quote
-
- # if this is a VERSION statement
- || $is_VERSION_statement
-
- # to keep a label at the end of a line
- || ( $type eq 'J' && $rOpts_break_after_labels != 2 )
-
- # if we have a hard break request
- || $break_flag && $break_flag != 2
-
- # if we are instructed to keep all old line breaks
- || !$rOpts->{'delete-old-newlines'}
-
- # if this is a line of the form 'use overload'. A break here
- # in the input file is a good break because it will allow
- # the operators which follow to be formatted well. Without
- # this break the formatting with -ci=4 -xci is poor, for example.
-
- # use overload
- # '+' => sub {
- # print length $_[2], "\n";
- # my ( $x, $y ) = _order(@_);
- # Number::Roman->new( int $x + $y );
- # },
- # '-' => sub {
- # my ( $x, $y ) = _order(@_);
- # Number::Roman->new( int $x - $y );
- # };
- || ( $max_index_to_go == 2
- && $types_to_go[0] eq 'k'
- && $tokens_to_go[0] eq 'use'
- && $tokens_to_go[$max_index_to_go] eq 'overload' )
- )
- {
- destroy_one_line_block();
- $self->end_batch() if ( $max_index_to_go >= 0 );
- }
+ my $type = $rLL->[$K_last]->[_TYPE_];
+ my $break_flag = $self->[_rbreak_after_Klast_]->{$K_last};
- # Check for a soft break request
- if ( $max_index_to_go >= 0 && $break_flag && $break_flag == 2 ) {
- $self->set_forced_breakpoint($max_index_to_go);
- }
+ # we have to flush ..
+ if (
- # mark old line breakpoints in current output stream
- if (
- $max_index_to_go >= 0
- && ( !$rOpts_ignore_old_breakpoints
- || $self->[_ris_essential_old_breakpoint_]->{$K_last} )
- )
- {
- my $jobp = $max_index_to_go;
- if ( $types_to_go[$max_index_to_go] eq 'b' && $max_index_to_go > 0 )
+ # if there is a side comment...
+ $type eq '#'
+
+ # if this line ends in a quote
+ # NOTE: This is critically important for insuring that quoted
+ # lines do not get processed by things like -sot and -sct
+ || $in_quote
+
+ # if this is a VERSION statement
+ || $CODE_type eq 'VER'
+
+ # to keep a label at the end of a line
+ || ( $type eq 'J' && $rOpts_break_after_labels != 2 )
+
+ # if we have a hard break request
+ || $break_flag && $break_flag != 2
+
+ # if we are instructed to keep all old line breaks
+ || !$rOpts->{'delete-old-newlines'}
+
+ # if this is a line of the form 'use overload'. A break here in
+ # the input file is a good break because it will allow the
+ # operators which follow to be formatted well. Without this
+ # break the formatting with -ci=4 -xci is poor, for example.
+
+ # use overload
+ # '+' => sub {
+ # print length $_[2], "\n";
+ # my ( $x, $y ) = _order(@_);
+ # Number::Roman->new( int $x + $y );
+ # },
+ # '-' => sub {
+ # my ( $x, $y ) = _order(@_);
+ # Number::Roman->new( int $x - $y );
+ # };
+ || ( $max_index_to_go == 2
+ && $types_to_go[0] eq 'k'
+ && $tokens_to_go[0] eq 'use'
+ && $tokens_to_go[$max_index_to_go] eq 'overload' )
+ )
{
- $jobp--;
+ destroy_one_line_block();
+ $self->end_batch();
+ }
+
+ else {
+
+ # Check for a soft break request
+ if ( $break_flag && $break_flag == 2 ) {
+ $self->set_forced_breakpoint($max_index_to_go);
+ }
+
+ # mark old line breakpoints in current output stream
+ if ( !$rOpts_ignore_old_breakpoints
+ || $self->[_ris_essential_old_breakpoint_]->{$K_last} )
+ {
+ my $jobp = $max_index_to_go;
+ if ( $types_to_go[$max_index_to_go] eq 'b'
+ && $max_index_to_go > 0 )
+ {
+ $jobp--;
+ }
+ $old_breakpoint_to_go[$jobp] = 1;
+ }
}
- $old_breakpoint_to_go[$jobp] = 1;
}
+
return;
} ## end sub process_line_of_CODE
} ## end closure process_line_of_CODE
# OK to keep the paren tight
return 1;
-}
+} ## end sub tight_paren_follows
my %is_brace_semicolon_colon;
}
# Return if block should be broken
- my $type_sequence = $rLL->[$Kj]->[_TYPE_SEQUENCE_];
- if ( $rbreak_container->{$type_sequence} ) {
+ my $type_sequence_j = $rLL->[$Kj]->[_TYPE_SEQUENCE_];
+ if ( $rbreak_container->{$type_sequence_j} ) {
return 0;
}
my $ris_bli_container = $self->[_ris_bli_container_];
- my $is_bli = $ris_bli_container->{$type_sequence};
+ my $is_bli = $ris_bli_container->{$type_sequence_j};
- my $block_type = $rblock_type_of_seqno->{$type_sequence};
- $block_type = "" unless ( defined($block_type) );
- my $index_max_forced_break = get_index_max_forced_break();
+ my $block_type = $rblock_type_of_seqno->{$type_sequence_j};
+ $block_type = EMPTY_STRING unless ( defined($block_type) );
- my $previous_nonblank_token = '';
+ my $previous_nonblank_token = EMPTY_STRING;
my $i_last_nonblank = -1;
if ( defined($K_last_nonblank) ) {
$i_last_nonblank = $K_last_nonblank - $K_to_go[0];
elsif (
$i_last_nonblank >= 0
&& ( $previous_nonblank_token eq $block_type
- || $self->[_ris_asub_block_]->{$type_sequence}
- || $self->[_ris_sub_block_]->{$type_sequence}
+ || $self->[_ris_asub_block_]->{$type_sequence_j}
+ || $self->[_ris_sub_block_]->{$type_sequence_j}
|| substr( $block_type, -2, 2 ) eq '()' )
)
{
# For signatures and extended syntax ...
# If this brace follows a parenthesized list, we should look back to
# find the keyword before the opening paren because otherwise we might
- # form a one line block which stays intack, and cause the parenthesized
+ # form a one line block which stays intact, and cause the parenthesized
# expression to break open. That looks bad.
if ( $tokens_to_go[$i_start] eq ')' ) {
# See if everything to the closing token will fit on one line
# This is part of an update to fix cases b562 .. b983
- my $K_closing = $self->[_K_closing_container_]->{$type_sequence};
+ my $K_closing = $self->[_K_closing_container_]->{$type_sequence_j};
return 0 unless ( defined($K_closing) );
my $container_length = $rLL->[$K_closing]->[_CUMULATIVE_LENGTH_] -
$rLL->[$Kj]->[_CUMULATIVE_LENGTH_];
my $excess = $pos + 1 + $container_length - $maximum_line_length;
# Add a small tolerance for welded tokens (case b901)
- if ( $total_weld_count && $self->is_welded_at_seqno($type_sequence) ) {
+ if ( $total_weld_count && $self->is_welded_at_seqno($type_sequence_j) ) {
$excess += 2;
}
else { $pos += $rLL->[$Ki]->[_TOKEN_LENGTH_] }
# ignore some small blocks
- my $type_sequence = $rLL->[$Ki]->[_TYPE_SEQUENCE_];
- my $nobreak = $rshort_nested->{$type_sequence};
+ my $type_sequence_i = $rLL->[$Ki]->[_TYPE_SEQUENCE_];
+ my $nobreak = $rshort_nested->{$type_sequence_i};
# Return false result if we exceed the maximum line length,
if ( $pos > $maximum_line_length ) {
}
# keep going for non-containers
- elsif ( !$type_sequence ) {
+ elsif ( !$type_sequence_i ) {
}
# closing brace.
elsif ($rLL->[$Ki]->[_TOKEN_] eq '{'
&& $rLL->[$Ki]->[_TYPE_] eq '{'
- && $rblock_type_of_seqno->{$type_sequence}
+ && $rblock_type_of_seqno->{$type_sequence_i}
&& !$nobreak )
{
return 0;
# if we find our closing brace..
elsif ($rLL->[$Ki]->[_TOKEN_] eq '}'
&& $rLL->[$Ki]->[_TYPE_] eq '}'
- && $rblock_type_of_seqno->{$type_sequence}
+ && $rblock_type_of_seqno->{$type_sequence_i}
&& !$nobreak )
{
# ; # very long comment......
# so we do not need to include the length of the comment, which
# would break the block. Project 'bioperl' has coding like this.
- if ( $block_type !~ /^(if|else|elsif|unless)$/
+ ## !~ /^(if|else|elsif|unless)$/
+ if ( !$is_if_unless_elsif_else{$block_type}
|| $K_last == $Ki_nonblank )
{
$Ki_nonblank = $K_last;
create_one_line_block( $i_start, 1 );
}
return 0;
-}
+} ## end sub starting_one_line_block
sub unstore_token_to_go {
$max_index_to_go = UNDEFINED_INDEX;
}
return;
-}
+} ## end sub unstore_token_to_go
sub compare_indentation_levels {
}
}
return;
-}
+} ## end sub compare_indentation_levels
###################################################
# CODE SECTION 8: Utilities for setting breakpoints
{ ## begin closure set_forced_breakpoint
- my $forced_breakpoint_count;
- my $forced_breakpoint_undo_count;
my @forced_breakpoint_undo_stack;
- my $index_max_forced_break;
+
+ # These are global vars for efficiency:
+ # my $forced_breakpoint_count;
+ # my $forced_breakpoint_undo_count;
+ # my $index_max_forced_break;
# Break before or after certain tokens based on user settings
my %break_before_or_after_token;
@break_before_or_after_token{@q} = (1) x scalar(@q);
}
+ # This is no longer called - global vars - moved into initialize_batch_vars
sub initialize_forced_breakpoint_vars {
$forced_breakpoint_count = 0;
$index_max_forced_break = UNDEFINED_INDEX;
$forced_breakpoint_undo_count = 0;
- @forced_breakpoint_undo_stack = ();
+ ##@forced_breakpoint_undo_stack = (); # not needed
return;
}
- sub get_forced_breakpoint_count {
- return $forced_breakpoint_count;
- }
-
- sub get_forced_breakpoint_undo_count {
- return $forced_breakpoint_undo_count;
- }
-
- sub get_index_max_forced_break {
- return $index_max_forced_break;
- }
-
sub set_fake_breakpoint {
# Just bump up the breakpoint count as a signal that there are breaks.
my $msg =
"FORCE $forced_breakpoint_count after call from $a $c with i=$i max=$max_index_to_go";
if ( !defined($i_nonblank) ) {
- $i = "" unless defined($i);
+ $i = EMPTY_STRING unless defined($i);
$msg .= " but could not set break after i='$i'\n";
}
else {
};
return $i_nonblank;
- }
+ } ## end sub set_forced_breakpoint
sub set_forced_breakpoint_AFTER {
my ( $self, $i ) = @_;
}
}
return;
- }
+ } ## end sub set_forced_breakpoint_AFTER
sub clear_breakpoint_undo_stack {
my ($self) = @_;
}
}
return;
- }
+ } ## end sub undo_forced_breakpoint_stack
} ## end closure set_forced_breakpoint
{ ## begin closure set_closing_breakpoint
}
}
return;
- }
+ } ## end sub set_closing_breakpoint
} ## end closure set_closing_breakpoint
#########################################
# - 'grind_batch_of_CODE' determines which tokens will form the OUTPUT
# lines.
- # So sub 'process_line_of_CODE' builds up the longest possible continouus
+ # So sub 'process_line_of_CODE' builds up the longest possible continuous
# sequences of tokens, regardless of line length, and then
# grind_batch_of_CODE breaks these sequences back down into the new output
# lines.
}
my $Klimit = $self->[_Klimit_];
- # The local batch tokens must be a continous part of the global token
+ # The local batch tokens must be a continuous part of the global token
# array.
my $KK;
foreach my $ii ( 0 .. $max_index_to_go ) {
}
}
return;
- }
+ } ## end sub check_grind_input
sub grind_batch_of_CODE {
# This routine is only called from sub flush_batch_of_code, so that
# routine is a better spot for debugging.
DEBUG_GRIND && do {
- my $token = my $type = "";
+ my $token = my $type = EMPTY_STRING;
if ( $max_index_to_go >= 0 ) {
$token = $tokens_to_go[$max_index_to_go];
$type = $types_to_go[$max_index_to_go];
}
- my $output_str = "";
+ my $output_str = EMPTY_STRING;
if ( $max_index_to_go > 20 ) {
my $mm = $max_index_to_go - 10;
- $output_str = join( "", @tokens_to_go[ 0 .. 10 ] ) . " ... "
- . join( "", @tokens_to_go[ $mm .. $max_index_to_go ] );
+ $output_str =
+ join( EMPTY_STRING, @tokens_to_go[ 0 .. 10 ] ) . " ... "
+ . join( EMPTY_STRING,
+ @tokens_to_go[ $mm .. $max_index_to_go ] );
}
else {
- $output_str = join "", @tokens_to_go[ 0 .. $max_index_to_go ];
+ $output_str = join EMPTY_STRING,
+ @tokens_to_go[ 0 .. $max_index_to_go ];
}
print STDERR <<EOM;
grind got batch number $batch_count with $max_index_to_go tokens, last type '$type' tok='$token', text:
my $ris_seqno_controlling_ci = $self->[_ris_seqno_controlling_ci_];
my $rwant_container_open = $self->[_rwant_container_open_];
- my $starting_in_quote = $this_batch->[_starting_in_quote_];
- my $ending_in_quote = $this_batch->[_ending_in_quote_];
- my $is_static_block_comment = $this_batch->[_is_static_block_comment_];
-
#-------------------------------------------------------
# Loop over the batch to initialize some batch variables
#-------------------------------------------------------
my $ilast_nonblank = -1;
my @colon_list;
my @ix_seqno_controlling_ci;
- my %comma_arrow_count = ();
+ my %comma_arrow_count;
my $comma_arrow_count_contained = 0;
my @unmatched_closing_indexes_in_this_batch;
@unmatched_opening_indexes_in_this_batch = ();
- for ( my $i = 0 ; $i <= $max_index_to_go ; $i++ ) {
- $bond_strength_to_go[$i] = 0;
- $iprev_to_go[$i] = $ilast_nonblank;
- $inext_to_go[$i] = $i + 1;
+ foreach my $i ( 0 .. $max_index_to_go ) {
+ $iprev_to_go[$i] = $ilast_nonblank;
+ $inext_to_go[$i] = $i + 1;
my $type = $types_to_go[$i];
if ( $type ne 'b' ) {
{
$mate_index_to_go[$i] = $i_mate;
$mate_index_to_go[$i_mate] = $i;
- my $seqno = $type_sequence_to_go[$i];
if ( $comma_arrow_count{$seqno} ) {
$comma_arrow_count_contained +=
$comma_arrow_count{$seqno};
# Walk backwards from the end and
# set break at any closing block braces at the same level.
# But quit if we are not in a chain of blocks.
- for ( my $i = $max_index_to_go - 1 ; $i >= 0 ; $i-- ) {
+ foreach my $i ( reverse( 0 .. $max_index_to_go - 1 ) ) {
last if ( $levels_to_go[$i] < $lev ); # stop at a lower level
next if ( $levels_to_go[$i] > $lev ); # skip past higher level
if ( $imin > $imax ) {
if (DEVEL_MODE) {
my $K0 = $K_to_go[0];
- my $lno = "";
+ my $lno = EMPTY_STRING;
if ( defined($K0) ) { $lno = $rLL->[$K0]->[_LINE_INDEX_] + 1 }
Fault(<<EOM);
Strange: received batch containing only blanks near input line $lno: after trimming imin=$imin, imax=$imax
my $leading_token = $tokens_to_go[$imin];
my $leading_type = $types_to_go[$imin];
- # blank lines before subs except declarations and one-liners
- if ( $leading_type eq 'i' ) {
- if (
-
- # quick check
- (
- substr( $leading_token, 0, 3 ) eq 'sub'
- || $rOpts_sub_alias_list
- )
-
- # slow check
- && $leading_token =~ /$SUB_PATTERN/
- )
- {
- $want_blank = $rOpts->{'blank-lines-before-subs'}
- if ( terminal_type_i( $imin, $imax ) !~ /^[\;\}\,]$/ );
- }
-
- # break before all package declarations
- elsif ( substr( $leading_token, 0, 8 ) eq 'package ' ) {
- $want_blank = $rOpts->{'blank-lines-before-packages'};
- }
- }
-
# break before certain key blocks except one-liners
if ( $leading_type eq 'k' ) {
if ( $leading_token eq 'BEGIN' || $leading_token eq 'END' ) {
}
}
+ # blank lines before subs except declarations and one-liners
+ elsif ( $leading_type eq 'i' ) {
+ if (
+
+ # quick check
+ (
+ substr( $leading_token, 0, 3 ) eq 'sub'
+ || $rOpts_sub_alias_list
+ )
+
+ # slow check
+ && $leading_token =~ /$SUB_PATTERN/
+ )
+ {
+ $want_blank = $rOpts->{'blank-lines-before-subs'}
+ if ( terminal_type_i( $imin, $imax ) !~ /^[\;\}\,]$/ );
+ }
+
+ # break before all package declarations
+ elsif ( substr( $leading_token, 0, 8 ) eq 'package ' ) {
+ $want_blank = $rOpts->{'blank-lines-before-packages'};
+ }
+ }
+
# Check for blank lines wanted before a closing brace
- if ( $leading_token eq '}' ) {
+ elsif ( $leading_token eq '}' ) {
if ( $rOpts->{'blank-lines-before-closing-block'}
&& $block_type_to_go[$imin]
&& $block_type_to_go[$imin] =~
$rLL->[$Kend]->[_LINE_INDEX_] - $rLL->[$Kbeg]->[_LINE_INDEX_];
}
+ my $rbond_strength_bias = [];
if (
$is_long_line
|| $old_line_count_in_batch > 1
$self->pad_array_to_go();
$called_pad_array_to_go = 1;
- my $sgb = $self->break_lists($is_long_line);
+ my $sgb = $self->break_lists( $is_long_line, $rbond_strength_bias );
$saw_good_break ||= $sgb;
}
&& !$saw_good_break
# and we don't already have an interior breakpoint
- && !get_forced_breakpoint_count()
+ && !$forced_breakpoint_count
)
)
{
# already done so
$self->pad_array_to_go() unless ($called_pad_array_to_go);
- ( $ri_first, $ri_last ) =
- $self->break_long_lines( $saw_good_break, \@colon_list );
+ ( $ri_first, $ri_last, my $rbond_strength_to_go ) =
+ $self->break_long_lines( $saw_good_break, \@colon_list,
+ $rbond_strength_bias );
$self->break_all_chain_tokens( $ri_first, $ri_last );
# now we do a correction step to clean this up a bit
# (The only time we would not do this is for debugging)
- $self->recombine_breakpoints( $ri_first, $ri_last )
+ $self->recombine_breakpoints( $ri_first, $ri_last,
+ $rbond_strength_to_go )
if ( $rOpts_recombine && @{$ri_first} > 1 );
$self->insert_final_ternary_breaks( $ri_first, $ri_last )
}
return;
- }
+ } ## end sub grind_batch_of_CODE
sub save_opening_indentation {
];
}
return;
- }
+ } ## end sub save_opening_indentation
sub get_saved_opening_indentation {
my ($seqno) = @_;
# (example is badfile.t)
return ( $indent, $offset, $is_leading, $exists );
- }
+ } ## end sub get_saved_opening_indentation
} ## end closure grind_batch_of_CODE
sub lookup_opening_indentation {
my $offset = token_sequence_length( $ibeg, $i_opening ) - 1;
my $is_leading = ( $ibeg == $i_opening );
return ( $rindentation_list->[ $nline + 1 ], $offset, $is_leading );
-}
+} ## end sub lookup_opening_indentation
sub terminal_type_i {
$type_i = 'b';
}
return wantarray ? ( $type_i, $i ) : $type_i;
-}
+} ## end sub terminal_type_i
sub pad_array_to_go {
# some undef's to help guard against using invalid data.
my ($self) = @_;
$K_to_go[ $max_index_to_go + 1 ] = undef;
- $tokens_to_go[ $max_index_to_go + 1 ] = '';
- $tokens_to_go[ $max_index_to_go + 2 ] = '';
+ $tokens_to_go[ $max_index_to_go + 1 ] = EMPTY_STRING;
+ $tokens_to_go[ $max_index_to_go + 2 ] = EMPTY_STRING;
$tokens_to_go[ $max_index_to_go + 3 ] = undef;
$types_to_go[ $max_index_to_go + 1 ] = 'b';
$types_to_go[ $max_index_to_go + 2 ] = 'b';
$nesting_depth_to_go[ $max_index_to_go + 1 ] += 1;
}
return;
-}
+} ## end sub pad_array_to_go
sub break_all_chain_tokens {
$typer = '+' if ( $typer eq '-' );
$typel = '*' if ( $typel eq '/' ); # treat * and / the same
$typer = '*' if ( $typer eq '/' );
- my $tokenl = $tokens_to_go[$il];
- my $tokenr = $tokens_to_go[$ir];
- if ( $is_chain_operator{$tokenl} && $want_break_before{$typel} ) {
+ my $keyl = $typel eq 'k' ? $tokens_to_go[$il] : $typel;
+ my $keyr = $typer eq 'k' ? $tokens_to_go[$ir] : $typer;
+ if ( $is_chain_operator{$keyl} && $want_break_before{$typel} ) {
next if ( $typel eq '?' );
- push @{ $left_chain_type{$typel} }, $il;
- $saw_chain_type{$typel} = 1;
+ push @{ $left_chain_type{$keyl} }, $il;
+ $saw_chain_type{$keyl} = 1;
$count++;
}
- if ( $is_chain_operator{$tokenr} && !$want_break_before{$typer} ) {
+ if ( $is_chain_operator{$keyr} && !$want_break_before{$typer} ) {
next if ( $typer eq '?' );
- push @{ $right_chain_type{$typer} }, $ir;
- $saw_chain_type{$typer} = 1;
+ push @{ $right_chain_type{$keyr} }, $ir;
+ $saw_chain_type{$keyr} = 1;
$count++;
}
}
my $ir = $ri_right->[$n];
foreach my $i ( $il + 1 .. $ir - 1 ) {
my $type = $types_to_go[$i];
- $type = '+' if ( $type eq '-' );
- $type = '*' if ( $type eq '/' );
- if ( $saw_chain_type{$type} ) {
- push @{ $interior_chain_type{$type} }, $i;
+ my $key = $type eq 'k' ? $tokens_to_go[$i] : $type;
+ $key = '+' if ( $key eq '-' );
+ $key = '*' if ( $key eq '/' );
+ if ( $saw_chain_type{$key} ) {
+ push @{ $interior_chain_type{$key} }, $i;
$count++;
}
}
my @insert_list;
# loop over all chain types
- foreach my $type ( keys %saw_chain_type ) {
+ foreach my $key ( keys %saw_chain_type ) {
# quit if just ONE continuation line with leading . For example--
# print LATEXFILE '\framebox{\parbox[c][' . $h . '][t]{' . $w . '}{'
# . $contents;
- last if ( $nmax == 1 && $type =~ /^[\.\+]$/ );
+ last if ( $nmax == 1 && $key =~ /^[\.\+]$/ );
# loop over all interior chain tokens
- foreach my $itest ( @{ $interior_chain_type{$type} } ) {
+ foreach my $itest ( @{ $interior_chain_type{$key} } ) {
# loop over all left end tokens of same type
- if ( $left_chain_type{$type} ) {
+ if ( $left_chain_type{$key} ) {
next if $nobreak_to_go[ $itest - 1 ];
- foreach my $i ( @{ $left_chain_type{$type} } ) {
+ foreach my $i ( @{ $left_chain_type{$key} } ) {
next unless $self->in_same_container_i( $i, $itest );
push @insert_list, $itest - 1;
# ( $_ & 1 ) ? ( $_ & 4 ) ? $THRf_DEAD : $THRf_ZOMBIE
# : ( $_ & 4 ) ? $THRf_R_DETACHED
# : $THRf_R_JOINABLE;
- if ( $type eq ':'
+ if ( $key eq ':'
&& $levels_to_go[$i] != $levels_to_go[$itest] )
{
my $i_question = $mate_index_to_go[$itest];
}
# loop over all right end tokens of same type
- if ( $right_chain_type{$type} ) {
+ if ( $right_chain_type{$key} ) {
next if $nobreak_to_go[$itest];
- foreach my $i ( @{ $right_chain_type{$type} } ) {
+ foreach my $i ( @{ $right_chain_type{$key} } ) {
next unless $self->in_same_container_i( $i, $itest );
push @insert_list, $itest;
# break at matching ? if this : is at a different level
- if ( $type eq ':'
+ if ( $key eq ':'
&& $levels_to_go[$i] != $levels_to_go[$itest] )
{
my $i_question = $mate_index_to_go[$itest];
$self->insert_additional_breaks( \@insert_list, $ri_left, $ri_right );
}
return;
-}
+} ## end sub break_all_chain_tokens
sub insert_additional_breaks {
}
}
return;
-}
+} ## end sub insert_additional_breaks
{ ## begin closure in_same_container_i
my $ris_break_token;
return if ( $rbreak->{$tok_i} );
}
return 1;
- }
+ } ## end sub in_same_container_i
} ## end closure in_same_container_i
sub break_equals {
return unless ( $nmax >= 2 );
# scan the left ends of first two lines
- my $tokbeg = "";
+ my $tokbeg = EMPTY_STRING;
my $depth_beg;
for my $n ( 1 .. 2 ) {
my $il = $ri_left->[$n];
my $typel = $types_to_go[$il];
my $tokenl = $tokens_to_go[$il];
+ my $keyl = $typel eq 'k' ? $tokenl : $typel;
- my $has_leading_op = ( $tokenl =~ /^\w/ )
- ? $is_chain_operator{$tokenl} # + - * / : ? && ||
- : $is_chain_operator{$typel}; # and, or
+ my $has_leading_op = $is_chain_operator{$keyl};
return unless ($has_leading_op);
if ( $n > 1 ) {
return
# now make a list of all new break points
my @insert_list;
- for ( my $i = $ir - 1 ; $i > $il ; $i-- ) {
+ foreach my $i ( reverse( $il + 1 .. $ir - 1 ) ) {
my $type = $types_to_go[$i];
if ( $is_assignment{$type}
&& $nesting_depth_to_go[$i] eq $depth_beg )
# or $icon = $html_icons{$type}
# or $icon = $html_icons{$state} )
for my $n ( 1 .. 2 ) {
- my $il = $ri_left->[$n];
- my $ir = $ri_right->[$n];
- foreach my $i ( $il + 1 .. $ir ) {
+ my $il_n = $ri_left->[$n];
+ my $ir_n = $ri_right->[$n];
+ foreach my $i ( $il_n + 1 .. $ir_n ) {
my $type = $types_to_go[$i];
return
if ( $is_assignment{$type}
$self->insert_additional_breaks( \@insert_list, $ri_left, $ri_right );
}
return;
-}
+} ## end sub break_equals
{ ## begin closure recombine_breakpoints
# to combine some of the lines into which the batch has been broken.
my %is_amp_amp;
- my %is_ternary;
my %is_math_op;
my %is_plus_minus;
my %is_mult_div;
@q = qw( && || );
@is_amp_amp{@q} = (1) x scalar(@q);
- @q = qw( ? : );
- @is_ternary{@q} = (1) x scalar(@q);
-
@q = qw( + - * / );
@is_math_op{@q} = (1) x scalar(@q);
for my $n ( 0 .. @{$ri_end} - 1 ) {
my $ibeg = $ri_beg->[$n];
my $iend = $ri_end->[$n];
- my $text = "";
+ my $text = EMPTY_STRING;
foreach my $i ( $ibeg .. $iend ) {
$text .= $tokens_to_go[$i];
}
}
print STDERR "----\n";
return;
- }
+ } ## end sub Debug_dump_breakpoints
sub delete_one_line_semicolons {
# ...ok, then make the semicolon invisible
my $len = $token_lengths_to_go[$i_semicolon];
- $tokens_to_go[$i_semicolon] = "";
+ $tokens_to_go[$i_semicolon] = EMPTY_STRING;
$token_lengths_to_go[$i_semicolon] = 0;
- $rLL->[$K_semicolon]->[_TOKEN_] = "";
+ $rLL->[$K_semicolon]->[_TOKEN_] = EMPTY_STRING;
$rLL->[$K_semicolon]->[_TOKEN_LENGTH_] = 0;
foreach ( $i_semicolon .. $max_index_to_go ) {
$summed_lengths_to_go[ $_ + 1 ] -= $len;
}
}
return;
- }
+ } ## end sub delete_one_line_semicolons
use constant DEBUG_RECOMBINE => 0;
# We are given indexes to the current lines:
# $ri_beg = ref to array of BEGinning indexes of each line
# $ri_end = ref to array of ENDing indexes of each line
- my ( $self, $ri_beg, $ri_end ) = @_;
+ my ( $self, $ri_beg, $ri_end, $rbond_strength_to_go ) = @_;
# sub break_long_lines is very liberal in setting line breaks
# for long lines, always setting breaks at good breakpoints, even
my $rK_weld_right = $self->[_rK_weld_right_];
my $rK_weld_left = $self->[_rK_weld_left_];
- my $nmax = @{$ri_end} - 1;
- return if ( $nmax <= 0 );
-
- my $nmax_start = $nmax;
+ my $nmax_start = @{$ri_end} - 1;
+ return if ( $nmax_start <= 0 );
# Make a list of all good joining tokens between the lines
# n-1 and n.
# Break the total batch sub-sections with lengths short enough to
# recombine
my $rsections = [];
- my $nbeg = 0;
- my $nend;
+ my $nbeg_sec = 0;
+ my $nend_sec;
my $nmax_section = 0;
- foreach my $nn ( 1 .. $nmax ) {
+ foreach my $nn ( 1 .. $nmax_start ) {
my $ibeg_1 = $ri_beg->[ $nn - 1 ];
my $iend_1 = $ri_end->[ $nn - 1 ];
my $iend_2 = $ri_end->[$nn];
# The number 5 here is an arbitrary small number intended
# to keep most small matches in one sub-section.
- || ( defined($nend) && ( $nn < 5 || $nmax - $nn < 5 ) )
+ || ( defined($nend_sec)
+ && ( $nn < 5 || $nmax_start - $nn < 5 ) )
)
{
- $nend = $nn;
+ $nend_sec = $nn;
}
else {
- if ( defined($nend) ) {
- push @{$rsections}, [ $nbeg, $nend ];
- my $num = $nend - $nbeg;
+ if ( defined($nend_sec) ) {
+ push @{$rsections}, [ $nbeg_sec, $nend_sec ];
+ my $num = $nend_sec - $nbeg_sec;
if ( $num > $nmax_section ) { $nmax_section = $num }
- $nbeg = $nn;
- $nend = undef;
+ $nbeg_sec = $nn;
+ $nend_sec = undef;
}
- $nbeg = $nn;
+ $nbeg_sec = $nn;
}
}
- if ( defined($nend) ) {
- push @{$rsections}, [ $nbeg, $nend ];
- my $num = $nend - $nbeg;
+ if ( defined($nend_sec) ) {
+ push @{$rsections}, [ $nbeg_sec, $nend_sec ];
+ my $num = $nend_sec - $nbeg_sec;
if ( $num > $nmax_section ) { $nmax_section = $num }
}
# suggested by issue c118, which pushed about 5.e5 lines through here
# and caused an excessive run time.
- # Three lines of defence have been put in place to prevent excessive
+ # Three lines of defense have been put in place to prevent excessive
# run times:
# 1. do nothing if formatting under stress (c118 was under stress)
# 2. break into small sub-sections to decrease the maximum n-squared.
if ( DEBUG_RECOMBINE > 1 ) {
my $max = 0;
- print STDERR "-----\n$num_sections sections found for nmax=$nmax\n";
+ print STDERR
+ "-----\n$num_sections sections found for nmax=$nmax_start\n";
foreach my $sect ( @{$rsections} ) {
my ( $nbeg, $nend ) = @{$sect};
my $num = $nend - $nbeg;
if ( $num > $max ) { $max = $num }
print STDERR "$nbeg $nend\n";
}
- print STDERR "max size=$max of $nmax lines\n";
+ print STDERR "max size=$max of $nmax_start lines\n";
}
# Loop over all sub-sections. Note that we have to work backwards
my ( $nbeg, $nend ) = @{$section};
# number of ending lines to leave untouched in this pass
- $nmax = @{$ri_end} - 1;
- my $num_freeze = $nmax - $nend;
+ my $nmax_sec = @{$ri_end} - 1;
+ my $num_freeze = $nmax_sec - $nend;
my $more_to_do = 1;
# We keep looping over all of the lines of this batch
# until there are no more possible recombinations
- my $nmax_last = $nmax + 1;
+ my $nmax_last = $nmax_sec + 1;
my $reverse = 0;
while ($more_to_do) {
# handle '.' and '?' specially below
|| ( $type_ibeg_2 =~ /^[\.\?]$/ )
+
+ # fix for c054 (unusual -pbp case)
+ || $type_ibeg_2 eq '=='
+
);
}
# honor hard breakpoints
next if ( $forced_breakpoint_to_go[$iend_1] > 0 );
- my $bs = $bond_strength_to_go[$iend_1] + $bs_tweak;
+ my $bs = $rbond_strength_to_go->[$iend_1] + $bs_tweak;
# Require a few extra spaces before recombining lines if we are
# at an old breakpoint unless this is a simple list or terminal
RETURN:
if (DEBUG_RECOMBINE) {
- my $nmax = @{$ri_end} - 1;
+ my $nmax_last = @{$ri_end} - 1;
print STDERR
-"exiting recombine with $nmax lines, starting lines=$nmax_start, iterations=$it_count, max_it=$it_count_max numsec=$num_sections\n";
+"exiting recombine with $nmax_last lines, starting lines=$nmax_start, iterations=$it_count, max_it=$it_count_max numsec=$num_sections\n";
}
return;
- }
+ } ## end sub recombine_breakpoints
} ## end closure recombine_breakpoints
sub insert_final_ternary_breaks {
my $i_question = $mate_index_to_go[$i_first_colon];
if ( $i_question > 0 ) {
my @insert_list;
- for ( my $ii = $i_question - 1 ; $ii >= 0 ; $ii -= 1 ) {
+ foreach my $ii ( reverse( 0 .. $i_question - 1 ) ) {
my $token = $tokens_to_go[$ii];
my $type = $types_to_go[$ii];
}
}
return;
-}
+} ## end sub insert_final_ternary_breaks
sub insert_breaks_before_list_opening_containers {
$self->insert_additional_breaks( \@insert_list, $ri_left, $ri_right );
}
return;
-}
+} ## end sub insert_breaks_before_list_opening_containers
sub note_added_semicolon {
my ( $self, $line_number ) = @_;
$self->[_added_semicolon_count_]++;
write_logfile_entry("Added ';' here\n");
return;
-}
+} ## end sub note_added_semicolon
sub note_deleted_semicolon {
my ( $self, $line_number ) = @_;
$self->[_deleted_semicolon_count_]++;
write_logfile_entry("Deleted unnecessary ';' at line $line_number\n");
return;
-}
+} ## end sub note_deleted_semicolon
sub note_embedded_tab {
my ( $self, $line_number ) = @_;
write_logfile_entry("Embedded tabs in quote or pattern\n");
}
return;
-}
+} ## end sub note_embedded_tab
use constant DEBUG_CORRECT_LP => 0;
} ## end loop over tokens in a line
} ## end loop over lines
return $do_not_pad;
-}
+} ## end sub correct_lp_indentation
sub undo_lp_ci {
# see if all additional lines in this container have continuation
# indentation
- my $n;
my $line_1 = 1 + $line_open;
- for ( $n = $line_1 ; $n <= $max_line ; ++$n ) {
+ my $n = $line_open;
+
+ while ( ++$n <= $max_line ) {
my $ibeg = $ri_first->[$n];
my $iend = $ri_last->[$n];
if ( $ibeg eq $closing_index ) { $n--; last }
@leading_spaces_to_go[ @{$ri_first}[ $line_1 .. $n ] ] =
@reduced_spaces_to_go[ @{$ri_first}[ $line_1 .. $n ] ];
return;
-}
+} ## end sub undo_lp_ci
###############################################
# CODE SECTION 10: Code to break long statments
# may be updated to be =1 for any index $i after which there must be
# a break. This signals later routines not to undo the breakpoint.
- my ( $self, $saw_good_break, $rcolon_list ) = @_;
+ my ( $self, $saw_good_break, $rcolon_list, $rbond_strength_bias ) = @_;
# @{$rcolon_list} is a list of all the ? and : tokens in the batch, in
# order.
my @i_colon_breaks = (); # needed to decide if we have to break at ?'s
if ( $types_to_go[0] eq ':' ) { push @i_colon_breaks, 0 }
- $self->set_bond_strengths();
+ my $rbond_strength_to_go = $self->set_bond_strengths();
+
+ # Add any comma bias set by break_lists
+ if ( @{$rbond_strength_bias} ) {
+ foreach my $item ( @{$rbond_strength_bias} ) {
+ my ( $ii, $bias ) = @{$item};
+ if ( $ii >= 0 && $ii <= $max_index_to_go ) {
+ $rbond_strength_to_go->[$ii] += $bias;
+ }
+ elsif (DEVEL_MODE) {
+ my $KK = $K_to_go[0];
+ my $lno = $self->[_rLL_]->[$KK]->[_LINE_INDEX_];
+ Fault(
+"Bad bond strength bias near line $lno: i=$ii must be between 0 and $max_index_to_go\n"
+ );
+ }
+ }
+ }
my $imin = 0;
my $imax = $max_index_to_go;
if ( $types_to_go[$imin] eq 'b' ) { $imin++ }
if ( $types_to_go[$imax] eq 'b' ) { $imax-- }
- my $i_begin = $imin; # index for starting next iteration
+ my $i_begin = $imin; # index for starting next iteration
my $leading_spaces = leading_spaces_to_go($imin);
my $line_count = 0;
my $i_last_break = -1;
my $max_bias = 0.001;
my $tiny_bias = 0.0001;
- my $leading_alignment_token = "";
- my $leading_alignment_type = "";
+ my $leading_alignment_token = EMPTY_STRING;
+ my $leading_alignment_type = EMPTY_STRING;
# see if any ?/:'s are in order
my $colons_in_order = 1;
- my $last_tok = "";
+ my $last_tok = EMPTY_STRING;
foreach ( @{$rcolon_list} ) {
if ( $_ eq $last_tok ) { $colons_in_order = 0; last }
$last_tok = $_;
# This is a sufficient but not necessary condition for colon chain
my $is_colon_chain = ( $colons_in_order && @{$rcolon_list} > 2 );
- my $Msg = "";
+ my $Msg = EMPTY_STRING;
#-------------------------------------------------------
# BEGINNING of main loop to set continuation breakpoints
my $starting_sum = $summed_lengths_to_go[$i_begin];
my $i_lowest = -1;
my $i_test = -1;
- my $lowest_next_token = '';
+ my $lowest_next_token = EMPTY_STRING;
my $lowest_next_type = 'b';
my $i_lowest_next_nonblank = -1;
my $maximum_line_length =
{
my $i_next_nonblank = $inext_to_go[$i_begin];
if ( $tokens_to_go[$i_next_nonblank] eq '(' ) {
- $bond_strength_to_go[$i_begin] = NO_BREAK;
+ $rbond_strength_to_go->[$i_begin] = NO_BREAK;
}
}
# BEGINNING of inner loop to find the best next breakpoint
#-------------------------------------------------------
my $strength = NO_BREAK;
- for ( $i_test = $i_begin ; $i_test <= $imax ; $i_test++ ) {
+ $i_test = $i_begin - 1;
+ while ( ++$i_test <= $imax ) {
my $type = $types_to_go[$i_test];
my $token = $tokens_to_go[$i_test];
my $next_type = $types_to_go[ $i_test + 1 ];
# we must keep the bond strength of a token and its following blank
# the same;
my $last_strength = $strength;
- $strength = $bond_strength_to_go[$i_test];
+ $strength = $rbond_strength_to_go->[$i_test];
if ( $type eq 'b' ) { $strength = $last_strength }
# reduce strength a bit to break ties at an old comma breakpoint ...
$nesting_depth_to_go[$i_next_nonblank] )
&& (
$next_nonblank_type =~ /^(\.|\&\&|\|\|)$/
- || ( $next_nonblank_type eq 'k'
- && $next_nonblank_token =~ /^(and|or)$/ )
+ || (
+ $next_nonblank_type eq 'k'
+
+ ## /^(and|or)$/ # note: includes 'xor' now
+ && $is_and_or{$next_nonblank_token}
+ )
)
)
{
# the same breakpoints will occur. scbreak.t
if (
$i_test == $imax # we are at the end
- && !get_forced_breakpoint_count()
+ && !$forced_breakpoint_count
&& $saw_good_break # old line had good break
&& $type =~ /^[#;\{]$/ # and this line ends in
# ';' or side comment
}
DEBUG_BREAK_LINES && do {
- my $ltok = $token;
- my $rtok = $next_nonblank_token ? $next_nonblank_token : "";
+ my $ltok = $token;
+ my $rtok =
+ $next_nonblank_token ? $next_nonblank_token : EMPTY_STRING;
my $i_testp2 = $i_test + 2;
if ( $i_testp2 > $max_index_to_go + 1 ) {
$i_testp2 = $max_index_to_go + 1;
DEBUG_BREAK_LINES
&& print STDOUT
"BREAK: best is i = $i_lowest strength = $lowest_strength;\nReason>> $Msg\n";
- $Msg = "";
+ $Msg = EMPTY_STRING;
#-------------------------------------------------------
# ?/: rule 2 : if we break at a '?', then break at its ':'
$i_begin = $i_lowest + 1;
$last_break_strength = $lowest_strength;
$i_last_break = $i_lowest;
- $leading_alignment_token = "";
- $leading_alignment_type = "";
- $lowest_next_token = '';
+ $leading_alignment_token = EMPTY_STRING;
+ $leading_alignment_type = EMPTY_STRING;
+ $lowest_next_token = EMPTY_STRING;
$lowest_next_type = 'b';
if ( ( $i_begin <= $imax ) && ( $types_to_go[$i_begin] eq 'b' ) ) {
}
}
}
- return ( \@i_first, \@i_last );
-}
+ return ( \@i_first, \@i_last, $rbond_strength_to_go );
+} ## end sub break_long_lines
###########################################
# CODE SECTION 11: Code to break long lists
$list_stress_level = min( $stress_level_alpha, $stress_level_beta + 2 );
return;
- }
+ } ## end sub initialize_break_lists
# routine to define essential variables when we go 'up' to
# a new depth
sub check_for_new_minimum_depth {
- my $depth = shift;
- if ( $depth < $minimum_depth ) {
+ my ( $self, $depth_t, $seqno ) = @_;
+ if ( $depth_t < $minimum_depth ) {
- $minimum_depth = $depth;
+ $minimum_depth = $depth_t;
# these arrays need not retain values between calls
- $breakpoint_stack[$depth] = $starting_breakpoint_count;
- $container_type[$depth] = "";
- $identifier_count_stack[$depth] = 0;
- $index_before_arrow[$depth] = -1;
- $interrupted_list[$depth] = 1;
- $item_count_stack[$depth] = 0;
- $last_nonblank_type[$depth] = "";
- $opening_structure_index_stack[$depth] = -1;
-
- $breakpoint_undo_stack[$depth] = undef;
- $comma_index[$depth] = undef;
- $last_comma_index[$depth] = undef;
- $last_dot_index[$depth] = undef;
- $old_breakpoint_count_stack[$depth] = undef;
- $has_old_logical_breakpoints[$depth] = 0;
- $rand_or_list[$depth] = [];
- $rfor_semicolon_list[$depth] = [];
- $i_equals[$depth] = -1;
+ $type_sequence_stack[$depth_t] = $seqno;
+ $override_cab3[$depth_t] =
+ $rOpts_comma_arrow_breakpoints == 3
+ && $seqno
+ && $self->[_roverride_cab3_]->{$seqno};
+
+ $override_cab3[$depth_t] = undef;
+ $breakpoint_stack[$depth_t] = $starting_breakpoint_count;
+ $container_type[$depth_t] = EMPTY_STRING;
+ $identifier_count_stack[$depth_t] = 0;
+ $index_before_arrow[$depth_t] = -1;
+ $interrupted_list[$depth_t] = 1;
+ $item_count_stack[$depth_t] = 0;
+ $last_nonblank_type[$depth_t] = EMPTY_STRING;
+ $opening_structure_index_stack[$depth_t] = -1;
+
+ $breakpoint_undo_stack[$depth_t] = undef;
+ $comma_index[$depth_t] = undef;
+ $last_comma_index[$depth_t] = undef;
+ $last_dot_index[$depth_t] = undef;
+ $old_breakpoint_count_stack[$depth_t] = undef;
+ $has_old_logical_breakpoints[$depth_t] = 0;
+ $rand_or_list[$depth_t] = [];
+ $rfor_semicolon_list[$depth_t] = [];
+ $i_equals[$depth_t] = -1;
# these arrays must retain values between calls
- if ( !defined( $has_broken_sublist[$depth] ) ) {
- $dont_align[$depth] = 0;
- $has_broken_sublist[$depth] = 0;
- $want_comma_break[$depth] = 0;
+ if ( !defined( $has_broken_sublist[$depth_t] ) ) {
+ $dont_align[$depth_t] = 0;
+ $has_broken_sublist[$depth_t] = 0;
+ $want_comma_break[$depth_t] = 0;
}
}
return;
- }
+ } ## end sub check_for_new_minimum_depth
# routine to decide which commas to break at within a container;
# returns:
# be broken open
sub set_comma_breakpoints {
- my ( $self, $dd ) = @_;
+ my ( $self, $dd, $rbond_strength_bias ) = @_;
my $bp_count = 0;
my $do_not_break_apart = 0;
# handle commas not in containers...
if ( $dont_align[$dd] ) {
- $self->do_uncontained_comma_breaks($dd);
+ $self->do_uncontained_comma_breaks( $dd, $rbond_strength_bias );
}
# handle commas within containers...
elsif ($real_comma_count) {
- my $fbc = get_forced_breakpoint_count();
+ my $fbc = $forced_breakpoint_count;
# always open comma lists not preceded by keywords,
# barewords, identifiers (that is, anything that doesn't
has_broken_sublist => $has_broken_sublist[$dd],
}
);
- $bp_count = get_forced_breakpoint_count() - $fbc;
+ $bp_count = $forced_breakpoint_count - $fbc;
$do_not_break_apart = 0 if $must_break_open;
}
}
return ( $bp_count, $do_not_break_apart );
- }
+ } ## end sub set_comma_breakpoints
# These types are excluded at breakpoints to prevent blinking
# Switched from excluded to included as part of fix for b1214
- ##my %is_uncontained_comma_break_excluded_type;
my %is_uncontained_comma_break_included_type;
BEGIN {
- ##my @q = qw< L { ( [ ? : + - =~ >;
- ##@is_uncontained_comma_break_excluded_type{@q} = (1) x scalar(@q);
my @q = qw< k R } ) ] Y Z U w i q Q .
= **= += *= &= <<= &&= -= /= |= >>= ||= //= .= %= ^= x=>;
# won't work very well. However, the user can always
# prevent following the old breakpoints with the
# -iob flag.
- my ( $self, $dd ) = @_;
+ my ( $self, $dd, $rbond_strength_bias ) = @_;
+
+ # Check added for issue c131; an error here would be due to an
+ # error initializing @comma_index when entering depth $dd.
+ if (DEVEL_MODE) {
+ foreach my $ii ( @{ $comma_index[$dd] } ) {
+ if ( $ii < 0 || $ii > $max_index_to_go ) {
+ my $KK = $K_to_go[0];
+ my $lno = $self->[_rLL_]->[$KK]->[_LINE_INDEX_];
+ Fault(<<EOM);
+Bad comma index near line $lno: i=$ii must be between 0 and $max_index_to_go
+EOM
+ }
+ }
+ }
+
my $bias = -.01;
my $old_comma_break_count = 0;
foreach my $ii ( @{ $comma_index[$dd] } ) {
+
if ( $old_breakpoint_to_go[$ii] ) {
$old_comma_break_count++;
- $bond_strength_to_go[$ii] = $bias;
+
+ # Store the bias info for use by sub set_bond_strength
+ push @{$rbond_strength_bias}, [ $ii, $bias ];
# reduce bias magnitude to force breaks in order
$bias *= 0.99;
{
my $ibreak = -1;
my $obp_count = 0;
- for ( my $ii = $i_first_comma - 1 ; $ii >= 0 ; $ii -= 1 ) {
+ foreach my $ii ( reverse( 0 .. $i_first_comma - 1 ) ) {
if ( $old_breakpoint_to_go[$ii] ) {
$obp_count++;
last if ( $obp_count > 1 );
# Switched from excluded to included for b1214. If necessary
# the token could also be checked if type_m eq 'k'
- ##if ( !$is_uncontained_comma_break_excluded_type{$type_m} ) {
- ##my $token_m = $tokens_to_go[$ibreak_m];
if ( $is_uncontained_comma_break_included_type{$type_m} ) {
$self->set_forced_breakpoint($ibreak);
}
}
}
return;
- }
+ } ## end sub do_uncontained_comma_breaks
my %is_logical_container;
my %quick_filter;
}
}
return;
- }
+ } ## end sub set_logical_breakpoints
sub is_unbreakable_container {
sub break_lists {
- my ( $self, $is_long_line ) = @_;
+ my ( $self, $is_long_line, $rbond_strength_bias ) = @_;
#----------------------------------------------------------------------
# This routine is called once per batch, if the batch is a list, to set
$starting_depth = $nesting_depth_to_go[0];
- $block_type = ' ';
+ $block_type = SPACE;
$current_depth = $starting_depth;
$i = -1;
$last_nonblank_token = ';';
$last_nonblank_type = ';';
- $last_nonblank_block_type = ' ';
+ $last_nonblank_block_type = SPACE;
$last_old_breakpoint_count = 0;
$minimum_depth = $current_depth + 1; # forces update in check below
$old_breakpoint_count = 0;
- $starting_breakpoint_count = get_forced_breakpoint_count();
+ $starting_breakpoint_count = $forced_breakpoint_count;
$token = ';';
$type = ';';
- $type_sequence = '';
+ $type_sequence = EMPTY_STRING;
my $total_depth_variation = 0;
my $i_old_assignment_break;
my $depth_last = $starting_depth;
my $comma_follows_last_closing_token;
- check_for_new_minimum_depth($current_depth);
+ $self->check_for_new_minimum_depth( $current_depth,
+ $parent_seqno_to_go[0] );
my $want_previous_breakpoint = -1;
elsif ( $is_opening_token{$token} ) {
- # do requeste -lp breaks at the OPENING token for BROKEN
+ # do requested -lp breaks at the OPENING token for BROKEN
# blocks. NOTE: this can be done for both -lp and -xlp,
# but only -xlp can really take advantage of this. So this
# is currently restricted to -xlp to avoid excess changes to
# must be opening..fixes c102
if ( $depth == $current_depth + 1 && $is_opening_type{$type} ) {
+ #----------------------------------------------------------
+ # BEGIN initialize depth arrays
+ # ... use the same order as sub check_for_new_minimum_depth
+ #----------------------------------------------------------
$type_sequence_stack[$depth] = $type_sequence;
$override_cab3[$depth] =
$rOpts_comma_arrow_breakpoints == 3
&& $type_sequence
&& $self->[_roverride_cab3_]->{$type_sequence};
- $breakpoint_stack[$depth] = get_forced_breakpoint_count();
- $breakpoint_undo_stack[$depth] =
- get_forced_breakpoint_undo_count();
- $has_broken_sublist[$depth] = 0;
+
+ $breakpoint_stack[$depth] = $forced_breakpoint_count;
+ $container_type[$depth] =
+
+ # k => && || ? : .
+ $is_container_label_type{$last_nonblank_type}
+ ? $last_nonblank_token
+ : EMPTY_STRING;
$identifier_count_stack[$depth] = 0;
$index_before_arrow[$depth] = -1;
$interrupted_list[$depth] = 0;
$item_count_stack[$depth] = 0;
- $last_comma_index[$depth] = undef;
- $last_dot_index[$depth] = undef;
$last_nonblank_type[$depth] = $last_nonblank_type;
- $old_breakpoint_count_stack[$depth] = $old_breakpoint_count;
$opening_structure_index_stack[$depth] = $i;
- $rand_or_list[$depth] = [];
- $rfor_semicolon_list[$depth] = [];
- $i_equals[$depth] = -1;
- $want_comma_break[$depth] = 0;
- $container_type[$depth] =
- # k => && || ? : .
- $is_container_label_type{$last_nonblank_type}
- ? $last_nonblank_token
- : "";
+ $breakpoint_undo_stack[$depth] = $forced_breakpoint_undo_count;
+ $comma_index[$depth] = undef;
+ $last_comma_index[$depth] = undef;
+ $last_dot_index[$depth] = undef;
+ $old_breakpoint_count_stack[$depth] = $old_breakpoint_count;
$has_old_logical_breakpoints[$depth] = 0;
+ $rand_or_list[$depth] = [];
+ $rfor_semicolon_list[$depth] = [];
+ $i_equals[$depth] = -1;
# if line ends here then signal closing token to break
if ( $next_nonblank_type eq 'b' || $next_nonblank_type eq '#' )
$dont_align[$depth] =
# code BLOCKS are handled at a higher level
- ( $block_type ne "" )
+ ( $block_type ne EMPTY_STRING )
# certain paren lists
|| ( $type eq '(' ) && (
# a trailing '(' usually indicates a non-list
|| ( $next_nonblank_type eq '(' )
);
+ $has_broken_sublist[$depth] = 0;
+ $want_comma_break[$depth] = 0;
+
+ #-------------------------------------
+ # END initialize depth arrays
+ #-------------------------------------
# patch to outdent opening brace of long if/for/..
# statements (like this one). See similar coding in
# must be closing .. fixes c102
elsif ( $depth == $current_depth - 1 && $is_closing_type{$type} ) {
- check_for_new_minimum_depth($depth);
+ $self->check_for_new_minimum_depth( $depth,
+ $parent_seqno_to_go[$i] );
$comma_follows_last_closing_token =
$next_nonblank_type eq ',' || $next_nonblank_type eq '=>';
# set breaks at commas if necessary
my ( $bp_count, $do_not_break_apart ) =
- $self->set_comma_breakpoints($current_depth);
+ $self->set_comma_breakpoints( $current_depth,
+ $rbond_strength_bias );
my $i_opening = $opening_structure_index_stack[$current_depth];
my $saw_opening_structure = ( $i_opening >= 0 );
# Do not break hash braces under stress (fixes b1238)
$do_not_break_apart ||= $types_to_go[$i_opening] eq 'L';
- # This option fixes b1235, b1237, b1240 with old and new -lp,
- # but formatting is nicer with next option.
+ # This option fixes b1235, b1237, b1240 with old and new
+ # -lp, but formatting is nicer with next option.
## $is_long_term ||=
## $levels_to_go[$i_opening] > $stress_level_beta + 1;
if ( ref($indentation)
&& $ris_broken_container->{$type_sequence} )
{
- my $lp_spaces = $indentation->get_spaces();
- my $std_spaces =
- $standard_spaces_to_go[$i_opening_minus];
- my $diff = $std_spaces - $lp_spaces;
+ my $lp_spaces = $indentation->get_spaces();
+ my $std_spaces = $indentation->get_standard_spaces();
+ my $diff = $std_spaces - $lp_spaces;
if ( $diff > 0 ) { $excess += $diff }
}
# and we made breakpoints between the opening and closing
&& ( $breakpoint_undo_stack[$current_depth] <
- get_forced_breakpoint_undo_count() )
+ $forced_breakpoint_undo_count )
# and this block is short enough to fit on one line
# Note: use < because need 1 more space for possible comma
# now see if we have any comma breakpoints left
my $has_comma_breakpoints =
( $breakpoint_stack[$current_depth] !=
- get_forced_breakpoint_count() );
+ $forced_breakpoint_count );
# update broken-sublist flag of the outer container
$has_broken_sublist[$depth] =
# broken open to avoid too much density. Also, since it contains no 'or's, there
# will be a forced break at its 'and'.
+ # Open-up if parens if requested. We do this by pretending we
+ # did not see the opening structure, since in that case parens
+ # always get opened up.
+ if ( $saw_opening_structure
+ && $rOpts_break_open_compact_parens )
+ {
+
+ # This parameter is a one-character flag, as follows:
+ # '0' matches no parens -> break open NOT OK
+ # '1' matches all parens -> break open OK
+ # Other values are same as used by the weld-exclusion-list
+ my $flag = $rOpts_break_open_compact_parens;
+ if ( $flag eq '*'
+ || $flag eq '1' )
+ {
+ $saw_opening_structure = 0;
+ }
+ else {
+ my $KK = $K_to_go[$i_opening];
+ $saw_opening_structure =
+ !$self->match_paren_flag( $KK, $flag );
+ }
+ }
+
# set some flags telling something about this container..
my $is_simple_logical_expression = 0;
if ( $item_count_stack[$current_depth] == 0
if (
$is_assignment{$next_nonblank_type}
&& ( $breakpoint_stack[$current_depth] !=
- get_forced_breakpoint_count() )
+ $forced_breakpoint_count )
)
{
$self->set_forced_breakpoint($i);
#-------------------------------------------
# set breaks for any unfinished lists ..
- for ( my $dd = $current_depth ; $dd >= $minimum_depth ; $dd-- ) {
+ foreach my $dd ( reverse( $minimum_depth .. $current_depth ) ) {
$interrupted_list[$dd] = 1;
$has_broken_sublist[$dd] = 1 if ( $dd < $current_depth );
- $self->set_comma_breakpoints($dd);
+ $self->set_comma_breakpoints( $dd, $rbond_strength_bias );
$self->set_logical_breakpoints($dd)
if ( $has_old_logical_breakpoints[$dd] );
$self->set_for_semicolon_breakpoints($dd);
# This is complex ($total_depth_variation=6):
# $res2 =
# (is_boundp("a", 'self-insert') && is_boundp("b", 'self-insert'));
+
+ # The check ($i_old_.. < $max_index_to_go) was added to fix b1333
elsif ($i_old_assignment_break
&& $total_depth_variation > 4
- && $old_breakpoint_count == 1 )
+ && $old_breakpoint_count == 1
+ && $i_old_assignment_break < $max_index_to_go )
{
$saw_good_breakpoint = 1;
} ## end elsif ( $i_old_assignment_break...)
# at the previous nonblank. This makes the result insensitive
# to the flag --space-function-paren, and similar.
# previous loop: for ( my $j = $im1 ; $j >= 0 ; $j-- ) {
- for ( my $j = $iprev_nb ; $j >= 0 ; $j-- ) {
- ##last if ( $types_to_go[$j] =~ /^[\(\[\{L\}\]\)Rb,]$/ );
- ##last if ( $is_key_type{ $types_to_go[$j] } );
+ foreach my $j ( reverse( 0 .. $iprev_nb ) ) {
if ( $is_key_type{ $types_to_go[$j] } ) {
# fix for b1211
EOM
return $i_opening_minus;
-}
+} ## end sub find_token_starting_list
{ ## begin closure set_comma_breakpoints_do
}
else {
$skipped_count = 0;
- my $i = $i_term_comma[ $j - 1 ];
- last unless defined $i;
- $self->set_forced_breakpoint($i);
+ my $i_tc = $i_term_comma[ $j - 1 ];
+ last unless defined $i_tc;
+ $self->set_forced_breakpoint($i_tc);
}
}
&& $container_indentation_options{$opening_token} == 2 )
{
$tol = $rOpts_indent_columns;
+
+ # use greater of -ci and -i (fix for case b1334)
+ if ( $tol < $rOpts_continuation_indentation ) {
+ $tol = $rOpts_continuation_indentation;
+ }
}
my $i_opening_minus = $self->find_token_starting_list($i_opening_paren);
# If a line starts with paren+space+terms, then its max length
# could be up to ci+2-i spaces less than if the term went out
# on a line after the paren. So..
- my $tol = max( 0,
+ my $tol_w = max( 0,
2 + $rOpts_continuation_indentation -
$rOpts_indent_columns );
- $columns = max( 0, $columns - $tol );
+ $columns = max( 0, $columns - $tol_w );
## Here is the original b1210 fix, but it failed on b1216-b1218
##my $columns2 = table_columns_available($i_opening_paren);
# )
# if $style eq 'all';
- my $i_last_comma = $rcomma_index->[ $comma_count - 1 ];
+ $i_last_comma = $rcomma_index->[ $comma_count - 1 ];
+
my $long_last_term =
$self->excess_line_length( 0, $i_last_comma ) <= 0;
my $long_first_term =
$two_line_word_wrap_ok = 1;
# but turn off word wrap where requested
- if ($rOpts_break_open_paren_list) {
+ if ($rOpts_break_open_compact_parens) {
# This parameter is a one-character flag, as follows:
# '0' matches no parens -> break open NOT OK -> word wrap OK
# '1' matches all parens -> break open OK -> word wrap NOT OK
# Other values are the same as used by the weld-exclusion-list
- my $flag = $rOpts_break_open_paren_list;
+ my $flag = $rOpts_break_open_compact_parens;
if ( $flag eq '*'
|| $flag eq '1' )
{
# thing before the '=>'. This is crude and should be improved by
# actually looking back token by token.
if ( !$too_long && $i_opening_paren > 0 && $list_type eq '=>' ) {
- my $i_opening_minus = $i_opening_paren - 4;
+ my $i_opening_minus_test = $i_opening_paren - 4;
if ( $i_opening_minus >= 0 ) {
- $too_long = $self->excess_line_length( $i_opening_minus,
+ $too_long = $self->excess_line_length( $i_opening_minus_test,
$i_effective_last_comma + 1 ) > 0;
}
}
my $j_first_break =
$use_separate_first_term ? $number_of_fields : $number_of_fields - 1;
- for (
- my $j = $j_first_break ;
- $j < $comma_count ;
- $j += $number_of_fields
- )
- {
- my $i = $rcomma_index->[$j];
- $self->set_forced_breakpoint($i);
+ my $j = $j_first_break;
+ while ( $j < $comma_count ) {
+ my $i_comma = $rcomma_index->[$j];
+ $self->set_forced_breakpoint($i_comma);
+ $j += $number_of_fields;
}
return;
- }
+ } ## end sub set_comma_breakpoints_do
} ## end closure set_comma_breakpoints_do
sub study_list_complexity {
}
return ( $number_of_fields_best, \@i_ragged_break_list, $identifier_count );
-}
+} ## end sub study_list_complexity
sub get_maximum_fields_wanted {
}
}
return ($number_of_fields_best);
-}
+} ## end sub get_maximum_fields_wanted
sub table_columns_available {
my $i_first_comma = shift;
# available columns is reduced by 1 character.
$columns -= 1;
return $columns;
-}
+} ## end sub table_columns_available
sub maximum_number_of_fields {
$number_of_fields++;
}
return $number_of_fields;
-}
+} ## end sub maximum_number_of_fields
sub compactify_table {
# better.
my ( $item_count, $number_of_fields, $formatted_lines, $odd_or_even ) = @_;
if ( $number_of_fields >= $odd_or_even * 2 && $formatted_lines > 0 ) {
- my $min_fields;
- for (
- $min_fields = $number_of_fields ;
- $min_fields >= $odd_or_even
- && $min_fields * $formatted_lines >= $item_count ;
- $min_fields -= $odd_or_even
- )
+ my $min_fields = $number_of_fields;
+
+ while ($min_fields >= $odd_or_even
+ && $min_fields * $formatted_lines >= $item_count )
{
$number_of_fields = $min_fields;
+ $min_fields -= $odd_or_even;
}
}
return $number_of_fields;
-}
+} ## end sub compactify_table
sub set_ragged_breakpoints {
}
}
return $break_count;
-}
+} ## end sub set_ragged_breakpoints
sub copy_old_breakpoints {
my ( $self, $i_first_comma, $i_last_comma ) = @_;
0 && do {
my ( $a, $b, $c ) = caller();
- my $forced_breakpoint_count = get_forced_breakpoint_count();
print STDOUT
"NOBREAK: forced_breakpoint $forced_breakpoint_count from $a $c with i=$i max=$max_index_to_go type=$types_to_go[$i]\n";
};
};
}
return;
-}
+} ## end sub set_nobreaks
###############################################
# CODE SECTION 12: Code for setting indentation
sub token_sequence_length {
# return length of tokens ($ibeg .. $iend) including $ibeg & $iend
- # returns 0 if $ibeg > $iend (shouldn't happen)
my ( $ibeg, $iend ) = @_;
- return 0 if ( !defined($iend) || $iend < 0 || $ibeg > $iend );
- return $summed_lengths_to_go[ $iend + 1 ] if ( $ibeg < 0 );
+
+ # fix possible negative starting index
+ if ( $ibeg < 0 ) { $ibeg = 0 }
+
+ # returns 0 if index range is empty (some subs assume this)
+ if ( $ibeg > $iend ) {
+ return 0;
+ }
+
return $summed_lengths_to_go[ $iend + 1 ] - $summed_lengths_to_go[$ibeg];
-}
+} ## end sub token_sequence_length
sub total_line_length {
# return length of a line of tokens ($ibeg .. $iend)
my ( $ibeg, $iend ) = @_;
- # original coding:
- #return leading_spaces_to_go($ibeg) + token_sequence_length( $ibeg, $iend );
+ # Start with the leading spaces on this line ...
+ my $length = $leading_spaces_to_go[$ibeg];
+ if ( ref($length) ) { $length = $length->get_spaces() }
- # this is basically sub 'leading_spaces_to_go':
- my $indentation = $leading_spaces_to_go[$ibeg];
- if ( ref($indentation) ) { $indentation = $indentation->get_spaces() }
+ # ... then add the net token length
+ $length +=
+ $summed_lengths_to_go[ $iend + 1 ] - $summed_lengths_to_go[$ibeg];
- return $indentation + $summed_lengths_to_go[ $iend + 1 ] -
- $summed_lengths_to_go[$ibeg];
-}
+ return $length;
+} ## end sub total_line_length
sub excess_line_length {
# return number of characters by which a line of tokens ($ibeg..$iend)
# exceeds the allowable line length.
+ # NOTE: profiling shows that efficiency of this routine is essential.
- # NOTE: Profiling shows that this is a critical routine for efficiency.
- # Therefore I have eliminated additional calls to subs from it.
my ( $self, $ibeg, $iend, $ignore_right_weld ) = @_;
- # Original expression for line length
- ##$length = leading_spaces_to_go($ibeg) + token_sequence_length( $ibeg, $iend );
+ # Start with the leading spaces on this line ...
+ my $excess = $leading_spaces_to_go[$ibeg];
+ if ( ref($excess) ) { $excess = $excess->get_spaces() }
- # This is basically sub 'leading_spaces_to_go':
- my $indentation = $leading_spaces_to_go[$ibeg];
- if ( ref($indentation) ) { $indentation = $indentation->get_spaces() }
-
- my $length =
- $indentation +
+ # ... then add the net token length, minus the maximum length
+ $excess +=
$summed_lengths_to_go[ $iend + 1 ] -
- $summed_lengths_to_go[$ibeg];
+ $summed_lengths_to_go[$ibeg] -
+ $maximum_line_length_at_level[ $levels_to_go[$ibeg] ];
- # Include right weld lengths unless requested not to.
+ # ... and include right weld lengths unless requested not to
if ( $total_weld_count
- && !$ignore_right_weld
- && $type_sequence_to_go[$iend] )
+ && $type_sequence_to_go[$iend]
+ && !$ignore_right_weld )
{
my $wr = $self->[_rweld_len_right_at_K_]->{ $K_to_go[$iend] };
- $length += $wr if defined($wr);
+ $excess += $wr if defined($wr);
}
- # return the excess
- return $length - $maximum_line_length_at_level[ $levels_to_go[$ibeg] ];
-}
+ return $excess;
+} ## end sub excess_line_length
sub get_spaces {
# indentation variable. $indentation is either a constant number of
# spaces or an object with a get_available_spaces method.
return ref($item) ? $item->get_available_spaces() : 0;
-}
+} ## end sub get_available_spaces_to_go
{ ## begin closure set_lp_indentation
$rLP->[$max_lp_stack]->[_lp_space_count_] = 0;
return;
- }
+ } ## end sub initialize_lp_vars
# hashes for efficient testing
my %hash_test1;
my $ris_excluded_lp_container = $self->[_ris_excluded_lp_container_];
my $rblock_type_of_seqno = $self->[_rblock_type_of_seqno_];
my $starting_in_quote = $self->[_this_batch_]->[_starting_in_quote_];
- my $K_opening_container = $self->[_K_opening_container_]; ##TESTING
my $K_closing_container = $self->[_K_closing_container_];
my $rlp_object_by_seqno = $self->[_rlp_object_by_seqno_];
my $radjusted_levels = $self->[_radjusted_levels_];
$K_last_nonblank = $Kpnb;
}
- my $last_nonblank_token = '';
- my $last_nonblank_type = '';
- my $last_last_nonblank_type = '';
+ my $last_nonblank_token = EMPTY_STRING;
+ my $last_nonblank_type = EMPTY_STRING;
+ my $last_last_nonblank_type = EMPTY_STRING;
if ( defined($K_last_nonblank) ) {
$last_nonblank_token = $rLL->[$K_last_nonblank]->[_TOKEN_];
#-----------------------------------
foreach my $ii ( $imin .. $max_index_to_go ) {
- my $KK = $K_to_go[$ii];
- my $type = $types_to_go[$ii];
- my $token = $tokens_to_go[$ii];
- my $level = $levels_to_go[$ii];
- my $ci_level = $ci_levels_to_go[$ii];
- my $total_depth = $nesting_depth_to_go[$ii];
+ my $KK = $K_to_go[$ii];
+ my $type = $types_to_go[$ii];
+ my $token = $tokens_to_go[$ii];
+ my $level = $levels_to_go[$ii];
+ my $ci_level = $ci_levels_to_go[$ii];
+ my $total_depth = $nesting_depth_to_go[$ii];
+ my $standard_spaces = $leading_spaces_to_go[$ii];
#--------------------------------------------------
# Adjust levels if necessary to recycle whitespace:
# type, see if it would be helpful to 'break' after the '=' to
# save space
my $last_equals = $last_lp_equals{$total_depth};
- if ( $last_equals && $last_equals > $ii_begin_line ) {
+
+ # Skip an empty set of parens, such as after channel():
+ # my $exchange = $self->_channel()->exchange(
+ # This fixes issues b1318 b1322 b1323 b1328
+ # TODO: maybe also skip parens with just one token?
+ my $is_empty_container;
+ if ( $last_equals && $ii < $max_index_to_go ) {
+ my $seqno = $type_sequence_to_go[$ii];
+ my $inext_nb = $ii + 1;
+ $inext_nb++
+ if ( $types_to_go[$inext_nb] eq 'b' );
+ my $seqno_nb = $type_sequence_to_go[$inext_nb];
+ $is_empty_container =
+ $seqno && $seqno_nb && $seqno_nb == $seqno;
+ }
+
+ if ( $last_equals
+ && $last_equals > $ii_begin_line
+ && !$is_empty_container )
+ {
my $seqno = $type_sequence_to_go[$ii];
}
elsif ( $types_to_go[ $i_test + 1 ] eq 'b' ) { $i_test++ }
- # TESTING
- ##my $too_close = ($i_test==$ii-1);
-
my $test_position = total_line_length( $i_test, $ii );
my $mll =
$maximum_line_length_at_level[ $levels_to_go[$i_test] ];
if (
- # the equals is not just before an open paren (testing)
- ##!$too_close &&
-
# if we might exceed the maximum line length
$lp_position_predictor + $len_increase > $mll
if ( $level < $current_level || $ci_level < $current_ci_level ) {
# loop to find the first entry at or completely below this level
- my ( $lev, $ci_lev );
while (1) {
if ($max_lp_stack) {
# non-fatal, keep going except in DEVEL_MODE
if (DEVEL_MODE) {
+##program bug with -lp: stack_error. level=$level; lev=$lev; ci_level=$ci_level; ci_lev=$ci_lev; rerun with -nlp
Fault(<<EOM);
-program bug with -lp: stack_error. level=$level; lev=$lev; ci_level=$ci_level; ci_lev=$ci_lev; rerun with -nlp
+program bug with -lp: stack_error. level=$level; ci_level=$ci_level; rerun with -nlp
EOM
}
last;
# it becomes clear that we do not have a good list.
my $available_spaces = 0;
my $align_seqno = 0;
- my $excess = 0;
my $last_nonblank_seqno;
my $last_nonblank_block_type;
# or if this is not a sequenced item
|| !$last_nonblank_seqno
- # or this continer is excluded by user rules
+ # or this container is excluded by user rules
# or contains here-docs or multiline qw text
|| defined($last_nonblank_seqno)
&& $ris_excluded_lp_container->{$last_nonblank_seqno}
elsif ( $available_spaces > 1 ) {
$min_gnu_indentation += $available_spaces + 1;
}
- elsif ( $last_nonblank_token =~ /^[\{\[\(]$/ ) {
+ ##elsif ( $last_nonblank_token =~ /^[\{\[\(]$/ ) {
+ elsif ( $is_opening_token{$last_nonblank_token} ) {
if ( ( $tightness{$last_nonblank_token} < 2 ) ) {
$min_gnu_indentation += 2;
}
align_seqno => $align_seqno,
stack_depth => $max_lp_stack,
K_begin_line => $K_begin_line,
+ standard_spaces => $standard_spaces,
);
DEBUG_LP && do {
$lp_object;
}
- if ( $last_nonblank_token =~ /^[\{\[\(]$/
+ ##if ( $last_nonblank_token =~ /^[\{\[\(]$/
+ if ( $is_opening_token{$last_nonblank_token}
&& $last_nonblank_seqno )
{
$rlp_object_by_seqno->{$last_nonblank_seqno} =
if ( !$rOpts_extended_line_up_parentheses );
return;
- }
+ } ## end sub set_lp_indentation
sub check_for_long_gnu_style_lines {
# from whitespace items created on this batch, since others have
# already been used and cannot be undone.
my @candidates = ();
- my $i;
# loop over all whitespace items created for the current batch
- for ( $i = 0 ; $i <= $max_lp_object_list ; $i++ ) {
+ foreach my $i ( 0 .. $max_lp_object_list ) {
my $item = $rlp_object_list->[$i];
# item must still be open to be a candidate (otherwise it
return unless (@candidates);
# sort by available whitespace so that we can remove whitespace
- # from the maximum available first
- @candidates = sort { $b->[1] <=> $a->[1] } @candidates;
+ # from the maximum available first.
+ @candidates =
+ sort { $b->[1] <=> $a->[1] || $a->[0] <=> $b->[0] } @candidates;
# keep removing whitespace until we are done or have no more
foreach my $candidate (@candidates) {
# update the leading whitespace of this item and all items
# that came after it
- for ( ; $i <= $max_lp_object_list ; $i++ ) {
+ $i -= 1;
+ while ( ++$i <= $max_lp_object_list ) {
my $old_spaces = $rlp_object_list->[$i]->get_spaces();
if ( $old_spaces >= $deleted_spaces ) {
last unless ( $spaces_needed > 0 );
}
return;
- }
+ } ## end sub check_for_long_gnu_style_lines
sub undo_incomplete_lp_indentation {
}
}
return;
- }
+ } ## end sub undo_incomplete_lp_indentation
} ## end closure set_lp_indentation
#----------------------------------------------------------------------
}
}
return;
-}
+} ## end sub set_forced_lp_break
sub reduce_lp_indentation {
}
return $deleted_spaces;
-}
+} ## end sub reduce_lp_indentation
###########################################################
# CODE SECTION 13: Preparing batches for vertical alignment
}
}
return;
-}
+} ## end sub check_convey_batch_input
sub convey_batch_to_vertical_aligner {
# 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)$/ )
+ && $is_if_unless{$token_beg_next} )
{
$self->flush_vertical_aligner();
}
# ----------------------------------------------
# loop to send each line to the vertical aligner
# ----------------------------------------------
- my ( $type_beg, $token_beg );
- my ($type_end);
- my ( $ibeg, $iend );
+ my ( $type_beg, $type_end, $token_beg );
+
for my $n ( 0 .. $n_last_line ) {
# ----------------------------------------------------------------
# to pass nesting depths to the vertical aligner. They remain invariant
# under all formatting operations. Previously, level values were sent
# to the aligner. But they can be altered in welding and other
- # opeartions, and this can lead to alignement errors.
+ # operations, and this can lead to alignment errors.
my $nesting_depth_beg = $nesting_depth_to_go[$ibeg];
my $nesting_depth_end = $nesting_depth_to_go[$iend];
# or is a single token followed by opening token.
# Note that sub identifiers have blanks like 'sub doit'
# $token_beg !~ /\s+/
- || ( $Kend - $Kbeg <= 2 && index( $token_beg, ' ' ) < 0 )
+ || ( $Kend - $Kbeg <= 2 && index( $token_beg, SPACE ) < 0 )
)
# and limit total to 10 character widths
$file_writer_object->write_code_line( $cscw_block_comment . "\n" );
}
return;
-}
+} ## end sub convey_batch_to_vertical_aligner
sub check_batch_summed_lengths {
my ( $self, $msg ) = @_;
- $msg = "" unless defined($msg);
+ $msg = EMPTY_STRING unless defined($msg);
my $rLL = $self->[_rLL_];
# Verify that the summed lengths are correct. We want to be sure that
}
}
return;
-}
+} ## end sub check_batch_summed_lengths
{ ## begin closure set_vertical_alignment_markers
my %is_vertical_alignment_type;
my $last_vertical_alignment_BEFORE_index;
my $vert_last_nonblank_type;
my $vert_last_nonblank_token;
- my $vert_last_nonblank_block_type;
foreach my $line ( 0 .. $max_line ) {
$i_good_paren++;
}
- # Initializtion for 'elsif' patch: remember the paren range of
+ # Initialization for 'elsif' patch: remember the paren range 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.
my $type = $types_to_go[$i];
my $token = $tokens_to_go[$i];
- my $alignment_type = '';
+ my $alignment_type = EMPTY_STRING;
# ----------------------------------------------
# Check for 'paren patch' : Remove excess parens
&& $imate > $i_good_paren )
{
if ( $ralignment_type_to_go->[$imate] ) {
- $ralignment_type_to_go->[$imate] = '';
+ $ralignment_type_to_go->[$imate] = EMPTY_STRING;
$ralignment_counts->[$line]--;
delete $ralignment_hash_by_line->[$line]->{$imate};
}
}
}
+ # align qw in a 'use' statement (issue git #93)
+ elsif ( $type eq 'q' ) {
+ if ( $types_to_go[0] eq 'k' && $tokens_to_go[0] eq 'use' ) {
+ $alignment_type = $type;
+ }
+ }
+
# align before one of these types..
elsif ( $is_vertical_alignment_type{$type}
&& !$is_not_vertical_alignment_token{$token} )
# (2) doing so may prevent other good alignments.
# Current exceptions are && and || and =>
if ( $i == $iend ) {
- $alignment_type = ""
+ $alignment_type = EMPTY_STRING
unless ( $is_terminal_alignment_type{$type} );
}
&& $i == $ibeg + 2
&& $types_to_go[ $i - 1 ] eq 'b' )
{
- $alignment_type = "";
+ $alignment_type = EMPTY_STRING;
}
# Certain tokens only align at the same level as the
if ( $is_low_level_alignment_token{$token}
&& $levels_to_go[$i] != $level_beg )
{
- $alignment_type = "";
+ $alignment_type = EMPTY_STRING;
}
# For a paren after keyword, only align something like this:
if ( $token eq '(' ) {
if ( $vert_last_nonblank_type eq 'k' ) {
- $alignment_type = ""
- unless $vert_last_nonblank_token =~
- /^(if|unless|elsif)$/;
+ $alignment_type = EMPTY_STRING
+ unless
+ $is_if_unless_elsif{$vert_last_nonblank_token};
+ ##unless $vert_last_nonblank_token =~ /^(if|unless|elsif)$/;
}
# Do not align a spaced-function-paren if requested.
if ( !$rOpts_function_paren_vertical_alignment ) {
my $seqno = $type_sequence_to_go[$i];
if ( $ris_function_call_paren->{$seqno} ) {
- $alignment_type = "";
+ $alignment_type = EMPTY_STRING;
}
}
+
+ # make () align with qw in a 'use' statement (git #93)
+ if ( $tokens_to_go[0] eq 'use'
+ && $types_to_go[0] eq 'k'
+ && $mate_index_to_go[$i] == $i + 1 )
+ {
+ $alignment_type = 'q';
+ }
}
# be sure the alignment tokens are unique
# and ignore any tokens which have leading padded spaces
# example: perl527/lop.t
- elsif ( substr( $alignment_type, 0, 1 ) eq ' ' ) {
+ elsif ( substr( $alignment_type, 0, 1 ) eq SPACE ) {
}
}
}
return ($seqno);
-}
+} ## end sub get_seqno
{
my %undo_extended_ci;
}
return;
- }
+ } ## end sub undo_ci
}
{ ## begin closure set_logical_padding
# : eval($_) ? 1
# : 0;
- # be sure levels agree (do not indent after an indented 'if')
+ # be sure levels agree (never indent after an indented 'if')
next
if ( $levels_to_go[$ibeg] ne $levels_to_go[$ibeg_next] );
# find interior token to pad if necessary
if ( !defined($ipad) ) {
- for ( my $i = $ibeg ; ( $i < $iend ) && !$ipad ; $i++ ) {
+ foreach my $i ( $ibeg .. $iend - 1 ) {
# find any unclosed container
next
# find next nonblank token to pad
$ipad = $inext_to_go[$i];
- last if ( $ipad > $iend );
+ last if $ipad;
}
- last unless $ipad;
+ last if ( !$ipad || $ipad > $iend );
}
# We cannot pad the first leading token of a file because
## $font->{'loca'}->{'glyphs'}[$x]->read->{'xMin'} * 1000
## / $upem
## ),
-##? # do not put leading padding for just 2 lines of math
-##? if ( $ipad == $ibeg
-##? && $line > 0
-##? && $levels_to_go[$ipad] > $levels_to_go[ $ipad - 1 ]
-##? && $is_math_op{$type_next}
-##? && $line + 2 <= $max_line )
-##? {
-##? my $ibeg_next_next = $ri_first->[ $line + 2 ];
-##? my $type_next_next = $types_to_go[$ibeg_next_next];
-##? next if !$is_math_op{$type_next_next};
-##? }
+## # do not put leading padding for just 2 lines of math
+## if ( $ipad == $ibeg
+## && $line > 0
+## && $levels_to_go[$ipad] > $levels_to_go[ $ipad - 1 ]
+## && $is_math_op{$type_next}
+## && $line + 2 <= $max_line )
+## {
+## my $ibeg_next_next = $ri_first->[ $line + 2 ];
+## my $type_next_next = $types_to_go[$ibeg_next_next];
+## next if !$is_math_op{$type_next_next};
+## }
# next line must not be at greater depth
my $iend_next = $ri_last->[ $line + 1 ];
# lines must be somewhat similar to be padded..
my $inext_next = $inext_to_go[$ibeg_next];
my $type = $types_to_go[$ipad];
- my $type_next = $types_to_go[ $ipad + 1 ];
# see if there are multiple continuation lines
my $logical_continuation_lines = 1;
my $l = $line + 1;
foreach my $ltest ( $line + 2 .. $max_line ) {
$l = $ltest;
- my $ibg = $ri_first->[$l];
+ my $ibeg_t = $ri_first->[$l];
# quit looking at the end of this container
last
- if ( $nesting_depth_to_go[ $ibg + 1 ] < $depth )
- || ( $nesting_depth_to_go[$ibg] < $depth );
+ if ( $nesting_depth_to_go[ $ibeg_t + 1 ] < $depth )
+ || ( $nesting_depth_to_go[$ibeg_t] < $depth );
# cannot do the pad if a later line would be
# outdented more
- if ( $levels_to_go[$ibg] + $ci_levels_to_go[$ibg] < $lsp ) {
+ if ( $levels_to_go[$ibeg_t] + $ci_levels_to_go[$ibeg_t] <
+ $lsp )
+ {
$ok_to_pad = 0;
last;
}
$has_leading_op = $has_leading_op_next;
} ## end of loop over lines
return;
- }
+ } ## end sub set_logical_padding
} ## end closure set_logical_padding
sub pad_token {
my $tok_len = $rLL->[$KK]->[_TOKEN_LENGTH_];
if ( $pad_spaces > 0 ) {
- $tok = ' ' x $pad_spaces . $tok;
+ $tok = SPACE x $pad_spaces . $tok;
$tok_len += $pad_spaces;
}
- elsif ( $pad_spaces == -1 && $tokens_to_go[$ipad] eq ' ' ) {
- $tok = "";
+ elsif ( $pad_spaces == -1 && $tokens_to_go[$ipad] eq SPACE ) {
+ $tok = EMPTY_STRING;
$tok_len = 0;
}
else {
$summed_lengths_to_go[ $i + 1 ] += $pad_spaces;
}
return;
-}
+} ## end sub pad_token
{ ## begin closure make_alignment_patterns
$rpatterns = [ $types_to_go[$ibeg] ];
}
else {
- $rfields = [ join( '', @tokens_to_go[ $ibeg .. $iend ] ) ];
- $rpatterns = [ join( '', @types_to_go[ $ibeg .. $iend ] ) ];
+ $rfields =
+ [ join( EMPTY_STRING, @tokens_to_go[ $ibeg .. $iend ] ) ];
+ $rpatterns =
+ [ join( EMPTY_STRING, @types_to_go[ $ibeg .. $iend ] ) ];
}
return [ $rtokens, $rfields, $rpatterns, $rfield_lengths ];
}
my $i_start = $ibeg;
my $depth = 0;
- my %container_name = ( 0 => "" );
+ my %container_name = ( 0 => EMPTY_STRING );
my @tokens = ();
my @fields = ();
# Make a container name by combining all leading barewords,
# keywords and functions.
- my $name = "";
+ my $name = EMPTY_STRING;
my $count = 0;
my $count_max;
my $iname_end;
|| $is_binary_type{$type}
|| $type eq 'k' && $is_binary_keyword{$token} )
{
- $name = "";
+ $name = EMPTY_STRING;
last;
}
$token = $name_map{$token};
}
- $name .= ' ' . $token;
+ $name .= SPACE . $token;
$iname_end = $_;
$count++;
}
# --------------------
my $j = 0; # field index
- $patterns[0] = "";
+ $patterns[0] = EMPTY_STRING;
my %token_count;
for my $i ( $ibeg .. $iend ) {
# concatenate the text of the consecutive tokens to form
# the field
push( @fields,
- join( '', @tokens_to_go[ $i_start .. $i - 1 ] ) );
+ join( EMPTY_STRING, @tokens_to_go[ $i_start .. $i - 1 ] ) );
push @field_lengths,
$summed_lengths_to_go[$i] - $summed_lengths_to_go[$i_start];
# get ready for the next batch
$i_start = $i;
$j++;
- $patterns[$j] = "";
+ $patterns[$j] = EMPTY_STRING;
} ## end if ( new synchronization token
# continue accumulating tokens
# so that we can align things like this:
# Button => "Print letter \"~$_\"",
# -command => [ sub { print "$_[0]\n" }, $_ ],
- if ( $patterns[$j] eq 'm' ) { $patterns[$j] = "" }
+ if ( $patterns[$j] eq 'm' ) {
+ $patterns[$j] = EMPTY_STRING;
+ }
}
}
# remove any zero-level name at first fat comma
if ( $depth == 0 && $type eq '=>' ) {
- $container_name{$depth} = "";
+ $container_name{$depth} = EMPTY_STRING;
}
} ## end for my $i ( $ibeg .. $iend)
# done with this line .. join text of tokens to make the last field
- push( @fields, join( '', @tokens_to_go[ $i_start .. $iend ] ) );
+ push( @fields,
+ join( EMPTY_STRING, @tokens_to_go[ $i_start .. $iend ] ) );
push @field_lengths,
$summed_lengths_to_go[ $iend + 1 ] - $summed_lengths_to_go[$i_start];
# Create an alignment name for it to avoid incorrect alignments.
# Start with the name of the previous nonblank token...
- my $name = "";
+ my $name = EMPTY_STRING;
my $im = $i - 1;
- return "" if ( $im < 0 );
+ return EMPTY_STRING if ( $im < 0 );
if ( $types_to_go[$im] eq 'b' ) { $im--; }
- return "" if ( $im < 0 );
+ return EMPTY_STRING if ( $im < 0 );
$name = $tokens_to_go[$im];
# Prepend any sub name to an isolated -> to avoid unwanted alignments
$name = substr( $name, 2 );
}
return $name;
-}
+} ## end sub make_paren_name
{ ## begin closure final_indentation_adjustment
sub initialize_final_indentation_adjustment {
$last_indentation_written = 0;
$last_unadjusted_indentation = 0;
- $last_leading_token = "";
+ $last_leading_token = EMPTY_STRING;
return;
}
# YVES patch 1 of 2:
# Undo ci of line with leading closing eval brace,
- # but not beyond the indention of the line with
+ # but not beyond the indentation of the line with
# the opening brace.
if (
$block_type_beg eq 'eval'
my $tok = $token_beg;
my $cti = $closing_token_indentation{$tok};
- # Fix the value of 'cti' for an isloated non-welded closing qw
+ # Fix the value of 'cti' for an isolated non-welded closing qw
# delimiter.
if ( $seqno_qw_closing && $ibeg_weld_fix == $ibeg ) {
}
}
- # Full indentaion of closing tokens (-icb and -icp or -cti=2)
+ # Full indentation of closing tokens (-icb and -icp or -cti=2)
else {
# handle -icb (indented closing code block braces)
# Patch to make a line which is the end of a qw quote work with the
# -lp option. Make $token_beg look like a closing token as some
- # type even if it is not. This veriable will become
+ # type even if it is not. This variable will become
# $last_leading_token at the end of this loop. Then, if the -lp
# style is selected, and the next line is also a
# closing token, it will not get more indentation than this line.
return ( $indentation, $lev, $level_end, $terminal_type,
$terminal_block_type, $is_semicolon_terminated,
$is_outdented_line );
- }
+ } ## end sub final_indentation_adjustment
} ## end closure final_indentation_adjustment
sub get_opening_indentation {
get_saved_opening_indentation($seqno);
}
return ( $indent, $offset, $is_leading, $exists );
-}
+} ## end sub get_opening_indentation
sub set_vertical_tightness_flags {
{
# avoid multiple jumps in nesting depth in one line if
# requested
- my $ovt = $opening_vertical_tightness{$token_end};
- my $iend_next = $ri_last->[ $n + 1 ];
+ my $ovt = $opening_vertical_tightness{$token_end};
# Turn off the -vt flag if the next line ends in a weld.
# This avoids an instability with one-line welds (fixes b1183).
$ovt = 0;
}
+ if ( $ovt == 2
+ && $self->[_rreduce_vertical_tightness_by_seqno_]->{$seqno} )
+ {
+ $ovt = 1;
+ }
+
unless (
$ovt < 2
&& ( $nesting_depth_to_go[ $iend_next + 1 ] !=
# Implement cvt=3: like cvt=0 for assigned structures, like cvt=1
# otherwise. Added for rt136417.
if ( $cvt == 3 ) {
- my $seqno = $type_sequence_to_go[$ibeg_next];
$cvt = $self->[_ris_assigned_structure_]->{$seqno} ? 0 : 1;
}
my $ok = 0;
if ( $cvt == 2 || $iend_next == $ibeg_next ) { $ok = 1 }
else {
- my $str = join( '',
+ my $str = join( EMPTY_STRING,
@types_to_go[ $ibeg_next + 1 .. $ibeg_next + 2 ] );
# append closing token if followed by comment or ';'
};
return ($rvertical_tightness_flags);
-}
+} ## end sub set_vertical_tightness_flags
##########################################################
# CODE SECTION 14: Code for creating closing side comments
%block_leading_text = ();
%block_opening_line_number = ();
$csc_new_statement_ok = 1;
- $csc_last_label = "";
+ $csc_last_label = EMPTY_STRING;
%csc_block_label = ();
$rleading_block_if_elsif_text = [];
- $accumulating_text_for_block = "";
+ $accumulating_text_for_block = EMPTY_STRING;
reset_block_text_accumulator();
return;
- }
+ } ## end sub initialize_csc_vars
sub reset_block_text_accumulator {
# save text after 'if' and 'elsif' to append after 'else'
if ($accumulating_text_for_block) {
- if ( $accumulating_text_for_block =~ /^(if|elsif)$/ ) {
+ ## ( $accumulating_text_for_block =~ /^(if|elsif)$/ ) {
+ if ( $is_if_elsif{$accumulating_text_for_block} ) {
push @{$rleading_block_if_elsif_text}, $leading_block_text;
}
}
- $accumulating_text_for_block = "";
- $leading_block_text = "";
+ $accumulating_text_for_block = EMPTY_STRING;
+ $leading_block_text = EMPTY_STRING;
$leading_block_text_level = 0;
$leading_block_text_length_exceeded = 0;
$leading_block_text_line_number = 0;
$leading_block_text_line_length = 0;
return;
- }
+ } ## end sub reset_block_text_accumulator
sub set_block_text_accumulator {
my ( $self, $i ) = @_;
if ( $accumulating_text_for_block !~ /^els/ ) {
$rleading_block_if_elsif_text = [];
}
- $leading_block_text = "";
+ $leading_block_text = EMPTY_STRING;
$leading_block_text_level = $levels_to_go[$i];
$leading_block_text_line_number = $self->get_output_line_number();
$leading_block_text_length_exceeded = 0;
length( $rOpts->{'closing-side-comment-prefix'} ) +
$leading_block_text_level * $rOpts_indent_columns + 3;
return;
- }
+ } ## end sub set_block_text_accumulator
sub accumulate_block_text {
my ( $self, $i ) = @_;
# add an extra space at each newline
if ( $i == 0 && $types_to_go[$i] ne 'b' ) {
- $leading_block_text .= ' ';
+ $leading_block_text .= SPACE;
}
# add the token text
}
}
return;
- }
+ } ## end sub accumulate_block_text
sub accumulate_csc_text {
# the text placed after certain closing block braces.
# Defines and returns the following for this buffer:
- my $block_leading_text = ""; # the leading text of the last '}'
+ my $block_leading_text =
+ EMPTY_STRING; # the leading text of the last '}'
my $rblock_leading_if_elsif_text;
my $i_block_leading_text =
- -1; # index of token owning block_leading_text
- my $block_line_count = 100; # how many lines the block spans
- my $terminal_type = 'b'; # type of last nonblank token
- my $i_terminal = 0; # index of last nonblank token
- my $terminal_block_type = "";
+ -1; # index of token owning block_leading_text
+ my $block_line_count = 100; # how many lines the block spans
+ my $terminal_type = 'b'; # type of last nonblank token
+ my $i_terminal = 0; # index of last nonblank token
+ my $terminal_block_type = EMPTY_STRING;
# update most recent statement label
- $csc_last_label = "" unless ($csc_last_label);
+ $csc_last_label = EMPTY_STRING unless ($csc_last_label);
if ( $types_to_go[0] eq 'J' ) { $csc_last_label = $tokens_to_go[0] }
my $block_label = $csc_last_label;
# set a label for this block, except for
# a bare block which already has the label
# A label can only be used on the next {
- if ( $block_type =~ /:$/ ) { $csc_last_label = "" }
+ if ( $block_type =~ /:$/ ) {
+ $csc_last_label = EMPTY_STRING;
+ }
$csc_block_label{$type_sequence} = $csc_last_label;
- $csc_last_label = "";
+ $csc_last_label = EMPTY_STRING;
if ( $accumulating_text_for_block
&& $levels_to_go[$i] == $leading_block_text_level )
}
# if this line ends in a label then remember it for the next pass
- $csc_last_label = "";
+ $csc_last_label = EMPTY_STRING;
if ( $terminal_type eq 'J' ) {
$csc_last_label = $tokens_to_go[$i_terminal];
}
return ( $terminal_type, $i_terminal, $i_block_leading_text,
$block_leading_text, $block_line_count, $block_label );
- }
+ } ## end sub accumulate_csc_text
sub make_else_csc_text {
return $csc_text;
}
- my $last_elsif_text = "";
+ my $last_elsif_text = EMPTY_STRING;
if ( $count > 1 ) {
$last_elsif_text = ' [elsif' . $rif_elsif_text->[ $count - 1 ];
if ( $count > 2 ) { $last_elsif_text = ' [...' . $last_elsif_text; }
$csc_text .= $last_elsif_text;
}
else {
- $csc_text .= ' ' . $if_text;
+ $csc_text .= SPACE . $if_text;
}
# all done if no length checks requested
$csc_text = $saved_text;
}
return $csc_text;
- }
+ } ## end sub make_else_csc_text
} ## end closure accumulate_csc_text
{ ## begin closure balance_csc_text
# loop to examine characters one-by-one, RIGHT to LEFT and
# build a balancing ending, LEFT to RIGHT.
- for ( my $pos = length($csc) - 1 ; $pos >= 0 ; $pos-- ) {
+ foreach my $pos ( reverse( 0 .. length($csc) - 1 ) ) {
my $char = substr( $csc, $pos, 1 );
# return the balanced string
return $csc;
- }
+ } ## end sub balance_csc_text
} ## end closure balance_csc_text
sub add_closing_side_comment {
{
# then make the closing side comment text
- if ($block_label) { $block_label .= " " }
+ if ($block_label) { $block_label .= SPACE }
my $token =
"$rOpts->{'closing-side-comment-prefix'} $block_label$block_type_to_go[$i_terminal]";
# save the old side comment in a new trailing block
# comment
- my $timestamp = "";
+ my $timestamp = EMPTY_STRING;
if ( $rOpts->{'timestamp'} ) {
my ( $day, $month, $year ) = (localtime)[ 3, 4, 5 ];
$year += 1900;
}
}
return ( $closing_side_comment, $cscw_block_comment );
-}
+} ## end sub add_closing_side_comment
############################
# CODE SECTION 15: Summarize
my $last_added_semicolon_at = $self->[_last_added_semicolon_at_];
if ( $added_semicolon_count > 0 ) {
- my $first = ( $added_semicolon_count > 1 ) ? "First" : "";
+ my $first = ( $added_semicolon_count > 1 ) ? "First" : EMPTY_STRING;
my $what =
( $added_semicolon_count > 1 ) ? "semicolons were" : "semicolon was";
write_logfile_entry("$added_semicolon_count $what added:\n");
my $first_deleted_semicolon_at = $self->[_first_deleted_semicolon_at_];
my $last_deleted_semicolon_at = $self->[_last_deleted_semicolon_at_];
if ( $deleted_semicolon_count > 0 ) {
- my $first = ( $deleted_semicolon_count > 1 ) ? "First" : "";
+ my $first = ( $deleted_semicolon_count > 1 ) ? "First" : EMPTY_STRING;
my $what =
( $deleted_semicolon_count > 1 )
? "semicolons were"
my $first_embedded_tab_at = $self->[_first_embedded_tab_at_];
my $last_embedded_tab_at = $self->[_last_embedded_tab_at_];
if ( $embedded_tab_count > 0 ) {
- my $first = ( $embedded_tab_count > 1 ) ? "First" : "";
+ my $first = ( $embedded_tab_count > 1 ) ? "First" : EMPTY_STRING;
my $what =
( $embedded_tab_count > 1 )
? "quotes or patterns"
|| $rOpts->{'indent-only'};
return;
-}
+} ## end sub wrapup
} ## end package Perl::Tidy::Formatter
1;
package Perl::Tidy::HtmlWriter;
use strict;
use warnings;
-our $VERSION = '20220217';
+our $VERSION = '20220613';
+use English qw( -no_match_vars );
use File::Basename;
+use constant EMPTY_STRING => q{};
+use constant SPACE => q{ };
+
# class variables
use vars qw{
%html_color
BEGIN {
if ( !eval { require HTML::Entities; 1 } ) {
- $missing_html_entities = $@ ? $@ : 1;
+ $missing_html_entities = $EVAL_ERROR ? $EVAL_ERROR : 1;
}
if ( !eval { require Pod::Html; 1 } ) {
- $missing_pod_html = $@ ? $@ : 1;
+ $missing_pod_html = $EVAL_ERROR ? $EVAL_ERROR : 1;
}
}
( $html_fh, my $html_filename ) =
Perl::Tidy::streamhandle( $html_file, 'w' );
unless ($html_fh) {
- Perl::Tidy::Warn("can't open $html_file: $!\n");
+ Perl::Tidy::Warn("can't open $html_file: $ERRNO\n");
return;
}
$html_file_opened = 1;
( $title, my $path ) = fileparse($input_file);
}
my $toc_item_count = 0;
- my $in_toc_package = "";
+ my $in_toc_package = EMPTY_STRING;
my $last_level = 0;
return bless {
_input_file => $input_file, # name of input file
my $end_package_list = sub {
if ( ${$rin_toc_package} ) {
$html_toc_fh->print("</ul>\n</li>\n");
- ${$rin_toc_package} = "";
+ ${$rin_toc_package} = EMPTY_STRING;
}
return;
};
my $css_filename = shift;
my $fh;
unless ( $fh = IO::File->new("> $css_filename") ) {
- Perl::Tidy::Die("can't open $css_filename: $!\n");
+ Perl::Tidy::Die("can't open $css_filename: $ERRNO\n");
}
write_style_sheet_data($fh);
close_object($fh);
my $long_name = $short_to_long_names{$short_name};
my $abbrev = '.' . $short_name;
- if ( length($short_name) == 1 ) { $abbrev .= ' ' } # for alignment
+ if ( length($short_name) == 1 ) { $abbrev .= SPACE } # for alignment
my $color = $html_color{$short_name};
if ( !defined($color) ) { $color = $text_color }
$fh->print("$abbrev \{ color: $color;");
# This routine will write the html selectively and store the toc
my $html_print = sub {
- foreach (@_) {
- $html_fh->print($_) unless ($no_print);
- if ($in_toc) { push @toc, $_ }
+ foreach my $line (@_) {
+ $html_fh->print($line) unless ($no_print);
+ if ($in_toc) { push @toc, $line }
}
return;
};
# the necessary perltidy html sections
my ( $saw_body, $saw_index, $saw_body_end );
- my $timestamp = "";
+ my $timestamp = EMPTY_STRING;
if ( $rOpts->{'timestamp'} ) {
my $date = localtime;
$timestamp = "on $date";
$html_print->("<hr />\n") if $rOpts->{'frames'};
$html_print->("<h2>Code Index:</h2>\n");
##my @toc = map { $_ .= "\n" } split /\n/, $toc_string;
- my @toc = map { $_ . "\n" } split /\n/, $toc_string;
- $html_print->(@toc);
+ my @toc_st = map { $_ . "\n" } split /\n/, $toc_string;
+ $html_print->(@toc_st);
}
- $in_toc = "";
+ $in_toc = EMPTY_STRING;
$no_print = 0;
}
$html_print->("<hr />\n") if $rOpts->{'frames'};
$html_print->("<h2>Code Index:</h2>\n");
##my @toc = map { $_ .= "\n" } split /\n/, $toc_string;
- my @toc = map { $_ . "\n" } split /\n/, $toc_string;
- $html_print->(@toc);
+ my @toc_st = map { $_ . "\n" } split /\n/, $toc_string;
+ $html_print->(@toc_st);
}
- $in_toc = "";
+ $in_toc = EMPTY_STRING;
$ul_level = 0;
$no_print = 0;
}
# because the tmpfile may be one of the names used for frames
if ( -e $tmpfile ) {
unless ( unlink($tmpfile) ) {
- Perl::Tidy::Warn("couldn't unlink temporary file $tmpfile: $!\n");
+ Perl::Tidy::Warn(
+ "couldn't unlink temporary file $tmpfile: $ERRNO\n");
$success_flag = 0;
}
}
$title = escape_html($title);
# FUTURE input parameter:
- my $top_basename = "";
+ my $top_basename = EMPTY_STRING;
# We need to produce 3 html files:
# 1. - the table of contents
# 2. The current .html filename is renamed to be the contents panel
rename( $html_filename, $src_filename )
- or Perl::Tidy::Die("Cannot rename $html_filename to $src_filename:$!\n");
+ or Perl::Tidy::Die(
+ "Cannot rename $html_filename to $src_filename: $ERRNO\n");
# 3. Then use the original html filename for the frame
write_frame_html(
# write a separate html table of contents file for frames
my ( $title, $toc_filename, $src_basename, $rtoc, $src_frame_name ) = @_;
my $fh = IO::File->new( $toc_filename, 'w' )
- or Perl::Tidy::Die("Cannot open $toc_filename:$!\n");
+ or Perl::Tidy::Die("Cannot open $toc_filename: $ERRNO\n");
$fh->print(<<EOM);
<html>
<head>
my $first_anchor =
change_anchor_names( $rtoc, $src_basename, "$src_frame_name" );
- $fh->print( join "", @{$rtoc} );
+ $fh->print( join EMPTY_STRING, @{$rtoc} );
$fh->print(<<EOM);
</body>
) = @_;
my $fh = IO::File->new( $frame_filename, 'w' )
- or Perl::Tidy::Die("Cannot open $toc_basename:$!\n");
+ or Perl::Tidy::Die("Cannot open $toc_basename: $ERRNO\n");
$fh->print(<<EOM);
<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Frameset//EN"
# --------------------------------------------------
my $input_file = $self->{_input_file};
my $title = escape_html($input_file);
- my $timestamp = "";
+ my $timestamp = EMPTY_STRING;
if ( $rOpts->{'timestamp'} ) {
my $date = localtime;
$timestamp = "on $date";
my $rlast_level = $self->{_rlast_level};
my $rpackage_stack = $self->{_rpackage_stack};
- for ( my $j = 0 ; $j < @{$rtoken_type} ; $j++ ) {
+ foreach my $j ( 0 .. @{$rtoken_type} - 1 ) {
$type = $rtoken_type->[$j];
$token = $rtokens->[$j];
$level = $rlevels->[$j];
$type = 'M';
# but don't include sub declarations in the toc;
- # these wlll have leading token types 'i;'
- my $signature = join "", @{$rtoken_type};
+ # these will have leading token types 'i;'
+ my $signature = join EMPTY_STRING, @{$rtoken_type};
unless ( $signature =~ /^i;/ ) {
my $subname = $token;
$subname =~ s/[\s\(].*$//; # remove any attributes and prototype
$html_line = $1;
}
else {
- $html_line = "";
+ $html_line = EMPTY_STRING;
}
my ($rcolored_tokens) =
$self->markup_tokens( $rtokens, $rtoken_type, $rlevels );
- $html_line .= join '', @{$rcolored_tokens};
+ $html_line .= join EMPTY_STRING, @{$rcolored_tokens};
}
# markup line of non-code..
# otherwise, just clear the current string and start
# over
else {
- ${$rpre_string} = "";
+ ${$rpre_string} = EMPTY_STRING;
$html_pod_fh->print("\n");
}
}
# add the line number if requested
if ( $rOpts->{'html-line-numbers'} ) {
my $extra_space =
- ( $line_number < 10 ) ? " "
- : ( $line_number < 100 ) ? " "
- : ( $line_number < 1000 ) ? " "
- : "";
- $html_line = $extra_space . $line_number . " " . $html_line;
+ ( $line_number < 10 ) ? SPACE x 3
+ : ( $line_number < 100 ) ? SPACE x 2
+ : ( $line_number < 1000 ) ? SPACE
+ : EMPTY_STRING;
+ $html_line = $extra_space . $line_number . SPACE . $html_line;
}
# write the line
use strict;
use warnings;
use Carp;
-our $VERSION = '20220217';
+our $VERSION = '20220613';
+
+use constant EMPTY_STRING => q{};
sub AUTOLOAD {
}
if ( $mode eq 'w' ) {
- ${$rscalar} = "";
+ ${$rscalar} = EMPTY_STRING;
return bless [ $rscalar, $mode ], $package;
}
elsif ( $mode eq 'r' ) {
use strict;
use warnings;
use Carp;
-our $VERSION = '20220217';
+our $VERSION = '20220613';
sub AUTOLOAD {
package Perl::Tidy::IndentationItem;
use strict;
use warnings;
-our $VERSION = '20220217';
+our $VERSION = '20220613';
BEGIN {
_stack_depth_ => $i++,
_K_begin_line_ => $i++,
_arrow_count_ => $i++,
+ _standard_spaces_ => $i++,
};
}
$self->[_stack_depth_] = $input_hash{stack_depth};
$self->[_K_begin_line_] = $input_hash{K_begin_line};
$self->[_arrow_count_] = 0;
+ $self->[_standard_spaces_] = $input_hash{standard_spaces};
bless $self, $class;
return $self;
return $_[0]->[_spaces_];
}
+sub get_standard_spaces {
+ return $_[0]->[_standard_spaces_];
+}
+
sub get_marked {
return $_[0]->[_marked_];
}
package Perl::Tidy::LineBuffer;
use strict;
use warnings;
-our $VERSION = '20220217';
+our $VERSION = '20220613';
sub AUTOLOAD {
package Perl::Tidy::LineSink;
use strict;
use warnings;
-our $VERSION = '20220217';
+our $VERSION = '20220613';
sub AUTOLOAD {
package Perl::Tidy::LineSource;
use strict;
use warnings;
-our $VERSION = '20220217';
+our $VERSION = '20220613';
sub AUTOLOAD {
package Perl::Tidy::Logger;
use strict;
use warnings;
-our $VERSION = '20220217';
+our $VERSION = '20220613';
+use English qw( -no_match_vars );
+
+use constant EMPTY_STRING => q{};
+use constant SPACE => q{ };
sub AUTOLOAD {
# required to avoid call to AUTOLOAD in some versions of perl
}
+use constant DEFAULT_LOGFILE_GAP => 50;
+
sub new {
my ( $class, @args ) = @_;
log_file => undef,
warning_file => undef,
fh_stderr => undef,
- saw_extruce => undef,
display_name => undef,
is_encoded_data => undef,
);
my $log_file = $args{log_file};
my $warning_file = $args{warning_file};
my $fh_stderr = $args{fh_stderr};
- my $saw_extrude = $args{saw_extrude};
my $display_name = $args{display_name};
my $is_encoded_data = $args{is_encoded_data};
if ( -e $warning_file ) {
unlink($warning_file)
or Perl::Tidy::Die(
- "couldn't unlink warning file $warning_file: $!\n");
+ "couldn't unlink warning file $warning_file: $ERRNO\n");
}
}
my $logfile_gap =
defined( $rOpts->{'logfile-gap'} )
? $rOpts->{'logfile-gap'}
- : 50;
+ : DEFAULT_LOGFILE_GAP;
if ( $logfile_gap == 0 ) { $logfile_gap = 1 }
my $filename_stamp = $display_name ? $display_name . ':' : "??";
_is_encoded_data => $is_encoded_data,
_saw_code_bug => -1, # -1=no 0=maybe 1=for sure
_saw_brace_error => 0,
- _saw_extrude => $saw_extrude,
_output_array => [],
_input_stream_name => $input_stream_name,
_filename_stamp => $filename_stamp,
}
# record some stuff in case we go down in flames
+use constant MAX_PRINTED_CHARS => 35;
+
sub black_box {
my ( $self, $line_of_tokens, $output_line_number ) = @_;
my $input_line = $line_of_tokens->{_line_text};
$out_str = ( '.' x $structural_indentation_level ) . $out_str;
- if ( length($out_str) > 35 ) {
- $out_str = substr( $out_str, 0, 35 ) . " ....";
+ if ( length($out_str) > MAX_PRINTED_CHARS ) {
+ $out_str = substr( $out_str, 0, MAX_PRINTED_CHARS ) . " ....";
}
- $self->logfile_output( "", "$out_str\n" );
+ $self->logfile_output( EMPTY_STRING, "$out_str\n" );
}
return;
}
my $self = shift;
my $line_of_tokens = $self->{_line_of_tokens};
my $input_line_number = $line_of_tokens->{_line_number};
- my $line_information_string = "";
+ my $line_information_string = EMPTY_STRING;
if ($input_line_number) {
my $output_line_number = $self->{_output_line_number};
# keep logfile columns aligned for scripts up to 999 lines;
# for longer scripts it doesn't really matter
- my $extra_space = "";
+ my $extra_space = EMPTY_STRING;
$extra_space .=
- ( $input_line_number < 10 ) ? " "
- : ( $input_line_number < 100 ) ? " "
- : "";
+ ( $input_line_number < 10 ) ? SPACE x 2
+ : ( $input_line_number < 100 ) ? SPACE
+ : EMPTY_STRING;
$extra_space .=
- ( $output_line_number < 10 ) ? " "
- : ( $output_line_number < 100 ) ? " "
- : "";
+ ( $output_line_number < 10 ) ? SPACE x 2
+ : ( $output_line_number < 100 ) ? SPACE
+ : EMPTY_STRING;
# there are 2 possible nesting strings:
# the original which looks like this: (0 [1 {2
if ( length($nesting_string_new) <= 8 ) {
$nesting_string =
- $nesting_string_new . " " x ( 8 - length($nesting_string_new) );
+ $nesting_string_new . SPACE x ( 8 - length($nesting_string_new) );
}
$line_information_string =
"L$input_line_number:$output_line_number$extra_space i$guessed_indentation_level:$structural_indentation_level $ci_level $bk $nesting_string";
sub brace_warning {
my ( $self, $msg ) = @_;
- #use constant BRACE_WARNING_LIMIT => 10;
- my $BRACE_WARNING_LIMIT = 10;
- my $saw_brace_error = $self->{_saw_brace_error};
+ use constant BRACE_WARNING_LIMIT => 10;
+ my $saw_brace_error = $self->{_saw_brace_error};
- if ( $saw_brace_error < $BRACE_WARNING_LIMIT ) {
+ if ( $saw_brace_error < BRACE_WARNING_LIMIT ) {
$self->warning($msg);
}
$saw_brace_error++;
$self->{_saw_brace_error} = $saw_brace_error;
- if ( $saw_brace_error == $BRACE_WARNING_LIMIT ) {
+ if ( $saw_brace_error == BRACE_WARNING_LIMIT ) {
$self->warning("No further warnings of this type will be given\n");
}
return;
# report errors to .ERR file (or stdout)
my ( $self, $msg ) = @_;
- #use constant WARNING_LIMIT => 50;
- my $WARNING_LIMIT = 50;
+ use constant WARNING_LIMIT => 50;
# Always bump the warn count, even if no message goes out
Perl::Tidy::Warn_count_bump();
my $warning_file = $self->{_warning_file};
( $fh_warnings, my $filename ) =
Perl::Tidy::streamhandle( $warning_file, 'w', $is_encoded_data );
- $fh_warnings or Perl::Tidy::Die("couldn't open $filename $!\n");
+ $fh_warnings
+ or Perl::Tidy::Die("couldn't open $filename: $ERRNO\n");
Perl::Tidy::Warn_msg("## Please see file $filename\n")
unless ref($warning_file);
$self->{_fh_warnings} = $fh_warnings;
my $filename_stamp = $self->{_filename_stamp};
- if ( $warning_count < $WARNING_LIMIT ) {
+ if ( $warning_count < WARNING_LIMIT ) {
if ( !$warning_count ) {
# Turn off filename stamping unless error output is directed
# to the standard error output (with -se flag)
if ( !$rOpts->{'standard-error-output'} ) {
- $filename_stamp = "";
+ $filename_stamp = EMPTY_STRING;
$self->{_filename_stamp} = $filename_stamp;
}
}
# add prefix 'filename: ' to message lines
if ($filename_stamp) {
- my $pre_string = $filename_stamp . " ";
+ my $pre_string = $filename_stamp . SPACE;
chomp $msg;
$msg =~ s/\n/\n$pre_string/g;
$msg = $pre_string . $msg . "\n";
$warning_count++;
$self->{_warning_count} = $warning_count;
- if ( $warning_count == $WARNING_LIMIT ) {
+ if ( $warning_count == WARNING_LIMIT ) {
$fh_warnings->print(
$filename_stamp . "No further warnings will be given\n" );
}
}
if ($save_logfile) {
- my $log_file = $self->{_log_file};
my $is_encoded_data = $self->{_is_encoded_data};
my ( $fh, $filename ) =
Perl::Tidy::streamhandle( $log_file, 'w', $is_encoded_data );
if ($fh) {
my $routput_array = $self->{_output_array};
- foreach ( @{$routput_array} ) { $fh->print($_) }
+ foreach my $line ( @{$routput_array} ) { $fh->print($line) }
if ( $log_file ne '-' && !ref $log_file ) {
eval { $fh->close() };
}
package Perl::Tidy::Tokenizer;
use strict;
use warnings;
-our $VERSION = '20220217';
+use English qw( -no_match_vars );
-# this can be turned on for extra checking during development
-use constant DEVEL_MODE => 0;
+our $VERSION = '20220613';
+
+use constant DEVEL_MODE => 0;
+use constant EMPTY_STRING => q{};
+use constant SPACE => q{ };
use Perl::Tidy::LineBuffer;
use Carp;
%expecting_term_types
%expecting_term_token
%is_digraph
+ %can_start_digraph
%is_file_test_operator
%is_trigraph
%is_tetragraph
%is_keyword
%is_code_block_token
%is_sort_map_grep_eval_do
+ %is_sort_map_grep
%is_grep_alias
%really_want_term
@opening_brace_names
%is_keyword_taking_optional_arg
%is_keyword_rejecting_slash_as_pattern_delimiter
%is_keyword_rejecting_question_as_pattern_delimiter
+ %is_q_qq_qx_qr_s_y_tr_m
%is_q_qq_qw_qx_qr_s_y_tr_m
%is_sub
%is_package
%is_comma_question_colon
+ %is_if_elsif_unless
+ %is_if_elsif_unless_case_when
%other_line_endings
+ %is_END_DATA_format_sub
+ %is_semicolon_or_t
$code_skipping_pattern_begin
$code_skipping_pattern_end
};
======================================================================
EOM
exit 1;
-}
+} ## end sub AUTOLOAD
sub Die {
my ($msg) = @_;
# We shouldn't get here, but this return is to keep Perl-Critic from
# complaining.
return;
-}
+} ## end sub Fault
sub bad_pattern {
# by this program.
my ($pattern) = @_;
eval "'##'=~/$pattern/";
- return $@;
+ return $EVAL_ERROR;
}
sub make_code_skipping_pattern {
);
}
return $pattern;
-}
+} ## end sub make_code_skipping_pattern
sub check_options {
%is_sub = ();
$is_sub{'sub'} = 1;
+ %is_END_DATA_format_sub = (
+ '__END__' => 1,
+ '__DATA__' => 1,
+ 'format' => 1,
+ 'sub' => 1,
+ );
+
# Install any aliases to 'sub'
if ( $rOpts->{'sub-alias-list'} ) {
# for example, it might be 'sub method fun'
my @sub_alias_list = split /\s+/, $rOpts->{'sub-alias-list'};
foreach my $word (@sub_alias_list) {
- $is_sub{$word} = 1;
+ $is_sub{$word} = 1;
+ $is_END_DATA_format_sub{$word} = 1;
}
}
$code_skipping_pattern_end =
make_code_skipping_pattern( $rOpts, 'code-skipping-end', '#>>V' );
return;
-}
+} ## end sub check_options
sub new {
my $self = [];
$self->[_rhere_target_list_] = [];
$self->[_in_here_doc_] = 0;
- $self->[_here_doc_target_] = "";
- $self->[_here_quote_character_] = "";
+ $self->[_here_doc_target_] = EMPTY_STRING;
+ $self->[_here_quote_character_] = EMPTY_STRING;
$self->[_in_data_] = 0;
$self->[_in_end_] = 0;
$self->[_in_format_] = 0;
$self->[_in_skipped_] = 0;
$self->[_in_attribute_list_] = 0;
$self->[_in_quote_] = 0;
- $self->[_quote_target_] = "";
+ $self->[_quote_target_] = EMPTY_STRING;
$self->[_line_start_quote_] = -1;
$self->[_starting_level_] = $args{starting_level};
$self->[_know_starting_level_] = defined( $args{starting_level} );
$self->[_unexpected_error_count_] = 0;
$self->[_started_looking_for_here_target_at_] = 0;
$self->[_nearly_matched_here_target_at_] = undef;
- $self->[_line_of_text_] = "";
+ $self->[_line_of_text_] = EMPTY_STRING;
$self->[_rlower_case_labels_at_] = undef;
$self->[_extended_syntax_] = $args{extended_syntax};
$self->[_maximum_level_] = 0;
$rOpts->{'maximum-unexpected-errors'};
$self->[_rOpts_logfile_] = $rOpts->{'logfile'};
$self->[_rOpts_] = $rOpts;
+
+ # These vars are used for guessing indentation and must be positive
+ $self->[_tabsize_] = 8 if ( !$self->[_tabsize_] );
+ $self->[_indent_columns_] = 4 if ( !$self->[_indent_columns_] );
+
bless $self, $class;
$tokenizer_self = $self;
return $self;
-}
+} ## end sub new
# interface to Perl::Tidy::Logger routines
sub warning {
}
sub get_input_stream_name {
- my $input_stream_name = "";
+ my $input_stream_name = EMPTY_STRING;
my $logger_object = $tokenizer_self->[_logger_object_];
if ($logger_object) {
$input_stream_name = $logger_object->get_input_stream_name();
my $msg = shift;
my $logger_object = $tokenizer_self->[_logger_object_];
if ($logger_object) {
+ my $input_line_number = $tokenizer_self->[_last_line_number_] + 1;
+ $msg = "Line $input_line_number: $msg";
$logger_object->complain($msg);
}
return;
-}
+} ## end sub complain
sub write_logfile_entry {
my $msg = shift;
my ($self) = @_;
# Report any tokenization errors and return a flag '$severe_error'.
- # Set $severe_error = 1 if the tokenizations errors are so severe that
+ # Set $severe_error = 1 if the tokenization errors are so severe that
# the formatter should not attempt to format the file. Instead, it will
# just output the file verbatim.
check_final_nesting_depths();
# Likewise, large numbers of brace errors usually indicate non-perl
- # scirpts, so set the severe error flag at a low number. This is similar
+ # scripts, so set the severe error flag at a low number. This is similar
# to the level check, but different because braces may balance but be
# incorrectly interlaced.
if ( $tokenizer_self->[_true_brace_error_count_] > 2 ) {
@{ $tokenizer_self->[_rlower_case_labels_at_] };
write_logfile_entry(
"Suggest using upper case characters in label(s)\n");
- local $" = ')(';
+ local $LIST_SEPARATOR = ')(';
write_logfile_entry(" defined at line(s): (@lower_case_labels_at)\n");
}
return $severe_error;
-}
+} ## end sub report_tokenization_errors
sub report_v_string {
);
}
return;
-}
+} ## end sub report_v_string
sub is_valid_token_type {
my ($type) = @_;
# Find and remove what characters terminate this line, including any
# control r
- my $input_line_separator = "";
- if ( chomp($input_line) ) { $input_line_separator = $/ }
+ my $input_line_separator = EMPTY_STRING;
+ if ( chomp($input_line) ) {
+ $input_line_separator = $INPUT_RECORD_SEPARATOR;
+ }
# The first test here very significantly speeds things up, but be sure to
# keep the regex and hash %other_line_endings the same.
_curly_brace_depth => $brace_depth,
_square_bracket_depth => $square_bracket_depth,
_paren_depth => $paren_depth,
- _quote_character => '',
+ _quote_character => EMPTY_STRING,
## _rtoken_type => undef,
## _rtokens => undef,
## _rlevels => undef,
-## _rslevels => undef,
## _rblock_type => undef,
## _rcontainer_type => undef,
## _rcontainer_environment => undef,
}
else {
$tokenizer_self->[_in_here_doc_] = 0;
- $tokenizer_self->[_here_doc_target_] = "";
- $tokenizer_self->[_here_quote_character_] = "";
+ $tokenizer_self->[_here_doc_target_] = EMPTY_STRING;
+ $tokenizer_self->[_here_quote_character_] = EMPTY_STRING;
}
}
return $line_of_tokens;
}
- # Update indentation levels for log messages.
- # Skip blank lines and also block comments, unless a logfile is requested.
- # Note that _line_of_text_ is the input line but trimmed from left to right.
- my $lot = $tokenizer_self->[_line_of_text_];
- if ( $lot && ( $self->[_rOpts_logfile_] || substr( $lot, 0, 1 ) ne '#' ) ) {
- my $rlevels = $line_of_tokens->{_rlevels};
- $line_of_tokens->{_guessed_indentation_level} =
- guess_old_indentation_level($input_line);
- }
-
# see if this line contains here doc targets
my $rhere_target_list = $tokenizer_self->[_rhere_target_list_];
if ( @{$rhere_target_list} ) {
# we are returning a line of CODE
return $line_of_tokens;
-}
+} ## end sub get_line
sub find_starting_indentation_level {
my $i = 0;
# keep looking at lines until we find a hash bang or piece of code
- my $msg = "";
+ my $msg = EMPTY_STRING;
while ( $line =
$tokenizer_self->[_line_buffer_object_]->peek_ahead( $i++ ) )
{
$tokenizer_self->[_starting_level_] = $starting_level;
reset_indentation_level($starting_level);
return;
-}
+} ## end sub find_starting_indentation_level
sub guess_old_indentation_level {
my ($line) = @_;
$indent_columns = 4 if ( !$indent_columns );
$level = int( $spaces / $indent_columns );
return ($level);
-}
+} ## end sub guess_old_indentation_level
# This is a currently unused debug routine
sub dump_functions {
$fh->print("\nnon-constant subs in package $pkg\n");
foreach my $sub ( keys %{ $is_user_function{$pkg} } ) {
- my $msg = "";
+ my $msg = EMPTY_STRING;
if ( $is_block_list_function{$pkg}{$sub} ) {
$msg = 'block_list';
}
}
}
return;
-}
+} ## end sub dump_functions
sub prepare_for_a_new_file {
# previous tokens needed to determine what to expect next
$last_nonblank_token = ';'; # the only possible starting state which
$last_nonblank_type = ';'; # will make a leading brace a code block
- $last_nonblank_block_type = '';
+ $last_nonblank_block_type = EMPTY_STRING;
# scalars for remembering statement types across multiple lines
- $statement_type = ''; # '' or 'use' or 'sub..' or 'case..'
+ $statement_type = EMPTY_STRING; # '' or 'use' or 'sub..' or 'case..'
$in_attribute_list = 0;
# scalars for remembering where we are in the file
$context = UNKNOWN_CONTEXT;
# hashes used to remember function information
- %is_constant = (); # user-defined constants
- %is_user_function = (); # user-defined functions
- %user_function_prototype = (); # their prototypes
+ %is_constant = (); # user-defined constants
+ %is_user_function = (); # user-defined functions
+ %user_function_prototype = (); # their prototypes
%is_block_function = ();
%is_block_list_function = ();
%saw_function_definition = ();
@nested_statement_type = ();
@starting_line_of_current_depth = ();
- $paren_type[$paren_depth] = '';
+ $paren_type[$paren_depth] = EMPTY_STRING;
$paren_semicolon_count[$paren_depth] = 0;
- $paren_structural_type[$brace_depth] = '';
+ $paren_structural_type[$brace_depth] = EMPTY_STRING;
$brace_type[$brace_depth] = ';'; # identify opening brace as code block
- $brace_structural_type[$brace_depth] = '';
+ $brace_structural_type[$brace_depth] = EMPTY_STRING;
$brace_context[$brace_depth] = UNKNOWN_CONTEXT;
$brace_package[$paren_depth] = $current_package;
- $square_bracket_type[$square_bracket_depth] = '';
- $square_bracket_structural_type[$square_bracket_depth] = '';
+ $square_bracket_type[$square_bracket_depth] = EMPTY_STRING;
+ $square_bracket_structural_type[$square_bracket_depth] = EMPTY_STRING;
initialize_tokenizer_state();
return;
-}
+} ## end sub prepare_for_a_new_file
{ ## closure for sub tokenize_this_line
# TV3:
$in_quote = 0;
$quote_type = 'Q';
- $quote_character = "";
+ $quote_character = EMPTY_STRING;
$quote_pos = 0;
$quote_depth = 0;
- $quoted_string_1 = "";
- $quoted_string_2 = "";
- $allowed_quote_modifiers = "";
+ $quoted_string_1 = EMPTY_STRING;
+ $quoted_string_2 = EMPTY_STRING;
+ $allowed_quote_modifiers = EMPTY_STRING;
# TV4:
- $id_scan_state = '';
- $identifier = '';
- $want_paren = "";
+ $id_scan_state = EMPTY_STRING;
+ $identifier = EMPTY_STRING;
+ $want_paren = EMPTY_STRING;
$indented_if_level = 0;
# TV5:
- $nesting_token_string = "";
- $nesting_type_string = "";
- $nesting_block_string = '1'; # initially in a block
- $nesting_block_flag = 1;
- $nesting_list_string = '0'; # initially not in a list
- $nesting_list_flag = 0; # initially not in a list
- $ci_string_in_tokenizer = "";
+ $nesting_token_string = EMPTY_STRING;
+ $nesting_type_string = EMPTY_STRING;
+ $nesting_block_string = '1'; # initially in a block
+ $nesting_block_flag = 1;
+ $nesting_list_string = '0'; # initially not in a list
+ $nesting_list_flag = 0; # initially not in a list
+ $ci_string_in_tokenizer = EMPTY_STRING;
$continuation_string_in_tokenizer = "0";
$in_statement_continuation = 0;
$level_in_tokenizer = 0;
$rslevel_stack = [];
# TV6:
- $last_nonblank_container_type = '';
- $last_nonblank_type_sequence = '';
+ $last_nonblank_container_type = EMPTY_STRING;
+ $last_nonblank_type_sequence = EMPTY_STRING;
$last_last_nonblank_token = ';';
$last_last_nonblank_type = ';';
- $last_last_nonblank_block_type = '';
- $last_last_nonblank_container_type = '';
- $last_last_nonblank_type_sequence = '';
- $last_nonblank_prototype = "";
+ $last_last_nonblank_block_type = EMPTY_STRING;
+ $last_last_nonblank_container_type = EMPTY_STRING;
+ $last_last_nonblank_type_sequence = EMPTY_STRING;
+ $last_nonblank_prototype = EMPTY_STRING;
return;
- }
+ } ## end sub initialize_tokenizer_state
sub save_tokenizer_state {
$last_nonblank_prototype,
];
return [ $rTV1, $rTV2, $rTV3, $rTV4, $rTV5, $rTV6 ];
- }
+ } ## end sub save_tokenizer_state
sub restore_tokenizer_state {
my ($rstate) = @_;
$last_nonblank_prototype,
) = @{$rTV6};
return;
- }
+ } ## end sub restore_tokenizer_state
sub split_pretoken {
# Split $tok into up to 3 tokens:
my $tok_0 = substr( $pretoken, 0, $numc );
- my $tok_1 = defined($1) ? $1 : "";
- my $tok_2 = defined($2) ? $2 : "";
+ my $tok_1 = defined($1) ? $1 : EMPTY_STRING;
+ my $tok_2 = defined($2) ? $2 : EMPTY_STRING;
my $len_0 = length($tok_0);
my $len_1 = length($tok_1);
}
}
return;
- }
+ } ## end sub split_pretoken
sub get_indentation_level {
# end of tokenizer variable access and manipulation routines
# ------------------------------------------------------------
+ #------------------------------
+ # beginning of tokenizer hashes
+ #------------------------------
+
+ my %matching_start_token = ( '}' => '{', ']' => '[', ')' => '(' );
+
+ # These block types terminate statements and do not need a trailing
+ # semicolon
+ # patched for SWITCH/CASE/
+ my %is_zero_continuation_block_type;
+ my @q;
+ @q = qw( } { BEGIN END CHECK INIT AUTOLOAD DESTROY UNITCHECK continue ;
+ if elsif else unless while until for foreach switch case given when);
+ @is_zero_continuation_block_type{@q} = (1) x scalar(@q);
+
+ my %is_logical_container;
+ @q = qw(if elsif unless while and or err not && ! || for foreach);
+ @is_logical_container{@q} = (1) x scalar(@q);
+
+ my %is_binary_type;
+ @q = qw(|| &&);
+ @is_binary_type{@q} = (1) x scalar(@q);
+
+ my %is_binary_keyword;
+ @q = qw(and or err eq ne cmp);
+ @is_binary_keyword{@q} = (1) x scalar(@q);
+
+ # 'L' is token for opening { at hash key
+ my %is_opening_type;
+ @q = qw< L { ( [ >;
+ @is_opening_type{@q} = (1) x scalar(@q);
+
+ # 'R' is token for closing } at hash key
+ my %is_closing_type;
+ @q = qw< R } ) ] >;
+ @is_closing_type{@q} = (1) x scalar(@q);
+
+ my %is_redo_last_next_goto;
+ @q = qw(redo last next goto);
+ @is_redo_last_next_goto{@q} = (1) x scalar(@q);
+
+ my %is_use_require;
+ @q = qw(use require);
+ @is_use_require{@q} = (1) x scalar(@q);
+
+ # This hash holds the array index in $tokenizer_self for these keywords:
+ # Fix for issue c035: removed 'format' from this hash
+ my %is_END_DATA = (
+ '__END__' => _in_end_,
+ '__DATA__' => _in_data_,
+ );
+
+ my %is_list_end_type;
+ @q = qw( ; { } );
+ push @q, ',';
+ @is_list_end_type{@q} = (1) x scalar(@q);
+
+ # original ref: camel 3 p 147,
+ # but perl may accept undocumented flags
+ # perl 5.10 adds 'p' (preserve)
+ # Perl version 5.22 added 'n'
+ # From http://perldoc.perl.org/perlop.html we have
+ # /PATTERN/msixpodualngc or m?PATTERN?msixpodualngc
+ # s/PATTERN/REPLACEMENT/msixpodualngcer
+ # y/SEARCHLIST/REPLACEMENTLIST/cdsr
+ # tr/SEARCHLIST/REPLACEMENTLIST/cdsr
+ # qr/STRING/msixpodualn
+ my %quote_modifiers = (
+ 's' => '[msixpodualngcer]',
+ 'y' => '[cdsr]',
+ 'tr' => '[cdsr]',
+ 'm' => '[msixpodualngc]',
+ 'qr' => '[msixpodualn]',
+ 'q' => EMPTY_STRING,
+ 'qq' => EMPTY_STRING,
+ 'qw' => EMPTY_STRING,
+ 'qx' => EMPTY_STRING,
+ );
+
+ # table showing how many quoted things to look for after quote operator..
+ # s, y, tr have 2 (pattern and replacement)
+ # others have 1 (pattern only)
+ my %quote_items = (
+ 's' => 2,
+ 'y' => 2,
+ 'tr' => 2,
+ 'm' => 1,
+ 'qr' => 1,
+ 'q' => 1,
+ 'qq' => 1,
+ 'qw' => 1,
+ 'qx' => 1,
+ );
+
+ my %is_for_foreach;
+ @_ = qw(for foreach);
+ @is_for_foreach{@_} = (1) x scalar(@_);
+
+ my %is_my_our_state;
+ @_ = qw(my our state);
+ @is_my_our_state{@_} = (1) x scalar(@_);
+
+ # These keywords may introduce blocks after parenthesized expressions,
+ # in the form:
+ # keyword ( .... ) { BLOCK }
+ # patch for SWITCH/CASE: added 'switch' 'case' 'given' 'when'
+ my %is_blocktype_with_paren;
+ @_ =
+ qw(if elsif unless while until for foreach switch case given when catch);
+ @is_blocktype_with_paren{@_} = (1) x scalar(@_);
+
+ my %is_case_default;
+ @_ = qw(case default);
+ @is_case_default{@_} = (1) x scalar(@_);
+
+ #------------------------
+ # end of tokenizer hashes
+ #------------------------
+
# ------------------------------------------------------------
# beginning of various scanner interface routines
# ------------------------------------------------------------
# return the here doc targets
return $rht;
- }
+ } ## end sub scan_replacement_text
sub scan_bare_identifier {
( $i, $tok, $type, $prototype ) =
}
sub scan_identifier {
- ( $i, $tok, $type, $id_scan_state, $identifier ) =
- scan_identifier_do( $i, $id_scan_state, $identifier, $rtokens,
+ (
+ $i, $tok, $type, $id_scan_state, $identifier,
+ my $split_pretoken_flag
+ )
+ = scan_complex_identifier( $i, $id_scan_state, $identifier, $rtokens,
$max_token_index, $expecting, $paren_type[$paren_depth] );
# Check for signal to fix a special variable adjacent to a keyword,
# such as '$^One$0'.
- if ( $id_scan_state eq '^' ) {
+ if ($split_pretoken_flag) {
# Try to fix it by splitting the pretoken
if ( $i > 0
EOM
resume_logfile();
}
- $id_scan_state = "";
}
return;
- }
+ } ## end sub scan_identifier
use constant VERIFY_FASTSCAN => 0;
my %fast_scan_context;
);
}
- sub scan_identifier_fast {
+ sub scan_simple_identifier {
# This is a wrapper for sub scan_identifier. It does a fast preliminary
# scan for certain common identifiers:
# look for $var, @var, ...
if ( $rtoken_type->[ $i + 1 ] eq 'w' ) {
- my $pretype_next = "";
+ my $pretype_next = EMPTY_STRING;
my $i_next = $i + 2;
if ( $i_next <= $max_token_index ) {
if ( $rtoken_type->[$i_next] eq 'b'
# We will call the full method
my $identifier_simple = $identifier;
my $tok_simple = $tok;
- my $fast_scan_type = $type;
my $i_simple = $i;
my $context_simple = $context;
|| $context ne $context_simple )
{
print STDERR <<EOM;
-scan_identifier_fast differs from scan_identifier:
+scan_simple_identifier differs from scan_identifier:
simple: i=$i_simple, tok=$tok_simple, type=$fast_scan_type, ident=$identifier_simple, context='$context_simple
full: i=$i, tok=$tok, type=$type, ident=$identifier, context='$context state=$id_scan_state
EOM
scan_identifier();
}
return;
- }
+ } ## end sub scan_simple_identifier
sub scan_id {
( $i, $tok, $type, $id_scan_state ) =
my $typ_d = $rtoken_type->[$i_d];
# check for signed integer
- my $sign = "";
+ my $sign = EMPTY_STRING;
if ( $typ_d ne 'd'
&& ( $typ_d eq '+' || $typ_d eq '-' )
&& $i_d < $max_token_index )
$number = scan_number();
}
return $number;
- }
+ } ## end sub scan_number_fast
# a sub to warn if token found where term expected
sub error_if_expecting_TERM {
}
}
return;
- }
+ } ## end sub error_if_expecting_TERM
# a sub to warn if token found where operator expected
sub error_if_expecting_OPERATOR {
return 1;
}
return;
- }
+ } ## end sub error_if_expecting_OPERATOR
# ------------------------------------------------------------
# end scanner interfaces
# ------------------------------------------------------------
- my %is_for_foreach;
- @_ = qw(for foreach);
- @is_for_foreach{@_} = (1) x scalar(@_);
+ #------------------
+ # Tokenization subs
+ #------------------
+ sub do_GREATER_THAN_SIGN {
- my %is_my_our_state;
- @_ = qw(my our state);
- @is_my_our_state{@_} = (1) x scalar(@_);
+ # '>'
+ error_if_expecting_TERM()
+ if ( $expecting == TERM );
+ return;
+ }
- # These keywords may introduce blocks after parenthesized expressions,
- # in the form:
- # keyword ( .... ) { BLOCK }
- # patch for SWITCH/CASE: added 'switch' 'case' 'given' 'when'
- my %is_blocktype_with_paren;
- @_ =
- qw(if elsif unless while until for foreach switch case given when catch);
- @is_blocktype_with_paren{@_} = (1) x scalar(@_);
+ sub do_VERTICAL_LINE {
- my %is_case_default;
- @_ = qw(case default);
- @is_case_default{@_} = (1) x scalar(@_);
+ # '|'
+ error_if_expecting_TERM()
+ if ( $expecting == TERM );
+ return;
+ }
- # ------------------------------------------------------------
- # begin hash of code for handling most token types
- # ------------------------------------------------------------
- my $tokenization_code = {
+ sub do_DOLLAR_SIGN {
- # no special code for these types yet, but syntax checks
- # could be added
-
-## '!' => undef,
-## '!=' => undef,
-## '!~' => undef,
-## '%=' => undef,
-## '&&=' => undef,
-## '&=' => undef,
-## '+=' => undef,
-## '-=' => undef,
-## '..' => undef,
-## '..' => undef,
-## '...' => undef,
-## '.=' => undef,
-## '<<=' => undef,
-## '<=' => undef,
-## '<=>' => undef,
-## '<>' => undef,
-## '=' => undef,
-## '==' => undef,
-## '=~' => undef,
-## '>=' => undef,
-## '>>' => undef,
-## '>>=' => undef,
-## '\\' => undef,
-## '^=' => undef,
-## '|=' => undef,
-## '||=' => undef,
-## '//=' => undef,
-## '~' => undef,
-## '~~' => undef,
-## '!~~' => undef,
-
- '>' => sub {
- error_if_expecting_TERM()
- if ( $expecting == TERM );
- },
- '|' => sub {
- error_if_expecting_TERM()
- if ( $expecting == TERM );
- },
- '$' => sub {
-
- # start looking for a scalar
- error_if_expecting_OPERATOR("Scalar")
- if ( $expecting == OPERATOR );
- scan_identifier_fast();
+ # '$'
+ # start looking for a scalar
+ error_if_expecting_OPERATOR("Scalar")
+ if ( $expecting == OPERATOR );
+ scan_simple_identifier();
- if ( $identifier eq '$^W' ) {
- $tokenizer_self->[_saw_perl_dash_w_] = 1;
- }
+ if ( $identifier eq '$^W' ) {
+ $tokenizer_self->[_saw_perl_dash_w_] = 1;
+ }
- # Check for identifier in indirect object slot
- # (vorboard.pl, sort.t). Something like:
- # /^(print|printf|sort|exec|system)$/
- if (
- $is_indirect_object_taker{$last_nonblank_token}
- || ( ( $last_nonblank_token eq '(' )
- && $is_indirect_object_taker{ $paren_type[$paren_depth] } )
- || ( $last_nonblank_type eq 'w'
- || $last_nonblank_type eq 'U' ) # possible object
- )
- {
+ # Check for identifier in indirect object slot
+ # (vorboard.pl, sort.t). Something like:
+ # /^(print|printf|sort|exec|system)$/
+ if (
+ $is_indirect_object_taker{$last_nonblank_token}
+ || ( ( $last_nonblank_token eq '(' )
+ && $is_indirect_object_taker{ $paren_type[$paren_depth] } )
+ || ( $last_nonblank_type eq 'w'
+ || $last_nonblank_type eq 'U' ) # possible object
+ )
+ {
- # An identifier followed by '->' is not indirect object;
- # fixes b1175, b1176
- my ( $next_nonblank_type, $i_next ) =
- find_next_noncomment_type( $i, $rtokens, $max_token_index );
- $type = 'Z' if ( $next_nonblank_type ne '->' );
- }
- },
- '(' => sub {
+ # An identifier followed by '->' is not indirect object;
+ # fixes b1175, b1176
+ my ( $next_nonblank_type, $i_next ) =
+ find_next_noncomment_type( $i, $rtokens, $max_token_index );
+ $type = 'Z' if ( $next_nonblank_type ne '->' );
+ }
+ return;
+ } ## end sub do_DOLLAR_SIGN
- ++$paren_depth;
- $paren_semicolon_count[$paren_depth] = 0;
- if ($want_paren) {
- $container_type = $want_paren;
- $want_paren = "";
- }
- elsif ( $statement_type =~ /^sub\b/ ) {
- $container_type = $statement_type;
- }
- else {
- $container_type = $last_nonblank_token;
+ sub do_LEFT_PARENTHESIS {
- # We can check for a syntax error here of unexpected '(',
- # but this is going to get messy...
- if (
- $expecting == OPERATOR
+ # '('
+ ++$paren_depth;
+ $paren_semicolon_count[$paren_depth] = 0;
+ if ($want_paren) {
+ $container_type = $want_paren;
+ $want_paren = EMPTY_STRING;
+ }
+ elsif ( $statement_type =~ /^sub\b/ ) {
+ $container_type = $statement_type;
+ }
+ else {
+ $container_type = $last_nonblank_token;
- # Be sure this is not a method call of the form
- # &method(...), $method->(..), &{method}(...),
- # $ref[2](list) is ok & short for $ref[2]->(list)
- # NOTE: at present, braces in something like &{ xxx }
- # are not marked as a block, we might have a method call.
- # Added ')' to fix case c017, something like ()()()
- && $last_nonblank_token !~ /^([\]\}\)\&]|\-\>)/
+ # We can check for a syntax error here of unexpected '(',
+ # but this is going to get messy...
+ if (
+ $expecting == OPERATOR
- )
- {
+ # Be sure this is not a method call of the form
+ # &method(...), $method->(..), &{method}(...),
+ # $ref[2](list) is ok & short for $ref[2]->(list)
+ # NOTE: at present, braces in something like &{ xxx }
+ # are not marked as a block, we might have a method call.
+ # Added ')' to fix case c017, something like ()()()
+ && $last_nonblank_token !~ /^([\]\}\)\&]|\-\>)/
+
+ )
+ {
- # ref: camel 3 p 703.
- if ( $last_last_nonblank_token eq 'do' ) {
- complain(
+ # ref: camel 3 p 703.
+ if ( $last_last_nonblank_token eq 'do' ) {
+ complain(
"do SUBROUTINE is deprecated; consider & or -> notation\n"
- );
- }
- else {
+ );
+ }
+ else {
- # if this is an empty list, (), then it is not an
- # error; for example, we might have a constant pi and
- # invoke it with pi() or just pi;
- my ( $next_nonblank_token, $i_next ) =
- find_next_nonblank_token( $i, $rtokens,
- $max_token_index );
+ # if this is an empty list, (), then it is not an
+ # error; for example, we might have a constant pi and
+ # invoke it with pi() or just pi;
+ my ( $next_nonblank_token, $i_next ) =
+ find_next_nonblank_token( $i, $rtokens,
+ $max_token_index );
- # Patch for c029: give up error check if
- # a side comment follows
- if ( $next_nonblank_token ne ')'
- && $next_nonblank_token ne '#' )
- {
- my $hint;
+ # Patch for c029: give up error check if
+ # a side comment follows
+ if ( $next_nonblank_token ne ')'
+ && $next_nonblank_token ne '#' )
+ {
+ my $hint;
- error_if_expecting_OPERATOR('(');
+ error_if_expecting_OPERATOR('(');
- if ( $last_nonblank_type eq 'C' ) {
+ if ( $last_nonblank_type eq 'C' ) {
+ $hint =
+ "$last_nonblank_token has a void prototype\n";
+ }
+ elsif ( $last_nonblank_type eq 'i' ) {
+ if ( $i_tok > 0
+ && $last_nonblank_token =~ /^\$/ )
+ {
$hint =
- "$last_nonblank_token has a void prototype\n";
- }
- elsif ( $last_nonblank_type eq 'i' ) {
- if ( $i_tok > 0
- && $last_nonblank_token =~ /^\$/ )
- {
- $hint =
-"Do you mean '$last_nonblank_token->(' ?\n";
- }
+ "Do you mean '$last_nonblank_token->(' ?\n";
}
- if ($hint) {
- interrupt_logfile();
- warning($hint);
- resume_logfile();
- }
- } ## end if ( $next_nonblank_token...
- } ## end else [ if ( $last_last_nonblank_token...
- } ## end if ( $expecting == OPERATOR...
- }
- $paren_type[$paren_depth] = $container_type;
- ( $type_sequence, $indent_flag ) =
- increase_nesting_depth( PAREN, $rtoken_map->[$i_tok] );
+ }
+ if ($hint) {
+ interrupt_logfile();
+ warning($hint);
+ resume_logfile();
+ }
+ } ## end if ( $next_nonblank_token...
+ } ## end else [ if ( $last_last_nonblank_token...
+ } ## end if ( $expecting == OPERATOR...
+ }
+ $paren_type[$paren_depth] = $container_type;
+ ( $type_sequence, $indent_flag ) =
+ increase_nesting_depth( PAREN, $rtoken_map->[$i_tok] );
- # propagate types down through nested parens
- # for example: the second paren in 'if ((' would be structural
- # since the first is.
+ # propagate types down through nested parens
+ # for example: the second paren in 'if ((' would be structural
+ # since the first is.
- if ( $last_nonblank_token eq '(' ) {
- $type = $last_nonblank_type;
- }
+ if ( $last_nonblank_token eq '(' ) {
+ $type = $last_nonblank_type;
+ }
- # We exclude parens as structural after a ',' because it
- # causes subtle problems with continuation indentation for
- # something like this, where the first 'or' will not get
- # indented.
- #
- # assert(
- # __LINE__,
- # ( not defined $check )
- # or ref $check
- # or $check eq "new"
- # or $check eq "old",
- # );
- #
- # Likewise, we exclude parens where a statement can start
- # because of problems with continuation indentation, like
- # these:
- #
- # ($firstline =~ /^#\!.*perl/)
- # and (print $File::Find::name, "\n")
- # and (return 1);
- #
- # (ref($usage_fref) =~ /CODE/)
- # ? &$usage_fref
- # : (&blast_usage, &blast_params, &blast_general_params);
+ # We exclude parens as structural after a ',' because it
+ # causes subtle problems with continuation indentation for
+ # something like this, where the first 'or' will not get
+ # indented.
+ #
+ # assert(
+ # __LINE__,
+ # ( not defined $check )
+ # or ref $check
+ # or $check eq "new"
+ # or $check eq "old",
+ # );
+ #
+ # Likewise, we exclude parens where a statement can start
+ # because of problems with continuation indentation, like
+ # these:
+ #
+ # ($firstline =~ /^#\!.*perl/)
+ # and (print $File::Find::name, "\n")
+ # and (return 1);
+ #
+ # (ref($usage_fref) =~ /CODE/)
+ # ? &$usage_fref
+ # : (&blast_usage, &blast_params, &blast_general_params);
- else {
- $type = '{';
- }
+ else {
+ $type = '{';
+ }
- if ( $last_nonblank_type eq ')' ) {
- warning(
- "Syntax error? found token '$last_nonblank_type' then '('\n"
- );
- }
- $paren_structural_type[$paren_depth] = $type;
+ if ( $last_nonblank_type eq ')' ) {
+ warning(
+ "Syntax error? found token '$last_nonblank_type' then '('\n");
+ }
+ $paren_structural_type[$paren_depth] = $type;
+ return;
- },
- ')' => sub {
- ( $type_sequence, $indent_flag ) =
- decrease_nesting_depth( PAREN, $rtoken_map->[$i_tok] );
+ } ## end sub do_LEFT_PARENTHESIS
- if ( $paren_structural_type[$paren_depth] eq '{' ) {
- $type = '}';
- }
+ sub do_RIGHT_PARENTHESIS {
- $container_type = $paren_type[$paren_depth];
+ # ')'
+ ( $type_sequence, $indent_flag ) =
+ decrease_nesting_depth( PAREN, $rtoken_map->[$i_tok] );
- # restore statement type as 'sub' at closing paren of a signature
- # so that a subsequent ':' is identified as an attribute
- if ( $container_type =~ /^sub\b/ ) {
- $statement_type = $container_type;
- }
+ if ( $paren_structural_type[$paren_depth] eq '{' ) {
+ $type = '}';
+ }
- # /^(for|foreach)$/
- if ( $is_for_foreach{ $paren_type[$paren_depth] } ) {
- my $num_sc = $paren_semicolon_count[$paren_depth];
- if ( $num_sc > 0 && $num_sc != 2 ) {
- warning("Expected 2 ';' in 'for(;;)' but saw $num_sc\n");
- }
- }
+ $container_type = $paren_type[$paren_depth];
- if ( $paren_depth > 0 ) { $paren_depth-- }
- },
- ',' => sub {
- if ( $last_nonblank_type eq ',' ) {
- complain("Repeated ','s \n");
- }
+ # restore statement type as 'sub' at closing paren of a signature
+ # so that a subsequent ':' is identified as an attribute
+ if ( $container_type =~ /^sub\b/ ) {
+ $statement_type = $container_type;
+ }
- # Note that we have to check both token and type here because a
- # comma following a qw list can have last token='(' but type = 'q'
- elsif ( $last_nonblank_token eq '(' && $last_nonblank_type eq '{' )
- {
- warning("Unexpected leading ',' after a '('\n");
+ # /^(for|foreach)$/
+ if ( $is_for_foreach{ $paren_type[$paren_depth] } ) {
+ my $num_sc = $paren_semicolon_count[$paren_depth];
+ if ( $num_sc > 0 && $num_sc != 2 ) {
+ warning("Expected 2 ';' in 'for(;;)' but saw $num_sc\n");
}
+ }
- # patch for operator_expected: note if we are in the list (use.t)
- if ( $statement_type eq 'use' ) { $statement_type = '_use' }
+ if ( $paren_depth > 0 ) { $paren_depth-- }
+ return;
+ } ## end sub do_RIGHT_PARENTHESIS
- },
- ';' => sub {
- $context = UNKNOWN_CONTEXT;
- $statement_type = '';
- $want_paren = "";
+ sub do_COMMA {
- # /^(for|foreach)$/
- if ( $is_for_foreach{ $paren_type[$paren_depth] } )
- { # mark ; in for loop
+ # ','
+ if ( $last_nonblank_type eq ',' ) {
+ complain("Repeated ','s \n");
+ }
- # Be careful: we do not want a semicolon such as the
- # following to be included:
- #
- # for (sort {strcoll($a,$b);} keys %investments) {
+ # Note that we have to check both token and type here because a
+ # comma following a qw list can have last token='(' but type = 'q'
+ elsif ( $last_nonblank_token eq '(' && $last_nonblank_type eq '{' ) {
+ warning("Unexpected leading ',' after a '('\n");
+ }
- if ( $brace_depth == $depth_array[PAREN][BRACE][$paren_depth]
- && $square_bracket_depth ==
- $depth_array[PAREN][SQUARE_BRACKET][$paren_depth] )
- {
+ # patch for operator_expected: note if we are in the list (use.t)
+ if ( $statement_type eq 'use' ) { $statement_type = '_use' }
+ return;
- $type = 'f';
- $paren_semicolon_count[$paren_depth]++;
- }
- }
+ } ## end sub do_COMMA
- },
- '"' => sub {
- error_if_expecting_OPERATOR("String")
- if ( $expecting == OPERATOR );
- $in_quote = 1;
- $type = 'Q';
- $allowed_quote_modifiers = "";
- },
- "'" => sub {
- error_if_expecting_OPERATOR("String")
- if ( $expecting == OPERATOR );
- $in_quote = 1;
- $type = 'Q';
- $allowed_quote_modifiers = "";
- },
- '`' => sub {
- error_if_expecting_OPERATOR("String")
- if ( $expecting == OPERATOR );
- $in_quote = 1;
- $type = 'Q';
- $allowed_quote_modifiers = "";
- },
- '/' => sub {
- my $is_pattern;
+ sub do_SEMICOLON {
- # a pattern cannot follow certain keywords which take optional
- # arguments, like 'shift' and 'pop'. See also '?'.
- if (
- $last_nonblank_type eq 'k'
- && $is_keyword_rejecting_slash_as_pattern_delimiter{
- $last_nonblank_token}
- )
+ # ';'
+ $context = UNKNOWN_CONTEXT;
+ $statement_type = EMPTY_STRING;
+ $want_paren = EMPTY_STRING;
+
+ # /^(for|foreach)$/
+ if ( $is_for_foreach{ $paren_type[$paren_depth] } )
+ { # mark ; in for loop
+
+ # Be careful: we do not want a semicolon such as the
+ # following to be included:
+ #
+ # for (sort {strcoll($a,$b);} keys %investments) {
+
+ if ( $brace_depth == $depth_array[PAREN][BRACE][$paren_depth]
+ && $square_bracket_depth ==
+ $depth_array[PAREN][SQUARE_BRACKET][$paren_depth] )
{
- $is_pattern = 0;
- }
- elsif ( $expecting == UNKNOWN ) { # indeterminate, must guess..
- my $msg;
- ( $is_pattern, $msg ) =
- guess_if_pattern_or_division( $i, $rtokens, $rtoken_map,
- $max_token_index );
- if ($msg) {
- write_diagnostics("DIVIDE:$msg\n");
- write_logfile_entry($msg);
- }
+ $type = 'f';
+ $paren_semicolon_count[$paren_depth]++;
}
- else { $is_pattern = ( $expecting == TERM ) }
+ }
+ return;
+ } ## end sub do_SEMICOLON
- if ($is_pattern) {
- $in_quote = 1;
- $type = 'Q';
- $allowed_quote_modifiers = '[msixpodualngc]';
+ sub do_QUOTATION_MARK {
+
+ # '"'
+ error_if_expecting_OPERATOR("String")
+ if ( $expecting == OPERATOR );
+ $in_quote = 1;
+ $type = 'Q';
+ $allowed_quote_modifiers = EMPTY_STRING;
+ return;
+ } ## end sub do_QUOTATION_MARK
+
+ sub do_APOSTROPHE {
+
+ # "'"
+ error_if_expecting_OPERATOR("String")
+ if ( $expecting == OPERATOR );
+ $in_quote = 1;
+ $type = 'Q';
+ $allowed_quote_modifiers = EMPTY_STRING;
+ return;
+ } ## end sub do_APOSTROPHE
+
+ sub do_BACKTICK {
+
+ # '`'
+ error_if_expecting_OPERATOR("String")
+ if ( $expecting == OPERATOR );
+ $in_quote = 1;
+ $type = 'Q';
+ $allowed_quote_modifiers = EMPTY_STRING;
+ return;
+ } ## end sub do_BACKTICK
+
+ sub do_SLASH {
+
+ # '/'
+ my $is_pattern;
+
+ # a pattern cannot follow certain keywords which take optional
+ # arguments, like 'shift' and 'pop'. See also '?'.
+ if (
+ $last_nonblank_type eq 'k'
+ && $is_keyword_rejecting_slash_as_pattern_delimiter{
+ $last_nonblank_token}
+ )
+ {
+ $is_pattern = 0;
+ }
+ elsif ( $expecting == UNKNOWN ) { # indeterminate, must guess..
+ my $msg;
+ ( $is_pattern, $msg ) =
+ guess_if_pattern_or_division( $i, $rtokens, $rtoken_map,
+ $max_token_index );
+
+ if ($msg) {
+ write_diagnostics("DIVIDE:$msg\n");
+ write_logfile_entry($msg);
}
- else { # not a pattern; check for a /= token
+ }
+ else { $is_pattern = ( $expecting == TERM ) }
- if ( $rtokens->[ $i + 1 ] eq '=' ) { # form token /=
- $i++;
- $tok = '/=';
- $type = $tok;
- }
+ if ($is_pattern) {
+ $in_quote = 1;
+ $type = 'Q';
+ $allowed_quote_modifiers = '[msixpodualngc]';
+ }
+ else { # not a pattern; check for a /= token
+
+ if ( $rtokens->[ $i + 1 ] eq '=' ) { # form token /=
+ $i++;
+ $tok = '/=';
+ $type = $tok;
+ }
#DEBUG - collecting info on what tokens follow a divide
# for development of guessing algorithm
#if ( is_possible_numerator( $i, $rtokens, $max_token_index ) < 0 ) {
# #write_diagnostics( "DIVIDE? $input_line\n" );
#}
- }
- },
- '{' => sub {
-
- # if we just saw a ')', we will label this block with
- # its type. We need to do this to allow sub
- # code_block_type to determine if this brace starts a
- # code block or anonymous hash. (The type of a paren
- # pair is the preceding token, such as 'if', 'else',
- # etc).
- $container_type = "";
-
- # ATTRS: for a '{' following an attribute list, reset
- # things to look like we just saw the sub name
- if ( $statement_type =~ /^sub\b/ ) {
- $last_nonblank_token = $statement_type;
- $last_nonblank_type = 'i';
- $statement_type = "";
- }
-
- # patch for SWITCH/CASE: hide these keywords from an immediately
- # following opening brace
- elsif ( ( $statement_type eq 'case' || $statement_type eq 'when' )
- && $statement_type eq $last_nonblank_token )
- {
- $last_nonblank_token = ";";
- }
+ }
+ return;
+ } ## end sub do_SLASH
+
+ sub do_LEFT_CURLY_BRACKET {
+
+ # '{'
+ # if we just saw a ')', we will label this block with
+ # its type. We need to do this to allow sub
+ # code_block_type to determine if this brace starts a
+ # code block or anonymous hash. (The type of a paren
+ # pair is the preceding token, such as 'if', 'else',
+ # etc).
+ $container_type = EMPTY_STRING;
+
+ # ATTRS: for a '{' following an attribute list, reset
+ # things to look like we just saw the sub name
+ if ( $statement_type =~ /^sub\b/ ) {
+ $last_nonblank_token = $statement_type;
+ $last_nonblank_type = 'i';
+ $statement_type = EMPTY_STRING;
+ }
+
+ # patch for SWITCH/CASE: hide these keywords from an immediately
+ # following opening brace
+ elsif ( ( $statement_type eq 'case' || $statement_type eq 'when' )
+ && $statement_type eq $last_nonblank_token )
+ {
+ $last_nonblank_token = ";";
+ }
- elsif ( $last_nonblank_token eq ')' ) {
- $last_nonblank_token = $paren_type[ $paren_depth + 1 ];
+ elsif ( $last_nonblank_token eq ')' ) {
+ $last_nonblank_token = $paren_type[ $paren_depth + 1 ];
- # defensive move in case of a nesting error (pbug.t)
- # in which this ')' had no previous '('
- # this nesting error will have been caught
- if ( !defined($last_nonblank_token) ) {
- $last_nonblank_token = 'if';
- }
+ # defensive move in case of a nesting error (pbug.t)
+ # in which this ')' had no previous '('
+ # this nesting error will have been caught
+ if ( !defined($last_nonblank_token) ) {
+ $last_nonblank_token = 'if';
+ }
- # check for syntax error here;
- unless ( $is_blocktype_with_paren{$last_nonblank_token} ) {
- if ( $tokenizer_self->[_extended_syntax_] ) {
+ # check for syntax error here;
+ unless ( $is_blocktype_with_paren{$last_nonblank_token} ) {
+ if ( $tokenizer_self->[_extended_syntax_] ) {
- # we append a trailing () to mark this as an unknown
- # block type. This allows perltidy to format some
- # common extensions of perl syntax.
- # This is used by sub code_block_type
- $last_nonblank_token .= '()';
- }
- else {
- my $list =
- join( ' ', sort keys %is_blocktype_with_paren );
- warning(
+ # we append a trailing () to mark this as an unknown
+ # block type. This allows perltidy to format some
+ # common extensions of perl syntax.
+ # This is used by sub code_block_type
+ $last_nonblank_token .= '()';
+ }
+ else {
+ my $list =
+ join( SPACE, sort keys %is_blocktype_with_paren );
+ warning(
"syntax error at ') {', didn't see one of: <<$list>>; If this code is okay try using the -xs flag\n"
- );
- }
+ );
}
}
+ }
- # patch for paren-less for/foreach glitch, part 2.
- # see note below under 'qw'
- elsif ($last_nonblank_token eq 'qw'
- && $is_for_foreach{$want_paren} )
- {
- $last_nonblank_token = $want_paren;
- if ( $last_last_nonblank_token eq $want_paren ) {
- warning(
+ # patch for paren-less for/foreach glitch, part 2.
+ # see note below under 'qw'
+ elsif ($last_nonblank_token eq 'qw'
+ && $is_for_foreach{$want_paren} )
+ {
+ $last_nonblank_token = $want_paren;
+ if ( $last_last_nonblank_token eq $want_paren ) {
+ warning(
"syntax error at '$want_paren .. {' -- missing \$ loop variable\n"
- );
+ );
- }
- $want_paren = "";
}
+ $want_paren = EMPTY_STRING;
+ }
- # now identify which of the three possible types of
- # curly braces we have: hash index container, anonymous
- # hash reference, or code block.
+ # now identify which of the three possible types of
+ # curly braces we have: hash index container, anonymous
+ # hash reference, or code block.
- # non-structural (hash index) curly brace pair
- # get marked 'L' and 'R'
- if ( is_non_structural_brace() ) {
- $type = 'L';
+ # non-structural (hash index) curly brace pair
+ # get marked 'L' and 'R'
+ if ( is_non_structural_brace() ) {
+ $type = 'L';
- # patch for SWITCH/CASE:
- # allow paren-less identifier after 'when'
- # if the brace is preceded by a space
- if ( $statement_type eq 'when'
- && $last_nonblank_type eq 'i'
- && $last_last_nonblank_type eq 'k'
- && ( $i_tok == 0 || $rtoken_type->[ $i_tok - 1 ] eq 'b' ) )
- {
- $type = '{';
- $block_type = $statement_type;
- }
+ # patch for SWITCH/CASE:
+ # allow paren-less identifier after 'when'
+ # if the brace is preceded by a space
+ if ( $statement_type eq 'when'
+ && $last_nonblank_type eq 'i'
+ && $last_last_nonblank_type eq 'k'
+ && ( $i_tok == 0 || $rtoken_type->[ $i_tok - 1 ] eq 'b' ) )
+ {
+ $type = '{';
+ $block_type = $statement_type;
}
+ }
- # code and anonymous hash have the same type, '{', but are
- # distinguished by 'block_type',
- # which will be blank for an anonymous hash
- else {
+ # code and anonymous hash have the same type, '{', but are
+ # distinguished by 'block_type',
+ # which will be blank for an anonymous hash
+ else {
- $block_type = code_block_type( $i_tok, $rtokens, $rtoken_type,
- $max_token_index );
+ $block_type = code_block_type( $i_tok, $rtokens, $rtoken_type,
+ $max_token_index );
- # patch to promote bareword type to function taking block
- if ( $block_type
- && $last_nonblank_type eq 'w'
- && $last_nonblank_i >= 0 )
- {
- if ( $routput_token_type->[$last_nonblank_i] eq 'w' ) {
- $routput_token_type->[$last_nonblank_i] =
- $is_grep_alias{$block_type} ? 'k' : 'G';
- }
+ # patch to promote bareword type to function taking block
+ if ( $block_type
+ && $last_nonblank_type eq 'w'
+ && $last_nonblank_i >= 0 )
+ {
+ if ( $routput_token_type->[$last_nonblank_i] eq 'w' ) {
+ $routput_token_type->[$last_nonblank_i] =
+ $is_grep_alias{$block_type} ? 'k' : 'G';
}
+ }
- # patch for SWITCH/CASE: if we find a stray opening block brace
- # where we might accept a 'case' or 'when' block, then take it
- if ( $statement_type eq 'case'
- || $statement_type eq 'when' )
- {
- if ( !$block_type || $block_type eq '}' ) {
- $block_type = $statement_type;
- }
+ # patch for SWITCH/CASE: if we find a stray opening block brace
+ # where we might accept a 'case' or 'when' block, then take it
+ if ( $statement_type eq 'case'
+ || $statement_type eq 'when' )
+ {
+ if ( !$block_type || $block_type eq '}' ) {
+ $block_type = $statement_type;
}
}
+ }
- $brace_type[ ++$brace_depth ] = $block_type;
- $brace_package[$brace_depth] = $current_package;
- $brace_structural_type[$brace_depth] = $type;
- $brace_context[$brace_depth] = $context;
- ( $type_sequence, $indent_flag ) =
- increase_nesting_depth( BRACE, $rtoken_map->[$i_tok] );
- },
- '}' => sub {
- $block_type = $brace_type[$brace_depth];
- if ($block_type) { $statement_type = '' }
- if ( defined( $brace_package[$brace_depth] ) ) {
- $current_package = $brace_package[$brace_depth];
- }
+ $brace_type[ ++$brace_depth ] = $block_type;
+ $brace_package[$brace_depth] = $current_package;
+ $brace_structural_type[$brace_depth] = $type;
+ $brace_context[$brace_depth] = $context;
+ ( $type_sequence, $indent_flag ) =
+ increase_nesting_depth( BRACE, $rtoken_map->[$i_tok] );
+ return;
+ } ## end sub do_LEFT_CURLY_BRACKET
- # can happen on brace error (caught elsewhere)
- else {
- }
- ( $type_sequence, $indent_flag ) =
- decrease_nesting_depth( BRACE, $rtoken_map->[$i_tok] );
+ sub do_RIGHT_CURLY_BRACKET {
- if ( $brace_structural_type[$brace_depth] eq 'L' ) {
- $type = 'R';
- }
+ # '}'
+ $block_type = $brace_type[$brace_depth];
+ if ($block_type) { $statement_type = EMPTY_STRING }
+ if ( defined( $brace_package[$brace_depth] ) ) {
+ $current_package = $brace_package[$brace_depth];
+ }
- # propagate type information for 'do' and 'eval' blocks, and also
- # for smartmatch operator. This is necessary to enable us to know
- # if an operator or term is expected next.
- if ( $is_block_operator{$block_type} ) {
- $tok = $block_type;
- }
+ # can happen on brace error (caught elsewhere)
+ else {
+ }
+ ( $type_sequence, $indent_flag ) =
+ decrease_nesting_depth( BRACE, $rtoken_map->[$i_tok] );
- $context = $brace_context[$brace_depth];
- if ( $brace_depth > 0 ) { $brace_depth--; }
- },
- '&' => sub { # maybe sub call? start looking
+ if ( $brace_structural_type[$brace_depth] eq 'L' ) {
+ $type = 'R';
+ }
- # We have to check for sub call unless we are sure we
- # are expecting an operator. This example from s2p
- # got mistaken as a q operator in an early version:
- # print BODY &q(<<'EOT');
- if ( $expecting != OPERATOR ) {
+ # propagate type information for 'do' and 'eval' blocks, and also
+ # for smartmatch operator. This is necessary to enable us to know
+ # if an operator or term is expected next.
+ if ( $is_block_operator{$block_type} ) {
+ $tok = $block_type;
+ }
- # But only look for a sub call if we are expecting a term or
- # if there is no existing space after the &.
- # For example we probably don't want & as sub call here:
- # Fcntl::S_IRUSR & $mode;
- if ( $expecting == TERM || $next_type ne 'b' ) {
- scan_identifier_fast();
- }
- }
- else {
- }
- },
- '<' => sub { # angle operator or less than?
+ $context = $brace_context[$brace_depth];
+ if ( $brace_depth > 0 ) { $brace_depth--; }
+ return;
+ } ## end sub do_RIGHT_CURLY_BRACKET
- if ( $expecting != OPERATOR ) {
- ( $i, $type ) =
- find_angle_operator_termination( $input_line, $i, $rtoken_map,
- $expecting, $max_token_index );
+ sub do_AMPERSAND {
- ## This message is not very helpful and quite confusing if the above
- ## routine decided not to write a message with the line number.
- ## if ( $type eq '<' && $expecting == TERM ) {
- ## error_if_expecting_TERM();
- ## interrupt_logfile();
- ## warning("Unterminated <> operator?\n");
- ## resume_logfile();
- ## }
+ # '&' = maybe sub call? start looking
+ # We have to check for sub call unless we are sure we
+ # are expecting an operator. This example from s2p
+ # got mistaken as a q operator in an early version:
+ # print BODY &q(<<'EOT');
+ if ( $expecting != OPERATOR ) {
+ # But only look for a sub call if we are expecting a term or
+ # if there is no existing space after the &.
+ # For example we probably don't want & as sub call here:
+ # Fcntl::S_IRUSR & $mode;
+ if ( $expecting == TERM || $next_type ne 'b' ) {
+ scan_simple_identifier();
}
- else {
- }
- },
- '?' => sub { # ?: conditional or starting pattern?
+ }
+ else {
+ }
+ return;
+ } ## end sub do_AMPERSAND
- my $is_pattern;
+ sub do_LESS_THAN_SIGN {
- # Patch for rt #126965
- # a pattern cannot follow certain keywords which take optional
- # arguments, like 'shift' and 'pop'. See also '/'.
- if (
- $last_nonblank_type eq 'k'
- && $is_keyword_rejecting_question_as_pattern_delimiter{
- $last_nonblank_token}
- )
- {
- $is_pattern = 0;
- }
+ # '<' - angle operator or less than?
+ if ( $expecting != OPERATOR ) {
+ ( $i, $type ) =
+ find_angle_operator_termination( $input_line, $i, $rtoken_map,
+ $expecting, $max_token_index );
- # patch for RT#131288, user constant function without prototype
- # last type is 'U' followed by ?.
- elsif ( $last_nonblank_type =~ /^[FUY]$/ ) {
- $is_pattern = 0;
- }
- elsif ( $expecting == UNKNOWN ) {
-
- # In older versions of Perl, a bare ? can be a pattern
- # delimiter. In perl version 5.22 this was
- # dropped, but we have to support it in order to format
- # older programs. See:
- ## https://perl.developpez.com/documentations/en/5.22.0/perl5211delta.html
- # For example, the following line worked
- # at one time:
- # ?(.*)? && (print $1,"\n");
- # In current versions it would have to be written with slashes:
- # /(.*)/ && (print $1,"\n");
- my $msg;
- ( $is_pattern, $msg ) =
- guess_if_pattern_or_conditional( $i, $rtokens, $rtoken_map,
- $max_token_index );
+ ## This message is not very helpful and quite confusing if the above
+ ## routine decided not to write a message with the line number.
+ ## if ( $type eq '<' && $expecting == TERM ) {
+ ## error_if_expecting_TERM();
+ ## interrupt_logfile();
+ ## warning("Unterminated <> operator?\n");
+ ## resume_logfile();
+ ## }
- if ($msg) { write_logfile_entry($msg) }
- }
- else { $is_pattern = ( $expecting == TERM ) }
+ }
+ else {
+ }
+ return;
+ } ## end sub do_LESS_THAN_SIGN
- if ($is_pattern) {
- $in_quote = 1;
- $type = 'Q';
- $allowed_quote_modifiers = '[msixpodualngc]';
- }
- else {
- ( $type_sequence, $indent_flag ) =
- increase_nesting_depth( QUESTION_COLON,
- $rtoken_map->[$i_tok] );
- }
- },
- '*' => sub { # typeglob, or multiply?
+ sub do_QUESTION_MARK {
- if ( $expecting == UNKNOWN && $last_nonblank_type eq 'Z' ) {
- if ( $next_type ne 'b'
- && $next_type ne '('
- && $next_type ne '#' ) # Fix c036
- {
- $expecting = TERM;
- }
- }
- if ( $expecting == TERM ) {
- scan_identifier_fast();
+ # '?' = conditional or starting pattern?
+ my $is_pattern;
+
+ # Patch for rt #126965
+ # a pattern cannot follow certain keywords which take optional
+ # arguments, like 'shift' and 'pop'. See also '/'.
+ if (
+ $last_nonblank_type eq 'k'
+ && $is_keyword_rejecting_question_as_pattern_delimiter{
+ $last_nonblank_token}
+ )
+ {
+ $is_pattern = 0;
+ }
+
+ # patch for RT#131288, user constant function without prototype
+ # last type is 'U' followed by ?.
+ elsif ( $last_nonblank_type =~ /^[FUY]$/ ) {
+ $is_pattern = 0;
+ }
+ elsif ( $expecting == UNKNOWN ) {
+
+ # In older versions of Perl, a bare ? can be a pattern
+ # delimiter. In perl version 5.22 this was
+ # dropped, but we have to support it in order to format
+ # older programs. See:
+ ## https://perl.developpez.com/documentations/en/5.22.0/perl5211delta.html
+ # For example, the following line worked
+ # at one time:
+ # ?(.*)? && (print $1,"\n");
+ # In current versions it would have to be written with slashes:
+ # /(.*)/ && (print $1,"\n");
+ my $msg;
+ ( $is_pattern, $msg ) =
+ guess_if_pattern_or_conditional( $i, $rtokens, $rtoken_map,
+ $max_token_index );
+
+ if ($msg) { write_logfile_entry($msg) }
+ }
+ else { $is_pattern = ( $expecting == TERM ) }
+
+ if ($is_pattern) {
+ $in_quote = 1;
+ $type = 'Q';
+ $allowed_quote_modifiers = '[msixpodualngc]';
+ }
+ else {
+ ( $type_sequence, $indent_flag ) =
+ increase_nesting_depth( QUESTION_COLON, $rtoken_map->[$i_tok] );
+ }
+ return;
+ } ## end sub do_QUESTION_MARK
+
+ sub do_STAR {
+
+ # '*' = typeglob, or multiply?
+ if ( $expecting == UNKNOWN && $last_nonblank_type eq 'Z' ) {
+ if ( $next_type ne 'b'
+ && $next_type ne '('
+ && $next_type ne '#' ) # Fix c036
+ {
+ $expecting = TERM;
}
- else {
+ }
+ if ( $expecting == TERM ) {
+ scan_simple_identifier();
+ }
+ else {
+ if ( $rtokens->[ $i + 1 ] eq '=' ) {
+ $tok = '*=';
+ $type = $tok;
+ $i++;
+ }
+ elsif ( $rtokens->[ $i + 1 ] eq '*' ) {
+ $tok = '**';
+ $type = $tok;
+ $i++;
if ( $rtokens->[ $i + 1 ] eq '=' ) {
- $tok = '*=';
- $type = $tok;
- $i++;
- }
- elsif ( $rtokens->[ $i + 1 ] eq '*' ) {
- $tok = '**';
+ $tok = '**=';
$type = $tok;
$i++;
- if ( $rtokens->[ $i + 1 ] eq '=' ) {
- $tok = '**=';
- $type = $tok;
- $i++;
- }
}
}
- },
- '.' => sub { # what kind of . ?
+ }
+ return;
+ } ## end sub do_STAR
- if ( $expecting != OPERATOR ) {
- scan_number();
- if ( $type eq '.' ) {
- error_if_expecting_TERM()
- if ( $expecting == TERM );
- }
- }
- else {
- }
- },
- ':' => sub {
+ sub do_DOT {
- # if this is the first nonblank character, call it a label
- # since perl seems to just swallow it
- if ( $input_line_number == 1 && $last_nonblank_i == -1 ) {
- $type = 'J';
+ # '.' = what kind of . ?
+ if ( $expecting != OPERATOR ) {
+ scan_number();
+ if ( $type eq '.' ) {
+ error_if_expecting_TERM()
+ if ( $expecting == TERM );
}
+ }
+ else {
+ }
+ return;
+ } ## end sub do_DOT
- # ATTRS: check for a ':' which introduces an attribute list
- # either after a 'sub' keyword or within a paren list
- elsif ( $statement_type =~ /^sub\b/ ) {
- $type = 'A';
- $in_attribute_list = 1;
- }
+ sub do_COLON {
- # Within a signature, unless we are in a ternary. For example,
- # from 't/filter_example.t':
- # method foo4 ( $class: $bar ) { $class->bar($bar) }
- elsif ( $paren_type[$paren_depth] =~ /^sub\b/
- && !is_balanced_closing_container(QUESTION_COLON) )
- {
- $type = 'A';
- $in_attribute_list = 1;
- }
+ # ':' = label, ternary, attribute, ?
- # check for scalar attribute, such as
- # my $foo : shared = 1;
- elsif ($is_my_our_state{$statement_type}
- && $current_depth[QUESTION_COLON] == 0 )
- {
- $type = 'A';
- $in_attribute_list = 1;
- }
+ # if this is the first nonblank character, call it a label
+ # since perl seems to just swallow it
+ if ( $input_line_number == 1 && $last_nonblank_i == -1 ) {
+ $type = 'J';
+ }
- # Look for Switch::Plain syntax if an error would otherwise occur
- # here. Note that we do not need to check if the extended syntax
- # flag is set because otherwise an error would occur, and we would
- # then have to output a message telling the user to set the
- # extended syntax flag to avoid the error.
- # case 1: {
- # default: {
- # default:
- # Note that the line 'default:' will be parsed as a label elsewhere.
- elsif ( $is_case_default{$statement_type}
- && !is_balanced_closing_container(QUESTION_COLON) )
- {
- # mark it as a perltidy label type
- $type = 'J';
- }
+ # ATTRS: check for a ':' which introduces an attribute list
+ # either after a 'sub' keyword or within a paren list
+ elsif ( $statement_type =~ /^sub\b/ ) {
+ $type = 'A';
+ $in_attribute_list = 1;
+ }
- # otherwise, it should be part of a ?/: operator
- else {
- ( $type_sequence, $indent_flag ) =
- decrease_nesting_depth( QUESTION_COLON,
- $rtoken_map->[$i_tok] );
- if ( $last_nonblank_token eq '?' ) {
- warning("Syntax error near ? :\n");
- }
+ # Within a signature, unless we are in a ternary. For example,
+ # from 't/filter_example.t':
+ # method foo4 ( $class: $bar ) { $class->bar($bar) }
+ elsif ( $paren_type[$paren_depth] =~ /^sub\b/
+ && !is_balanced_closing_container(QUESTION_COLON) )
+ {
+ $type = 'A';
+ $in_attribute_list = 1;
+ }
+
+ # check for scalar attribute, such as
+ # my $foo : shared = 1;
+ elsif ($is_my_our_state{$statement_type}
+ && $current_depth[QUESTION_COLON] == 0 )
+ {
+ $type = 'A';
+ $in_attribute_list = 1;
+ }
+
+ # Look for Switch::Plain syntax if an error would otherwise occur
+ # here. Note that we do not need to check if the extended syntax
+ # flag is set because otherwise an error would occur, and we would
+ # then have to output a message telling the user to set the
+ # extended syntax flag to avoid the error.
+ # case 1: {
+ # default: {
+ # default:
+ # Note that the line 'default:' will be parsed as a label elsewhere.
+ elsif ( $is_case_default{$statement_type}
+ && !is_balanced_closing_container(QUESTION_COLON) )
+ {
+ # mark it as a perltidy label type
+ $type = 'J';
+ }
+
+ # otherwise, it should be part of a ?/: operator
+ else {
+ ( $type_sequence, $indent_flag ) =
+ decrease_nesting_depth( QUESTION_COLON, $rtoken_map->[$i_tok] );
+ if ( $last_nonblank_token eq '?' ) {
+ warning("Syntax error near ? :\n");
}
- },
- '+' => sub { # what kind of plus?
+ }
+ return;
+ } ## end sub do_COLON
- if ( $expecting == TERM ) {
- my $number = scan_number_fast();
+ sub do_PLUS_SIGN {
+
+ # '+' = what kind of plus?
+ if ( $expecting == TERM ) {
+ my $number = scan_number_fast();
+
+ # unary plus is safest assumption if not a number
+ if ( !defined($number) ) { $type = 'p'; }
+ }
+ elsif ( $expecting == OPERATOR ) {
+ }
+ else {
+ if ( $next_type eq 'w' ) { $type = 'p' }
+ }
+ return;
+ } ## end sub do_PLUS_SIGN
+
+ sub do_AT_SIGN {
- # unary plus is safest assumption if not a number
- if ( !defined($number) ) { $type = 'p'; }
+ # '@' = sigil for array?
+ error_if_expecting_OPERATOR("Array")
+ if ( $expecting == OPERATOR );
+ scan_simple_identifier();
+ return;
+ }
+
+ sub do_PERCENT_SIGN {
+
+ # '%' = hash or modulo?
+ # first guess is hash if no following blank or paren
+ if ( $expecting == UNKNOWN ) {
+ if ( $next_type ne 'b' && $next_type ne '(' ) {
+ $expecting = TERM;
}
- elsif ( $expecting == OPERATOR ) {
+ }
+ if ( $expecting == TERM ) {
+ scan_simple_identifier();
+ }
+ return;
+ } ## end sub do_PERCENT_SIGN
+
+ sub do_LEFT_SQUARE_BRACKET {
+
+ # '['
+ $square_bracket_type[ ++$square_bracket_depth ] = $last_nonblank_token;
+ ( $type_sequence, $indent_flag ) =
+ increase_nesting_depth( SQUARE_BRACKET, $rtoken_map->[$i_tok] );
+
+ # It may seem odd, but structural square brackets have
+ # type '{' and '}'. This simplifies the indentation logic.
+ if ( !is_non_structural_brace() ) {
+ $type = '{';
+ }
+ $square_bracket_structural_type[$square_bracket_depth] = $type;
+ return;
+ } ## end sub do_LEFT_SQUARE_BRACKET
+
+ sub do_RIGHT_SQUARE_BRACKET {
+
+ # ']'
+ ( $type_sequence, $indent_flag ) =
+ decrease_nesting_depth( SQUARE_BRACKET, $rtoken_map->[$i_tok] );
+
+ if ( $square_bracket_structural_type[$square_bracket_depth] eq '{' ) {
+ $type = '}';
+ }
+
+ # propagate type information for smartmatch operator. This is
+ # necessary to enable us to know if an operator or term is expected
+ # next.
+ if ( $square_bracket_type[$square_bracket_depth] eq '~~' ) {
+ $tok = $square_bracket_type[$square_bracket_depth];
+ }
+
+ if ( $square_bracket_depth > 0 ) { $square_bracket_depth--; }
+ return;
+ } ## end sub do_RIGHT_SQUARE_BRACKET
+
+ sub do_MINUS_SIGN {
+
+ # '-' = what kind of minus?
+ if ( ( $expecting != OPERATOR )
+ && $is_file_test_operator{$next_tok} )
+ {
+ my ( $next_nonblank_token, $i_next ) =
+ find_next_nonblank_token( $i + 1, $rtokens, $max_token_index );
+
+ # check for a quoted word like "-w=>xx";
+ # it is sufficient to just check for a following '='
+ if ( $next_nonblank_token eq '=' ) {
+ $type = 'm';
}
else {
- if ( $next_type eq 'w' ) { $type = 'p' }
+ $i++;
+ $tok .= $next_tok;
+ $type = 'F';
}
- },
- '@' => sub {
+ }
+ elsif ( $expecting == TERM ) {
+ my $number = scan_number_fast();
- error_if_expecting_OPERATOR("Array")
- if ( $expecting == OPERATOR );
- scan_identifier_fast();
- },
- '%' => sub { # hash or modulo?
-
- # first guess is hash if no following blank or paren
- if ( $expecting == UNKNOWN ) {
- if ( $next_type ne 'b' && $next_type ne '(' ) {
- $expecting = TERM;
- }
- }
- if ( $expecting == TERM ) {
- scan_identifier_fast();
- }
- },
- '[' => sub {
- $square_bracket_type[ ++$square_bracket_depth ] =
- $last_nonblank_token;
- ( $type_sequence, $indent_flag ) =
- increase_nesting_depth( SQUARE_BRACKET, $rtoken_map->[$i_tok] );
+ # maybe part of bareword token? unary is safest
+ if ( !defined($number) ) { $type = 'm'; }
- # It may seem odd, but structural square brackets have
- # type '{' and '}'. This simplifies the indentation logic.
- if ( !is_non_structural_brace() ) {
- $type = '{';
- }
- $square_bracket_structural_type[$square_bracket_depth] = $type;
- },
- ']' => sub {
- ( $type_sequence, $indent_flag ) =
- decrease_nesting_depth( SQUARE_BRACKET, $rtoken_map->[$i_tok] );
+ }
+ elsif ( $expecting == OPERATOR ) {
+ }
+ else {
- if ( $square_bracket_structural_type[$square_bracket_depth] eq '{' )
- {
- $type = '}';
+ if ( $next_type eq 'w' ) {
+ $type = 'm';
}
+ }
+ return;
+ } ## end sub do_MINUS_SIGN
- # propagate type information for smartmatch operator. This is
- # necessary to enable us to know if an operator or term is expected
- # next.
- if ( $square_bracket_type[$square_bracket_depth] eq '~~' ) {
- $tok = $square_bracket_type[$square_bracket_depth];
- }
+ sub do_CARAT_SIGN {
- if ( $square_bracket_depth > 0 ) { $square_bracket_depth--; }
- },
- '-' => sub { # what kind of minus?
+ # '^'
+ # check for special variables like ${^WARNING_BITS}
+ if ( $expecting == TERM ) {
- if ( ( $expecting != OPERATOR )
- && $is_file_test_operator{$next_tok} )
+ if ( $last_nonblank_token eq '{'
+ && ( $next_tok !~ /^\d/ )
+ && ( $next_tok =~ /^\w/ ) )
{
- my ( $next_nonblank_token, $i_next ) =
- find_next_nonblank_token( $i + 1, $rtokens,
- $max_token_index );
- # check for a quoted word like "-w=>xx";
- # it is sufficient to just check for a following '='
- if ( $next_nonblank_token eq '=' ) {
- $type = 'm';
+ if ( $next_tok eq 'W' ) {
+ $tokenizer_self->[_saw_perl_dash_w_] = 1;
}
- else {
- $i++;
- $tok .= $next_tok;
- $type = 'F';
+ $tok = $tok . $next_tok;
+ $i = $i + 1;
+ $type = 'w';
+
+ # Optional coding to try to catch syntax errors. This can
+ # be removed if it ever causes incorrect warning messages.
+ # The '{^' should be preceded by either by a type or '$#'
+ # Examples:
+ # $#{^CAPTURE} ok
+ # *${^LAST_FH}{NAME} ok
+ # @{^HOWDY} ok
+ # $hash{^HOWDY} error
+
+ # Note that a type sigil '$' may be tokenized as 'Z'
+ # after something like 'print', so allow type 'Z'
+ if ( $last_last_nonblank_type ne 't'
+ && $last_last_nonblank_type ne 'Z'
+ && $last_last_nonblank_token ne '$#' )
+ {
+ warning("Possible syntax error near '{^'\n");
}
}
- elsif ( $expecting == TERM ) {
- my $number = scan_number_fast();
- # maybe part of bareword token? unary is safest
- if ( !defined($number) ) { $type = 'm'; }
-
- }
- elsif ( $expecting == OPERATOR ) {
- }
else {
+ unless ( error_if_expecting_TERM() ) {
- if ( $next_type eq 'w' ) {
- $type = 'm';
+ # Something like this is valid but strange:
+ # undef ^I;
+ complain("The '^' seems unusual here\n");
}
}
- },
+ }
+ return;
+ } ## end sub do_CARAT_SIGN
- '^' => sub {
+ sub do_DOUBLE_COLON {
- # check for special variables like ${^WARNING_BITS}
- if ( $expecting == TERM ) {
-
- if ( $last_nonblank_token eq '{'
- && ( $next_tok !~ /^\d/ )
- && ( $next_tok =~ /^\w/ ) )
- {
-
- if ( $next_tok eq 'W' ) {
- $tokenizer_self->[_saw_perl_dash_w_] = 1;
- }
- $tok = $tok . $next_tok;
- $i = $i + 1;
- $type = 'w';
-
- # Optional coding to try to catch syntax errors. This can
- # be removed if it ever causes incorrect warning messages.
- # The '{^' should be preceded by either by a type or '$#'
- # Examples:
- # $#{^CAPTURE} ok
- # *${^LAST_FH}{NAME} ok
- # @{^HOWDY} ok
- # $hash{^HOWDY} error
-
- # Note that a type sigil '$' may be tokenized as 'Z'
- # after something like 'print', so allow type 'Z'
- if ( $last_last_nonblank_type ne 't'
- && $last_last_nonblank_type ne 'Z'
- && $last_last_nonblank_token ne '$#' )
- {
- warning("Possible syntax error near '{^'\n");
- }
- }
-
- else {
- unless ( error_if_expecting_TERM() ) {
+ # '::' = probably a sub call
+ scan_bare_identifier();
+ return;
+ }
- # Something like this is valid but strange:
- # undef ^I;
- complain("The '^' seems unusual here\n");
- }
- }
- }
- },
+ sub do_LEFT_SHIFT {
- '::' => sub { # probably a sub call
- scan_bare_identifier();
- },
- '<<' => sub { # maybe a here-doc?
+ # '<<' = maybe a here-doc?
## This check removed because it could be a deprecated here-doc with
## no specified target. See example in log 16 Sep 2020.
## unless ( $i < $max_token_index )
## ; # here-doc not possible if end of line
- if ( $expecting != OPERATOR ) {
- my ( $found_target, $here_doc_target, $here_quote_character,
- $saw_error );
- (
- $found_target, $here_doc_target, $here_quote_character, $i,
- $saw_error
- )
- = find_here_doc( $expecting, $i, $rtokens, $rtoken_map,
- $max_token_index );
+ if ( $expecting != OPERATOR ) {
+ my ( $found_target, $here_doc_target, $here_quote_character,
+ $saw_error );
+ (
+ $found_target, $here_doc_target, $here_quote_character, $i,
+ $saw_error
+ )
+ = find_here_doc( $expecting, $i, $rtokens, $rtoken_map,
+ $max_token_index );
- if ($found_target) {
- push @{$rhere_target_list},
- [ $here_doc_target, $here_quote_character ];
- $type = 'h';
- if ( length($here_doc_target) > 80 ) {
- my $truncated = substr( $here_doc_target, 0, 80 );
- complain("Long here-target: '$truncated' ...\n");
- }
- elsif ( !$here_doc_target ) {
- warning(
- 'Use of bare << to mean <<"" is deprecated' . "\n" )
- unless ($here_quote_character);
- }
- elsif ( $here_doc_target !~ /^[A-Z_]\w+$/ ) {
- complain(
- "Unconventional here-target: '$here_doc_target'\n");
- }
+ if ($found_target) {
+ push @{$rhere_target_list},
+ [ $here_doc_target, $here_quote_character ];
+ $type = 'h';
+ if ( length($here_doc_target) > 80 ) {
+ my $truncated = substr( $here_doc_target, 0, 80 );
+ complain("Long here-target: '$truncated' ...\n");
+ }
+ elsif ( !$here_doc_target ) {
+ warning(
+ 'Use of bare << to mean <<"" is deprecated' . "\n" )
+ unless ($here_quote_character);
+ }
+ elsif ( $here_doc_target !~ /^[A-Z_]\w+$/ ) {
+ complain(
+ "Unconventional here-target: '$here_doc_target'\n");
}
- elsif ( $expecting == TERM ) {
- unless ($saw_error) {
+ }
+ elsif ( $expecting == TERM ) {
+ unless ($saw_error) {
- # shouldn't happen..arriving here implies an error in
- # the logic in sub 'find_here_doc'
- if (DEVEL_MODE) {
- Fault(<<EOM);
+ # shouldn't happen..arriving here implies an error in
+ # the logic in sub 'find_here_doc'
+ if (DEVEL_MODE) {
+ Fault(<<EOM);
Program bug; didn't find here doc target
EOM
- }
- warning(
-"Possible program error: didn't find here doc target\n"
- );
- report_definite_bug();
}
+ warning(
+ "Possible program error: didn't find here doc target\n"
+ );
+ report_definite_bug();
}
}
- else {
- }
- },
- '<<~' => sub { # a here-doc, new type added in v26
- return
- unless ( $i < $max_token_index )
- ; # here-doc not possible if end of line
- if ( $expecting != OPERATOR ) {
- my ( $found_target, $here_doc_target, $here_quote_character,
- $saw_error );
- (
- $found_target, $here_doc_target, $here_quote_character, $i,
- $saw_error
- )
- = find_here_doc( $expecting, $i, $rtokens, $rtoken_map,
- $max_token_index );
+ }
+ else {
+ }
+ return;
+ } ## end sub do_LEFT_SHIFT
- if ($found_target) {
+ sub do_NEW_HERE_DOC {
- if ( length($here_doc_target) > 80 ) {
- my $truncated = substr( $here_doc_target, 0, 80 );
- complain("Long here-target: '$truncated' ...\n");
- }
- elsif ( $here_doc_target !~ /^[A-Z_]\w+$/ ) {
- complain(
- "Unconventional here-target: '$here_doc_target'\n");
- }
+ # '<<~' = a here-doc, new type added in v26
+ return
+ unless ( $i < $max_token_index )
+ ; # here-doc not possible if end of line
+ if ( $expecting != OPERATOR ) {
+ my ( $found_target, $here_doc_target, $here_quote_character,
+ $saw_error );
+ (
+ $found_target, $here_doc_target, $here_quote_character, $i,
+ $saw_error
+ )
+ = find_here_doc( $expecting, $i, $rtokens, $rtoken_map,
+ $max_token_index );
- # Note that we put a leading space on the here quote
- # character indicate that it may be preceded by spaces
- $here_quote_character = " " . $here_quote_character;
- push @{$rhere_target_list},
- [ $here_doc_target, $here_quote_character ];
- $type = 'h';
+ if ($found_target) {
+
+ if ( length($here_doc_target) > 80 ) {
+ my $truncated = substr( $here_doc_target, 0, 80 );
+ complain("Long here-target: '$truncated' ...\n");
+ }
+ elsif ( $here_doc_target !~ /^[A-Z_]\w+$/ ) {
+ complain(
+ "Unconventional here-target: '$here_doc_target'\n");
}
- elsif ( $expecting == TERM ) {
- unless ($saw_error) {
- # shouldn't happen..arriving here implies an error in
- # the logic in sub 'find_here_doc'
- if (DEVEL_MODE) {
- Fault(<<EOM);
+ # Note that we put a leading space on the here quote
+ # character indicate that it may be preceded by spaces
+ $here_quote_character = SPACE . $here_quote_character;
+ push @{$rhere_target_list},
+ [ $here_doc_target, $here_quote_character ];
+ $type = 'h';
+ }
+ elsif ( $expecting == TERM ) {
+ unless ($saw_error) {
+
+ # shouldn't happen..arriving here implies an error in
+ # the logic in sub 'find_here_doc'
+ if (DEVEL_MODE) {
+ Fault(<<EOM);
Program bug; didn't find here doc target
EOM
- }
- warning(
-"Possible program error: didn't find here doc target\n"
- );
- report_definite_bug();
}
+ warning(
+ "Possible program error: didn't find here doc target\n"
+ );
+ report_definite_bug();
+ }
+ }
+ }
+ else {
+ error_if_expecting_OPERATOR();
+ }
+ return;
+ } ## end sub do_NEW_HERE_DOC
+
+ sub do_POINTER {
+
+ # '->'
+ # if -> points to a bare word, we must scan for an identifier,
+ # otherwise something like ->y would look like the y operator
+
+ # NOTE: this will currently allow things like
+ # '->@array' '->*VAR' '->%hash'
+ # to get parsed as identifiers, even though these are not currently
+ # allowed syntax. To catch syntax errors like this we could first
+ # check that the next character and skip this call if it is one of
+ # ' @ % * '. A disadvantage with doing this is that this would
+ # have to be fixed if the perltidy syntax is ever extended to make
+ # any of these valid. So for now this check is not done.
+ scan_simple_identifier();
+ return;
+ } ## end sub do_POINTER
+
+ sub do_PLUS_PLUS {
+
+ # '++'
+ # type = 'pp' for pre-increment, '++' for post-increment
+ if ( $expecting == TERM ) { $type = 'pp' }
+ elsif ( $expecting == UNKNOWN ) {
+
+ my ( $next_nonblank_token, $i_next ) =
+ find_next_nonblank_token( $i, $rtokens, $max_token_index );
+
+ # Fix for c042: look past a side comment
+ if ( $next_nonblank_token eq '#' ) {
+ ( $next_nonblank_token, $i_next ) =
+ find_next_nonblank_token( $max_token_index,
+ $rtokens, $max_token_index );
+ }
+
+ if ( $next_nonblank_token eq '$' ) { $type = 'pp' }
+ }
+ return;
+ } ## end sub do_PLUS_PLUS
+
+ sub do_FAT_COMMA {
+
+ # '=>'
+ if ( $last_nonblank_type eq $tok ) {
+ complain("Repeated '=>'s \n");
+ }
+
+ # patch for operator_expected: note if we are in the list (use.t)
+ # TODO: make version numbers a new token type
+ if ( $statement_type eq 'use' ) { $statement_type = '_use' }
+ return;
+ } ## end sub do_FAT_COMMA
+
+ sub do_MINUS_MINUS {
+
+ # '--'
+ # type = 'mm' for pre-decrement, '--' for post-decrement
+
+ if ( $expecting == TERM ) { $type = 'mm' }
+ elsif ( $expecting == UNKNOWN ) {
+ my ( $next_nonblank_token, $i_next ) =
+ find_next_nonblank_token( $i, $rtokens, $max_token_index );
+
+ # Fix for c042: look past a side comment
+ if ( $next_nonblank_token eq '#' ) {
+ ( $next_nonblank_token, $i_next ) =
+ find_next_nonblank_token( $max_token_index,
+ $rtokens, $max_token_index );
+ }
+
+ if ( $next_nonblank_token eq '$' ) { $type = 'mm' }
+ }
+ return;
+ } ## end sub do_MINUS_MINUS
+
+ sub do_LOGICAL_AND {
+
+ # '&&'
+ error_if_expecting_TERM()
+ if ( $expecting == TERM && $last_nonblank_token ne ',' ); #c015
+ return;
+ }
+
+ sub do_LOGICAL_OR {
+
+ # '||'
+ error_if_expecting_TERM()
+ if ( $expecting == TERM && $last_nonblank_token ne ',' ); #c015
+ return;
+ }
+
+ sub do_SLASH_SLASH {
+
+ # '//'
+ error_if_expecting_TERM()
+ if ( $expecting == TERM );
+ return;
+ }
+
+ sub do_DIGITS {
+
+ # 'd' = string of digits
+ error_if_expecting_OPERATOR("Number")
+ if ( $expecting == OPERATOR );
+
+ my $number = scan_number_fast();
+ if ( !defined($number) ) {
+
+ # shouldn't happen - we should always get a number
+ if (DEVEL_MODE) {
+ Fault(<<EOM);
+non-number beginning with digit--program bug
+EOM
+ }
+ warning(
+ "Unexpected error condition: non-number beginning with digit\n"
+ );
+ report_definite_bug();
+ }
+ return;
+ } ## end sub do_DIGITS
+
+ sub do_ATTRIBUTE_LIST {
+
+ my ($next_nonblank_token) = @_;
+
+ # Called at a bareword encountered while in an attribute list
+ # returns 'is_attribute':
+ # true if attribute found
+ # false if an attribute (continue parsing bareword)
+
+ # treat bare word followed by open paren like qw(
+ if ( $next_nonblank_token eq '(' ) {
+
+ # For something like:
+ # : prototype($$)
+ # we should let do_scan_sub see it so that it can see
+ # the prototype. All other attributes get parsed as a
+ # quoted string.
+ if ( $tok eq 'prototype' ) {
+ $id_scan_state = 'prototype';
+
+ # start just after the word 'prototype'
+ my $i_beg = $i + 1;
+ ( $i, $tok, $type, $id_scan_state ) = do_scan_sub(
+ {
+ input_line => $input_line,
+ i => $i,
+ i_beg => $i_beg,
+ tok => $tok,
+ type => $type,
+ rtokens => $rtokens,
+ rtoken_map => $rtoken_map,
+ id_scan_state => $id_scan_state,
+ max_token_index => $max_token_index
+ }
+ );
+
+ # If successful, mark as type 'q' to be consistent
+ # with other attributes. Type 'w' would also work.
+ if ( $i > $i_beg ) {
+ $type = 'q';
+ return 1;
+ }
+
+ # If not successful, continue and parse as a quote.
+ }
+
+ # All other attribute lists must be parsed as quotes
+ # (see 'signatures.t' for good examples)
+ $in_quote = $quote_items{'q'};
+ $allowed_quote_modifiers = $quote_modifiers{'q'};
+ $type = 'q';
+ $quote_type = 'q';
+ return 1;
+ }
+
+ # handle bareword not followed by open paren
+ else {
+ $type = 'w';
+ return 1;
+ }
+
+ # attribute not found
+ return;
+ } ## end sub do_ATTRIBUTE_LIST
+
+ sub do_QUOTED_BAREWORD {
+
+ # find type of a bareword followed by a '=>'
+ if ( $is_constant{$current_package}{$tok} ) {
+ $type = 'C';
+ }
+ elsif ( $is_user_function{$current_package}{$tok} ) {
+ $type = 'U';
+ $prototype = $user_function_prototype{$current_package}{$tok};
+ }
+ elsif ( $tok =~ /^v\d+$/ ) {
+ $type = 'v';
+ report_v_string($tok);
+ }
+ else {
+
+ # Bareword followed by a fat comma - see 'git18.in'
+ # If tok is something like 'x17' then it could
+ # actually be operator x followed by number 17.
+ # For example, here:
+ # 123x17 => [ 792, 1224 ],
+ # (a key of 123 repeated 17 times, perhaps not
+ # what was intended). We will mark x17 as type
+ # 'n' and it will be split. If the previous token
+ # was also a bareword then it is not very clear is
+ # going on. In this case we will not be sure that
+ # an operator is expected, so we just mark it as a
+ # bareword. Perl is a little murky in what it does
+ # with stuff like this, and its behavior can change
+ # over time. Something like
+ # a x18 => [792, 1224], will compile as
+ # a key with 18 a's. But something like
+ # push @array, a x18;
+ # is a syntax error.
+ if (
+ $expecting == OPERATOR
+ && substr( $tok, 0, 1 ) eq 'x'
+ && ( length($tok) == 1
+ || substr( $tok, 1, 1 ) =~ /^\d/ )
+ )
+ {
+ $type = 'n';
+ if ( split_pretoken(1) ) {
+ $type = 'x';
+ $tok = 'x';
}
}
else {
+
+ # git #18
+ $type = 'w';
error_if_expecting_OPERATOR();
}
- },
- '->' => sub {
+ }
+ return;
+ } ## end sub do_QUOTED_BAREWORD
- # if -> points to a bare word, we must scan for an identifier,
- # otherwise something like ->y would look like the y operator
+ sub do_X_OPERATOR {
- # NOTE: this will currently allow things like
- # '->@array' '->*VAR' '->%hash'
- # to get parsed as identifiers, even though these are not currently
- # allowed syntax. To catch syntax errors like this we could first
- # check that the next character and skip this call if it is one of
- # ' @ % * '. A disadvantage with doing this is that this would
- # have to be fixed if the perltidy syntax is ever extended to make
- # any of these valid. So for now this check is not done.
- scan_identifier_fast();
- },
+ if ( $tok eq 'x' ) {
+ if ( $rtokens->[ $i + 1 ] eq '=' ) { # x=
+ $tok = 'x=';
+ $type = $tok;
+ $i++;
+ }
+ else {
+ $type = 'x';
+ }
+ }
+ else {
- # type = 'pp' for pre-increment, '++' for post-increment
- '++' => sub {
- if ( $expecting == TERM ) { $type = 'pp' }
- elsif ( $expecting == UNKNOWN ) {
-
- my ( $next_nonblank_token, $i_next ) =
- find_next_nonblank_token( $i, $rtokens, $max_token_index );
-
- # Fix for c042: look past a side comment
- if ( $next_nonblank_token eq '#' ) {
- ( $next_nonblank_token, $i_next ) =
- find_next_nonblank_token( $max_token_index,
- $rtokens, $max_token_index );
+ # Split a pretoken like 'x10' into 'x' and '10'.
+ # Note: In previous versions of perltidy it was marked
+ # as a number, $type = 'n', and fixed downstream by the
+ # Formatter.
+ $type = 'n';
+ if ( split_pretoken(1) ) {
+ $type = 'x';
+ $tok = 'x';
+ }
+ }
+ return;
+ } ## end sub do_X_OPERATOR
+
+ sub do_USE_CONSTANT {
+ scan_bare_identifier();
+ my ( $next_nonblank_tok2, $i_next2 ) =
+ find_next_nonblank_token( $i, $rtokens, $max_token_index );
+
+ if ($next_nonblank_tok2) {
+
+ if ( $is_keyword{$next_nonblank_tok2} ) {
+
+ # Assume qw is used as a quote and okay, as in:
+ # use constant qw{ DEBUG 0 };
+ # Not worth trying to parse for just a warning
+
+ # NOTE: This warning is deactivated because recent
+ # versions of perl do not complain here, but
+ # the coding is retained for reference.
+ if ( 0 && $next_nonblank_tok2 ne 'qw' ) {
+ warning(
+"Attempting to define constant '$next_nonblank_tok2' which is a perl keyword\n"
+ );
}
+ }
- if ( $next_nonblank_token eq '$' ) { $type = 'pp' }
+ else {
+ $is_constant{$current_package}{$next_nonblank_tok2} = 1;
}
- },
+ }
+ return;
+ } ## end sub do_USE_CONSTANT
+
+ sub do_KEYWORD {
- '=>' => sub {
- if ( $last_nonblank_type eq $tok ) {
- complain("Repeated '=>'s \n");
+ # found a keyword - set any associated flags
+ $type = 'k';
+
+ # Since for and foreach may not be followed immediately
+ # by an opening paren, we have to remember which keyword
+ # is associated with the next '('
+ if ( $is_for_foreach{$tok} ) {
+ if ( new_statement_ok() ) {
+ $want_paren = $tok;
}
+ }
- # patch for operator_expected: note if we are in the list (use.t)
- # TODO: make version numbers a new token type
- if ( $statement_type eq 'use' ) { $statement_type = '_use' }
- },
+ # recognize 'use' statements, which are special
+ elsif ( $is_use_require{$tok} ) {
+ $statement_type = $tok;
+ error_if_expecting_OPERATOR()
+ if ( $expecting == OPERATOR );
+ }
+
+ # remember my and our to check for trailing ": shared"
+ elsif ( $is_my_our_state{$tok} ) {
+ $statement_type = $tok;
+ }
+
+ # Check for misplaced 'elsif' and 'else', but allow isolated
+ # else or elsif blocks to be formatted. This is indicated
+ # by a last noblank token of ';'
+ elsif ( $tok eq 'elsif' ) {
+ if (
+ $last_nonblank_token ne ';'
+
+ ## !~ /^(if|elsif|unless)$/
+ && !$is_if_elsif_unless{$last_nonblank_block_type}
+ )
+ {
+ warning(
+ "expecting '$tok' to follow one of 'if|elsif|unless'\n");
+ }
+ }
+ elsif ( $tok eq 'else' ) {
+
+ # patched for SWITCH/CASE
+ if (
+ $last_nonblank_token ne ';'
+
+ ## !~ /^(if|elsif|unless|case|when)$/
+ && !$is_if_elsif_unless_case_when{$last_nonblank_block_type}
+
+ # patch to avoid an unwanted error message for
+ # the case of a parenless 'case' (RT 105484):
+ # switch ( 1 ) { case x { 2 } else { } }
+ ## !~ /^(if|elsif|unless|case|when)$/
+ && !$is_if_elsif_unless_case_when{$statement_type}
+ )
+ {
+ warning(
+"expecting '$tok' to follow one of 'if|elsif|unless|case|when'\n"
+ );
+ }
+ }
+ elsif ( $tok eq 'continue' ) {
+ if ( $last_nonblank_token ne ';'
+ && $last_nonblank_block_type !~
+ /(^(\{|\}|;|while|until|for|foreach)|:$)/ )
+ {
+
+ # note: ';' '{' and '}' in list above
+ # because continues can follow bare blocks;
+ # ':' is labeled block
+ #
+ ############################################
+ # NOTE: This check has been deactivated because
+ # continue has an alternative usage for given/when
+ # blocks in perl 5.10
+ ## warning("'$tok' should follow a block\n");
+ ############################################
+ }
+ }
+
+ # patch for SWITCH/CASE if 'case' and 'when are
+ # treated as keywords. Also 'default' for Switch::Plain
+ elsif ($tok eq 'when'
+ || $tok eq 'case'
+ || $tok eq 'default' )
+ {
+ $statement_type = $tok; # next '{' is block
+ }
+
+ #
+ # indent trailing if/unless/while/until
+ # outdenting will be handled by later indentation loop
+## DEACTIVATED: unfortunately this can cause some unwanted indentation like:
+##$opt_o = 1
+## if !(
+## $opt_b
+## || $opt_c
+## || $opt_d
+## || $opt_f
+## || $opt_i
+## || $opt_l
+## || $opt_o
+## || $opt_x
+## );
+## if ( $tok =~ /^(if|unless|while|until)$/
+## && $next_nonblank_token ne '(' )
+## {
+## $indent_flag = 1;
+## }
+ return;
+ } ## end sub do_KEYWORD
+
+ sub do_QUOTE_OPERATOR {
+##NICOL PATCH
+ if ( $expecting == OPERATOR ) {
+
+ # Be careful not to call an error for a qw quote
+ # where a parenthesized list is allowed. For example,
+ # it could also be a for/foreach construct such as
+ #
+ # foreach my $key qw\Uno Due Tres Quadro\ {
+ # print "Set $key\n";
+ # }
+ #
+
+ # Or it could be a function call.
+ # NOTE: Braces in something like &{ xxx } are not
+ # marked as a block, we might have a method call.
+ # &method(...), $method->(..), &{method}(...),
+ # $ref[2](list) is ok & short for $ref[2]->(list)
+ #
+ # See notes in 'sub code_block_type' and
+ # 'sub is_non_structural_brace'
+
+ unless (
+ $tok eq 'qw'
+ && ( $last_nonblank_token =~ /^([\]\}\&]|\-\>)/
+ || $is_for_foreach{$want_paren} )
+ )
+ {
+ error_if_expecting_OPERATOR();
+ }
+ }
+ $in_quote = $quote_items{$tok};
+ $allowed_quote_modifiers = $quote_modifiers{$tok};
+
+ # All quote types are 'Q' except possibly qw quotes.
+ # qw quotes are special in that they may generally be trimmed
+ # of leading and trailing whitespace. So they are given a
+ # separate type, 'q', unless requested otherwise.
+ $type =
+ ( $tok eq 'qw' && $tokenizer_self->[_trim_qw_] )
+ ? 'q'
+ : 'Q';
+ $quote_type = $type;
+ return;
+ } ## end sub do_QUOTE_OPERATOR
+
+ sub do_UNKNOWN_BAREWORD {
+
+ my ($next_nonblank_token) = @_;
+
+ scan_bare_identifier();
+
+ if ( $statement_type eq 'use'
+ && $last_nonblank_token eq 'use' )
+ {
+ $saw_use_module{$current_package}->{$tok} = 1;
+ }
+
+ if ( $type eq 'w' ) {
+
+ if ( $expecting == OPERATOR ) {
+
+ # Patch to avoid error message for RPerl overloaded
+ # operator functions: use overload
+ # '+' => \&sse_add,
+ # '-' => \&sse_sub,
+ # '*' => \&sse_mul,
+ # '/' => \&sse_div;
+ # FIXME: this should eventually be generalized
+ if ( $saw_use_module{$current_package}->{'RPerl'}
+ && $tok =~ /^sse_(mul|div|add|sub)$/ )
+ {
+
+ }
+
+ # Fix part 1 for git #63 in which a comment falls
+ # between an -> and the following word. An
+ # alternate fix would be to change operator_expected
+ # to return an UNKNOWN for this type.
+ elsif ( $last_nonblank_type eq '->' ) {
- # type = 'mm' for pre-decrement, '--' for post-decrement
- '--' => sub {
-
- if ( $expecting == TERM ) { $type = 'mm' }
- elsif ( $expecting == UNKNOWN ) {
- my ( $next_nonblank_token, $i_next ) =
- find_next_nonblank_token( $i, $rtokens, $max_token_index );
-
- # Fix for c042: look past a side comment
- if ( $next_nonblank_token eq '#' ) {
- ( $next_nonblank_token, $i_next ) =
- find_next_nonblank_token( $max_token_index,
- $rtokens, $max_token_index );
}
- if ( $next_nonblank_token eq '$' ) { $type = 'mm' }
+ # don't complain about possible indirect object
+ # notation.
+ # For example:
+ # package main;
+ # sub new($) { ... }
+ # $b = new A::; # calls A::new
+ # $c = new A; # same thing but suspicious
+ # This will call A::new but we have a 'new' in
+ # main:: which looks like a constant.
+ #
+ elsif ( $last_nonblank_type eq 'C' ) {
+ if ( $tok !~ /::$/ ) {
+ complain(<<EOM);
+Expecting operator after '$last_nonblank_token' but found bare word '$tok'
+ Maybe indirectet object notation?
+EOM
+ }
+ }
+ else {
+ error_if_expecting_OPERATOR("bareword");
+ }
}
- },
- '&&' => sub {
- error_if_expecting_TERM()
- if ( $expecting == TERM && $last_nonblank_token ne ',' ); #c015
- },
+ # mark bare words immediately followed by a paren as
+ # functions
+ $next_tok = $rtokens->[ $i + 1 ];
+ if ( $next_tok eq '(' ) {
- '||' => sub {
- error_if_expecting_TERM()
- if ( $expecting == TERM && $last_nonblank_token ne ',' ); #c015
- },
+ # Fix part 2 for git #63. Leave type as 'w' to keep
+ # the type the same as if the -> were not separated
+ $type = 'U' unless ( $last_nonblank_type eq '->' );
+ }
- '//' => sub {
- error_if_expecting_TERM()
- if ( $expecting == TERM );
- },
- };
+ # underscore after file test operator is file handle
+ if ( $tok eq '_' && $last_nonblank_type eq 'F' ) {
+ $type = 'Z';
+ }
- # ------------------------------------------------------------
- # end hash of code for handling individual token types
- # ------------------------------------------------------------
+ # patch for SWITCH/CASE if 'case' and 'when are
+ # not treated as keywords:
+ if (
+ ( $tok eq 'case' && $brace_type[$brace_depth] eq 'switch' )
+ || ( $tok eq 'when'
+ && $brace_type[$brace_depth] eq 'given' )
+ )
+ {
+ $statement_type = $tok; # next '{' is block
+ $type = 'k'; # for keyword syntax coloring
+ }
- my %matching_start_token = ( '}' => '{', ']' => '[', ')' => '(' );
+ # patch for SWITCH/CASE if switch and given not keywords
+ # Switch is not a perl 5 keyword, but we will gamble
+ # and mark switch followed by paren as a keyword. This
+ # is only necessary to get html syntax coloring nice,
+ # and does not commit this as being a switch/case.
+ if ( $next_nonblank_token eq '('
+ && ( $tok eq 'switch' || $tok eq 'given' ) )
+ {
+ $type = 'k'; # for keyword syntax coloring
+ }
+ }
+ return;
+ } ## end sub do_UNKNOWN_BAREWORD
- # These block types terminate statements and do not need a trailing
- # semicolon
- # patched for SWITCH/CASE/
- my %is_zero_continuation_block_type;
- @_ = qw( } { BEGIN END CHECK INIT AUTOLOAD DESTROY UNITCHECK continue ;
- if elsif else unless while until for foreach switch case given when);
- @is_zero_continuation_block_type{@_} = (1) x scalar(@_);
+ sub sub_attribute_ok_here {
- my %is_logical_container;
- @_ = qw(if elsif unless while and or err not && ! || for foreach);
- @is_logical_container{@_} = (1) x scalar(@_);
+ my ( $tok_kw, $next_nonblank_token, $i_next ) = @_;
- my %is_binary_type;
- @_ = qw(|| &&);
- @is_binary_type{@_} = (1) x scalar(@_);
+ # Decide if 'sub :' can be the start of a sub attribute list.
+ # We will decide based on if the colon is followed by a
+ # bareword which is not a keyword.
+ # Changed inext+1 to inext to fixed case b1190.
+ my $sub_attribute_ok_here;
+ if ( $is_sub{$tok_kw}
+ && $expecting != OPERATOR
+ && $next_nonblank_token eq ':' )
+ {
+ my ( $nn_nonblank_token, $i_nn ) =
+ find_next_nonblank_token( $i_next, $rtokens, $max_token_index );
+ $sub_attribute_ok_here =
+ $nn_nonblank_token =~ /^\w/
+ && $nn_nonblank_token !~ /^\d/
+ && !$is_keyword{$nn_nonblank_token};
+ }
+ return $sub_attribute_ok_here;
+ } ## end sub sub_attribute_ok_here
- my %is_binary_keyword;
- @_ = qw(and or err eq ne cmp);
- @is_binary_keyword{@_} = (1) x scalar(@_);
+ sub do_BAREWORD {
- # 'L' is token for opening { at hash key
- my %is_opening_type;
- @_ = qw< L { ( [ >;
- @is_opening_type{@_} = (1) x scalar(@_);
+ my ($is_END_or_DATA) = @_;
- # 'R' is token for closing } at hash key
- my %is_closing_type;
- @_ = qw< R } ) ] >;
- @is_closing_type{@_} = (1) x scalar(@_);
+ # handle a bareword token:
+ # returns
+ # true if this token ends the current line
+ # false otherwise
- my %is_redo_last_next_goto;
- @_ = qw(redo last next goto);
- @is_redo_last_next_goto{@_} = (1) x scalar(@_);
+ # Patch for c043, part 3: A bareword after '->' expects a TERM
+ # FIXME: It would be cleaner to give method calls a new type 'M'
+ # and update sub operator_expected to handle this.
+ if ( $last_nonblank_type eq '->' ) {
+ $expecting = TERM;
+ }
- my %is_use_require;
- @_ = qw(use require);
- @is_use_require{@_} = (1) x scalar(@_);
+ my ( $next_nonblank_token, $i_next ) =
+ find_next_nonblank_token( $i, $rtokens, $max_token_index );
- # This hash holds the array index in $tokenizer_self for these keywords:
- # Fix for issue c035: removed 'format' from this hash
- my %is_END_DATA = (
- '__END__' => _in_end_,
- '__DATA__' => _in_data_,
- );
+ # a bare word immediately followed by :: is not a keyword;
+ # use $tok_kw when testing for keywords to avoid a mistake
+ my $tok_kw = $tok;
+ if ( $rtokens->[ $i + 1 ] eq ':'
+ && $rtokens->[ $i + 2 ] eq ':' )
+ {
+ $tok_kw .= '::';
+ }
- # original ref: camel 3 p 147,
- # but perl may accept undocumented flags
- # perl 5.10 adds 'p' (preserve)
- # Perl version 5.22 added 'n'
- # From http://perldoc.perl.org/perlop.html we have
- # /PATTERN/msixpodualngc or m?PATTERN?msixpodualngc
- # s/PATTERN/REPLACEMENT/msixpodualngcer
- # y/SEARCHLIST/REPLACEMENTLIST/cdsr
- # tr/SEARCHLIST/REPLACEMENTLIST/cdsr
- # qr/STRING/msixpodualn
- my %quote_modifiers = (
- 's' => '[msixpodualngcer]',
- 'y' => '[cdsr]',
- 'tr' => '[cdsr]',
- 'm' => '[msixpodualngc]',
- 'qr' => '[msixpodualn]',
- 'q' => "",
- 'qq' => "",
- 'qw' => "",
- 'qx' => "",
- );
+ if ($in_attribute_list) {
+ my $is_attribute = do_ATTRIBUTE_LIST($next_nonblank_token);
+ return if ($is_attribute);
+ }
- # table showing how many quoted things to look for after quote operator..
- # s, y, tr have 2 (pattern and replacement)
- # others have 1 (pattern only)
- my %quote_items = (
- 's' => 2,
- 'y' => 2,
- 'tr' => 2,
- 'm' => 1,
- 'qr' => 1,
- 'q' => 1,
- 'qq' => 1,
- 'qw' => 1,
- 'qx' => 1,
- );
+ #----------------------------------------
+ # Starting final if-elsif- chain of tests
+ #----------------------------------------
+
+ # This is the return flag:
+ # true => this is the last token on the line
+ # false => keep tokenizing the line
+ my $is_last;
+
+ # The following blocks of code must update these vars:
+ # $type - the final token type, must always be set
+
+ # In addition, if additional pretokens are added:
+ # $tok - the final token
+ # $i - the index of the last pretoken
+
+ # They may also need to check and set various flags
+
+ # Quote a word followed by => operator
+ # unless the word __END__ or __DATA__ and the only word on
+ # the line.
+ if ( !$is_END_or_DATA
+ && $next_nonblank_token eq '='
+ && $rtokens->[ $i_next + 1 ] eq '>' )
+ {
+ do_QUOTED_BAREWORD();
+ }
+
+ # quote a bare word within braces..like xxx->{s}; note that we
+ # must be sure this is not a structural brace, to avoid
+ # mistaking {s} in the following for a quoted bare word:
+ # for(@[){s}bla}BLA}
+ # Also treat q in something like var{-q} as a bare word, not
+ # a quote operator
+ elsif (
+ $next_nonblank_token eq '}'
+ && (
+ $last_nonblank_type eq 'L'
+ || ( $last_nonblank_type eq 'm'
+ && $last_last_nonblank_type eq 'L' )
+ )
+ )
+ {
+ $type = 'w';
+ }
+
+ # Scan a bare word following a -> as an identifier; it could
+ # have a long package name. Fixes c037, c041.
+ elsif ( $last_nonblank_token eq '->' ) {
+ scan_bare_identifier();
+
+ # Patch for c043, part 4; use type 'w' after a '->'.
+ # This is just a safety check on sub scan_bare_identifier,
+ # which should get this case correct.
+ $type = 'w';
+ }
+
+ # handle operator x (now we know it isn't $x=)
+ elsif (
+ $expecting == OPERATOR
+ && substr( $tok, 0, 1 ) eq 'x'
+ && ( length($tok) == 1
+ || substr( $tok, 1, 1 ) =~ /^\d/ )
+ )
+ {
+ do_X_OPERATOR();
+ }
+ elsif ( $tok_kw eq 'CORE::' ) {
+ $type = $tok = $tok_kw;
+ $i += 2;
+ }
+ elsif ( ( $tok eq 'strict' )
+ and ( $last_nonblank_token eq 'use' ) )
+ {
+ $tokenizer_self->[_saw_use_strict_] = 1;
+ scan_bare_identifier();
+ }
+
+ elsif ( ( $tok eq 'warnings' )
+ and ( $last_nonblank_token eq 'use' ) )
+ {
+ $tokenizer_self->[_saw_perl_dash_w_] = 1;
+
+ # scan as identifier, so that we pick up something like:
+ # use warnings::register
+ scan_bare_identifier();
+ }
+
+ elsif (
+ $tok eq 'AutoLoader'
+ && $tokenizer_self->[_look_for_autoloader_]
+ && (
+ $last_nonblank_token eq 'use'
+
+ # these regexes are from AutoSplit.pm, which we want
+ # to mimic
+ || $input_line =~ /^\s*(use|require)\s+AutoLoader\b/
+ || $input_line =~ /\bISA\s*=.*\bAutoLoader\b/
+ )
+ )
+ {
+ write_logfile_entry("AutoLoader seen, -nlal deactivates\n");
+ $tokenizer_self->[_saw_autoloader_] = 1;
+ $tokenizer_self->[_look_for_autoloader_] = 0;
+ scan_bare_identifier();
+ }
+
+ elsif (
+ $tok eq 'SelfLoader'
+ && $tokenizer_self->[_look_for_selfloader_]
+ && ( $last_nonblank_token eq 'use'
+ || $input_line =~ /^\s*(use|require)\s+SelfLoader\b/
+ || $input_line =~ /\bISA\s*=.*\bSelfLoader\b/ )
+ )
+ {
+ write_logfile_entry("SelfLoader seen, -nlsl deactivates\n");
+ $tokenizer_self->[_saw_selfloader_] = 1;
+ $tokenizer_self->[_look_for_selfloader_] = 0;
+ scan_bare_identifier();
+ }
+
+ elsif ( ( $tok eq 'constant' )
+ and ( $last_nonblank_token eq 'use' ) )
+ {
+ do_USE_CONSTANT();
+ }
+
+ # various quote operators
+ elsif ( $is_q_qq_qw_qx_qr_s_y_tr_m{$tok} ) {
+ do_QUOTE_OPERATOR();
+ }
+
+ # check for a statement label
+ elsif (
+ ( $next_nonblank_token eq ':' )
+ && ( $rtokens->[ $i_next + 1 ] ne ':' )
+ && ( $i_next <= $max_token_index ) # colon on same line
+
+ # like 'sub : lvalue' ?
+ ##&& !$sub_attribute_ok_here # like 'sub : lvalue' ?
+ && !sub_attribute_ok_here( $tok_kw, $next_nonblank_token, $i_next )
+ && label_ok()
+ )
+ {
+ if ( $tok !~ /[A-Z]/ ) {
+ push @{ $tokenizer_self->[_rlower_case_labels_at_] },
+ $input_line_number;
+ }
+ $type = 'J';
+ $tok .= ':';
+ $i = $i_next;
+ }
+
+ # 'sub' or alias
+ elsif ( $is_sub{$tok_kw} ) {
+ error_if_expecting_OPERATOR()
+ if ( $expecting == OPERATOR );
+ initialize_subname();
+ scan_id();
+ }
+
+ # 'package'
+ elsif ( $is_package{$tok_kw} ) {
+ error_if_expecting_OPERATOR()
+ if ( $expecting == OPERATOR );
+ scan_id();
+ }
+
+ # Fix for c035: split 'format' from 'is_format_END_DATA' to be
+ # more restrictive. Require a new statement to be ok here.
+ elsif ( $tok_kw eq 'format' && new_statement_ok() ) {
+ $type = ';'; # make tokenizer look for TERM next
+ $tokenizer_self->[_in_format_] = 1;
+ $is_last = 1; ## is last token on this line
+ }
+
+ # Note on token types for format, __DATA__, __END__:
+ # It simplifies things to give these type ';', so that when we
+ # start rescanning we will be expecting a token of type TERM.
+ # We will switch to type 'k' before outputting the tokens.
+ elsif ( $is_END_DATA{$tok_kw} ) {
+ $type = ';'; # make tokenizer look for TERM next
+
+ # Remember that we are in one of these three sections
+ $tokenizer_self->[ $is_END_DATA{$tok_kw} ] = 1;
+ $is_last = 1; ## is last token on this line
+ }
+
+ elsif ( $is_keyword{$tok_kw} ) {
+ do_KEYWORD();
+ }
+
+ # check for inline label following
+ # /^(redo|last|next|goto)$/
+ elsif (( $last_nonblank_type eq 'k' )
+ && ( $is_redo_last_next_goto{$last_nonblank_token} ) )
+ {
+ $type = 'j';
+ }
+
+ # something else --
+ else {
+ do_UNKNOWN_BAREWORD($next_nonblank_token);
+ }
+
+ return $is_last;
+
+ } ## end sub do_BAREWORD
+
+ sub do_FOLLOW_QUOTE {
+
+ # Continue following a quote on a new line
+ $type = $quote_type;
+
+ unless ( @{$routput_token_list} ) { # initialize if continuation line
+ push( @{$routput_token_list}, $i );
+ $routput_token_type->[$i] = $type;
+
+ }
+
+ # Removed to fix b1280. This is not needed and was causing the
+ # starting type 'qw' to be lost, leading to mis-tokenization of
+ # a trailing block brace in a parenless for stmt 'for .. qw.. {'
+ ##$tok = $quote_character if ($quote_character);
+
+ # scan for the end of the quote or pattern
+ (
+ $i, $in_quote, $quote_character, $quote_pos, $quote_depth,
+ $quoted_string_1, $quoted_string_2
+ )
+ = do_quote(
+ $i, $in_quote, $quote_character,
+ $quote_pos, $quote_depth, $quoted_string_1,
+ $quoted_string_2, $rtokens, $rtoken_map,
+ $max_token_index
+ );
+
+ # all done if we didn't find it
+ if ($in_quote) { return }
+
+ # save pattern and replacement text for rescanning
+ my $qs1 = $quoted_string_1;
+
+ # re-initialize for next search
+ $quote_character = EMPTY_STRING;
+ $quote_pos = 0;
+ $quote_type = 'Q';
+ $quoted_string_1 = EMPTY_STRING;
+ $quoted_string_2 = EMPTY_STRING;
+ if ( ++$i > $max_token_index ) { return }
+
+ # look for any modifiers
+ if ($allowed_quote_modifiers) {
+
+ # check for exact quote modifiers
+ if ( $rtokens->[$i] =~ /^[A-Za-z_]/ ) {
+ my $str = $rtokens->[$i];
+ my $saw_modifier_e;
+ while ( $str =~ /\G$allowed_quote_modifiers/gc ) {
+ my $pos = pos($str);
+ my $char = substr( $str, $pos - 1, 1 );
+ $saw_modifier_e ||= ( $char eq 'e' );
+ }
+
+ # For an 'e' quote modifier we must scan the replacement
+ # text for here-doc targets...
+ # but if the modifier starts a new line we can skip
+ # this because either the here doc will be fully
+ # contained in the replacement text (so we can
+ # ignore it) or Perl will not find it.
+ # See test 'here2.in'.
+ if ( $saw_modifier_e && $i_tok >= 0 ) {
+
+ my $rht = scan_replacement_text($qs1);
+
+ # Change type from 'Q' to 'h' for quotes with
+ # here-doc targets so that the formatter (see sub
+ # process_line_of_CODE) will not make any line
+ # breaks after this point.
+ if ($rht) {
+ push @{$rhere_target_list}, @{$rht};
+ $type = 'h';
+ if ( $i_tok < 0 ) {
+ my $ilast = $routput_token_list->[-1];
+ $routput_token_type->[$ilast] = $type;
+ }
+ }
+ }
+
+ if ( defined( pos($str) ) ) {
+
+ # matched
+ if ( pos($str) == length($str) ) {
+ if ( ++$i > $max_token_index ) { return }
+ }
+
+ # Looks like a joined quote modifier
+ # and keyword, maybe something like
+ # s/xxx/yyy/gefor @k=...
+ # Example is "galgen.pl". Would have to split
+ # the word and insert a new token in the
+ # pre-token list. This is so rare that I haven't
+ # done it. Will just issue a warning citation.
+
+ # This error might also be triggered if my quote
+ # modifier characters are incomplete
+ else {
+ warning(<<EOM);
+
+Partial match to quote modifier $allowed_quote_modifiers at word: '$str'
+Please put a space between quote modifiers and trailing keywords.
+EOM
+
+ # print "token $rtokens->[$i]\n";
+ # my $num = length($str) - pos($str);
+ # $rtokens->[$i]=substr($rtokens->[$i],pos($str),$num);
+ # print "continuing with new token $rtokens->[$i]\n";
+
+ # skipping past this token does least damage
+ if ( ++$i > $max_token_index ) { return }
+ }
+ }
+ else {
+
+ # example file: rokicki4.pl
+ # This error might also be triggered if my quote
+ # modifier characters are incomplete
+ write_logfile_entry(
+ "Note: found word $str at quote modifier location\n");
+ }
+ }
+
+ # re-initialize
+ $allowed_quote_modifiers = EMPTY_STRING;
+ }
+ return;
+ } ## end sub do_FOLLOW_QUOTE
+
+ # ------------------------------------------------------------
+ # begin hash of code for handling most token types
+ # ------------------------------------------------------------
+ my $tokenization_code = {
+
+ '>' => \&do_GREATER_THAN_SIGN,
+ '|' => \&do_VERTICAL_LINE,
+ '$' => \&do_DOLLAR_SIGN,
+ '(' => \&do_LEFT_PARENTHESIS,
+ ')' => \&do_RIGHT_PARENTHESIS,
+ ',' => \&do_COMMA,
+ ';' => \&do_SEMICOLON,
+ '"' => \&do_QUOTATION_MARK,
+ "'" => \&do_APOSTROPHE,
+ '`' => \&do_BACKTICK,
+ '/' => \&do_SLASH,
+ '{' => \&do_LEFT_CURLY_BRACKET,
+ '}' => \&do_RIGHT_CURLY_BRACKET,
+ '&' => \&do_AMPERSAND,
+ '<' => \&do_LESS_THAN_SIGN,
+ '?' => \&do_QUESTION_MARK,
+ '*' => \&do_STAR,
+ '.' => \&do_DOT,
+ ':' => \&do_COLON,
+ '+' => \&do_PLUS_SIGN,
+ '@' => \&do_AT_SIGN,
+ '%' => \&do_PERCENT_SIGN,
+ '[' => \&do_LEFT_SQUARE_BRACKET,
+ ']' => \&do_RIGHT_SQUARE_BRACKET,
+ '-' => \&do_MINUS_SIGN,
+ '^' => \&do_CARAT_SIGN,
+ '::' => \&do_DOUBLE_COLON,
+ '<<' => \&do_LEFT_SHIFT,
+ '<<~' => \&do_NEW_HERE_DOC,
+ '->' => \&do_POINTER,
+ '++' => \&do_PLUS_PLUS,
+ '=>' => \&do_FAT_COMMA,
+ '--' => \&do_MINUS_MINUS,
+ '&&' => \&do_LOGICAL_AND,
+ '||' => \&do_LOGICAL_OR,
+ '//' => \&do_SLASH_SLASH,
+
+ # No special code for these types yet, but syntax checks
+ # could be added.
+ ## '!' => undef,
+ ## '!=' => undef,
+ ## '!~' => undef,
+ ## '%=' => undef,
+ ## '&&=' => undef,
+ ## '&=' => undef,
+ ## '+=' => undef,
+ ## '-=' => undef,
+ ## '..' => undef,
+ ## '..' => undef,
+ ## '...' => undef,
+ ## '.=' => undef,
+ ## '<<=' => undef,
+ ## '<=' => undef,
+ ## '<=>' => undef,
+ ## '<>' => undef,
+ ## '=' => undef,
+ ## '==' => undef,
+ ## '=~' => undef,
+ ## '>=' => undef,
+ ## '>>' => undef,
+ ## '>>=' => undef,
+ ## '\\' => undef,
+ ## '^=' => undef,
+ ## '|=' => undef,
+ ## '||=' => undef,
+ ## '//=' => undef,
+ ## '~' => undef,
+ ## '~~' => undef,
+ ## '!~~' => undef,
+
+ };
+
+ # ------------------------------------------------------------
+ # end hash of code for handling individual token types
+ # ------------------------------------------------------------
use constant DEBUG_TOKENIZE => 0;
# do not trim end because we might end in a quote (test: deken4.pl)
# Perl::Tidy::Formatter will delete needless trailing blanks
unless ( $in_quote && ( $quote_type eq 'Q' ) ) {
- $input_line =~ s/^\s+//; # trim left end
+ $input_line =~ s/^(\s+)//; # trim left end
+
+ # calculate a guessed level for nonblank lines to avoid calls to
+ # sub guess_old_indentation_level()
+ if ( $input_line && $1 ) {
+ my $leading_spaces = $1;
+ my $spaces = length($leading_spaces);
+
+ # handle leading tabs
+ if ( ord( substr( $leading_spaces, 0, 1 ) ) == 9
+ && $leading_spaces =~ /^(\t+)/ )
+ {
+ my $tabsize = $tokenizer_self->[_tabsize_];
+ $spaces += length($1) * ( $tabsize - 1 );
+ }
+
+ my $indent_columns = $tokenizer_self->[_indent_columns_];
+ $line_of_tokens->{_guessed_indentation_level} =
+ int( $spaces / $indent_columns );
+ }
$is_END_or_DATA = substr( $input_line, 0, 1 ) eq '_'
- && $input_line =~ /^\s*__(END|DATA)__\s*$/;
+ && $input_line =~ /^__(END|DATA)__\s*$/;
}
# update the copy of the line for use in error messages
$indent_flag = 0;
$peeked_ahead = 0;
- # tokenization is done in two stages..
- # stage 1 is a very simple pre-tokenization
- my $max_tokens_wanted = 0; # this signals pre_tokenize to get all tokens
+ # This variable signals pre_tokenize to get all tokens.
+ # But note that it is no longer needed with fast block comment
+ # option below.
+ my $max_tokens_wanted = 0;
# optimize for a full-line comment
if ( !$in_quote && substr( $input_line, 0, 1 ) eq '#' ) {
$tokenizer_self->[_in_skipped_] = 1;
return;
}
+
+ # Optional fast processing of a block comment
+ my $ci_string_sum =
+ ( my $str = $ci_string_in_tokenizer ) =~ tr/1/0/;
+ my $ci_string_i = $ci_string_sum + $in_statement_continuation;
+ $line_of_tokens->{_line_type} = 'CODE';
+ $line_of_tokens->{_rtokens} = [$input_line];
+ $line_of_tokens->{_rtoken_type} = ['#'];
+ $line_of_tokens->{_rlevels} = [$level_in_tokenizer];
+ $line_of_tokens->{_rci_levels} = [$ci_string_i];
+ $line_of_tokens->{_rblock_type} = [EMPTY_STRING];
+ $line_of_tokens->{_nesting_tokens_0} = $nesting_token_string;
+ $line_of_tokens->{_nesting_blocks_0} = $nesting_block_string;
+ return;
}
+ tokenizer_main_loop( $max_tokens_wanted, $is_END_or_DATA );
+
+ #-----------------------------------------------
+ # all done tokenizing this line ...
+ # now prepare the final list of tokens and types
+ #-----------------------------------------------
+
+ tokenizer_wrapup_line($line_of_tokens);
+
+ return;
+ } ## end sub tokenize_this_line
+
+ sub tokenizer_main_loop {
+ my ( $max_tokens_wanted, $is_END_or_DATA ) = @_;
+
+ # tokenization is done in two stages..
+ # stage 1 is a very simple pre-tokenization
+
# start by breaking the line into pre-tokens
( $rtokens, $rtoken_map, $rtoken_type ) =
pre_tokenize( $input_line, $max_tokens_wanted );
$max_token_index = scalar( @{$rtokens} ) - 1;
- push( @{$rtokens}, ' ', ' ', ' ' ); # extra whitespace simplifies logic
+ push( @{$rtokens}, SPACE, SPACE, SPACE )
+ ; # extra whitespace simplifies logic
push( @{$rtoken_map}, 0, 0, 0 ); # shouldn't be referenced
push( @{$rtoken_type}, 'b', 'b', 'b' );
# initialize for main loop
+ if (0) { #<<< this is not necessary
foreach my $ii ( 0 .. $max_token_index + 3 ) {
- $routput_token_type->[$ii] = "";
- $routput_block_type->[$ii] = "";
- $routput_container_type->[$ii] = "";
- $routput_type_sequence->[$ii] = "";
+ $routput_token_type->[$ii] = EMPTY_STRING;
+ $routput_block_type->[$ii] = EMPTY_STRING;
+ $routput_container_type->[$ii] = EMPTY_STRING;
+ $routput_type_sequence->[$ii] = EMPTY_STRING;
$routput_indent_flag->[$ii] = 0;
}
+ }
+
$i = -1;
$i_tok = -1;
# into tokens
while ( ++$i <= $max_token_index ) {
- if ($in_quote) { # continue looking for end of a quote
- $type = $quote_type;
-
- unless ( @{$routput_token_list} )
- { # initialize if continuation line
- push( @{$routput_token_list}, $i );
- $routput_token_type->[$i] = $type;
-
- }
-
- # Removed to fix b1280. This is not needed and was causing the
- # starting type 'qw' to be lost, leading to mis-tokenization of
- # a trailing block brace in a parenless for stmt 'for .. qw.. {'
- ##$tok = $quote_character if ($quote_character);
-
- # scan for the end of the quote or pattern
- (
- $i, $in_quote, $quote_character, $quote_pos, $quote_depth,
- $quoted_string_1, $quoted_string_2
- )
- = do_quote(
- $i, $in_quote, $quote_character,
- $quote_pos, $quote_depth, $quoted_string_1,
- $quoted_string_2, $rtokens, $rtoken_map,
- $max_token_index
- );
-
- # all done if we didn't find it
- last if ($in_quote);
-
- # save pattern and replacement text for rescanning
- my $qs1 = $quoted_string_1;
- my $qs2 = $quoted_string_2;
-
- # re-initialize for next search
- $quote_character = '';
- $quote_pos = 0;
- $quote_type = 'Q';
- $quoted_string_1 = "";
- $quoted_string_2 = "";
- last if ( ++$i > $max_token_index );
-
- # look for any modifiers
- if ($allowed_quote_modifiers) {
-
- # check for exact quote modifiers
- if ( $rtokens->[$i] =~ /^[A-Za-z_]/ ) {
- my $str = $rtokens->[$i];
- my $saw_modifier_e;
- while ( $str =~ /\G$allowed_quote_modifiers/gc ) {
- my $pos = pos($str);
- my $char = substr( $str, $pos - 1, 1 );
- $saw_modifier_e ||= ( $char eq 'e' );
- }
-
- # For an 'e' quote modifier we must scan the replacement
- # text for here-doc targets...
- # but if the modifier starts a new line we can skip
- # this because either the here doc will be fully
- # contained in the replacement text (so we can
- # ignore it) or Perl will not find it.
- # See test 'here2.in'.
- if ( $saw_modifier_e && $i_tok >= 0 ) {
-
- my $rht = scan_replacement_text($qs1);
-
- # Change type from 'Q' to 'h' for quotes with
- # here-doc targets so that the formatter (see sub
- # process_line_of_CODE) will not make any line
- # breaks after this point.
- if ($rht) {
- push @{$rhere_target_list}, @{$rht};
- $type = 'h';
- if ( $i_tok < 0 ) {
- my $ilast = $routput_token_list->[-1];
- $routput_token_type->[$ilast] = $type;
- }
- }
- }
-
- if ( defined( pos($str) ) ) {
-
- # matched
- if ( pos($str) == length($str) ) {
- last if ( ++$i > $max_token_index );
- }
-
- # Looks like a joined quote modifier
- # and keyword, maybe something like
- # s/xxx/yyy/gefor @k=...
- # Example is "galgen.pl". Would have to split
- # the word and insert a new token in the
- # pre-token list. This is so rare that I haven't
- # done it. Will just issue a warning citation.
-
- # This error might also be triggered if my quote
- # modifier characters are incomplete
- else {
- warning(<<EOM);
-
-Partial match to quote modifier $allowed_quote_modifiers at word: '$str'
-Please put a space between quote modifiers and trailing keywords.
-EOM
-
- # print "token $rtokens->[$i]\n";
- # my $num = length($str) - pos($str);
- # $rtokens->[$i]=substr($rtokens->[$i],pos($str),$num);
- # print "continuing with new token $rtokens->[$i]\n";
-
- # skipping past this token does least damage
- last if ( ++$i > $max_token_index );
- }
- }
- else {
-
- # example file: rokicki4.pl
- # This error might also be triggered if my quote
- # modifier characters are incomplete
- write_logfile_entry(
-"Note: found word $str at quote modifier location\n"
- );
- }
- }
-
- # re-initialize
- $allowed_quote_modifiers = "";
- }
+ # continue looking for the end of a quote
+ if ($in_quote) {
+ do_FOLLOW_QUOTE();
+ last if ( $in_quote || $i > $max_token_index );
}
- unless ( $type eq 'b' || $tok eq 'CORE::' ) {
+ if ( $type ne 'b' && $tok ne 'CORE::' ) {
# try to catch some common errors
if ( ( $type eq 'n' ) && ( $tok ne '0' ) ) {
|| $last_nonblank_type eq 'i'
&& substr( $last_nonblank_token, 0, 1 ) eq '$' )
{
- $last_nonblank_token = '->' . $last_nonblank_token;
- $last_nonblank_type = 'i';
- }
- }
- }
-
- # store previous token type
- if ( $i_tok >= 0 ) {
- $routput_token_type->[$i_tok] = $type;
- $routput_block_type->[$i_tok] = $block_type;
- $routput_container_type->[$i_tok] = $container_type;
- $routput_type_sequence->[$i_tok] = $type_sequence;
- $routput_indent_flag->[$i_tok] = $indent_flag;
- }
- my $pre_tok = $rtokens->[$i]; # get the next pre-token
- my $pre_type = $rtoken_type->[$i]; # and type
- $tok = $pre_tok;
- $type = $pre_type; # to be modified as necessary
- $block_type = ""; # blank for all tokens except code block braces
- $container_type = ""; # blank for all tokens except some parens
- $type_sequence = ""; # blank for all tokens except ?/:
- $indent_flag = 0;
- $prototype = ""; # blank for all tokens except user defined subs
- $i_tok = $i;
-
- # this pre-token will start an output token
- push( @{$routput_token_list}, $i_tok );
-
- # continue gathering identifier if necessary
- # but do not start on blanks and comments
- if ( $id_scan_state && $pre_type ne 'b' && $pre_type ne '#' ) {
-
- if ( $is_sub{$id_scan_state} || $is_package{$id_scan_state} ) {
- scan_id();
- }
- else {
- scan_identifier();
- }
-
- if ($id_scan_state) {
-
- # Still scanning ...
- # Check for side comment between sub and prototype (c061)
-
- # done if nothing left to scan on this line
- last if ( $i > $max_token_index );
-
- my ( $next_nonblank_token, $i_next ) =
- find_next_nonblank_token_on_this_line( $i, $rtokens,
- $max_token_index );
-
- # done if it was just some trailing space
- last if ( $i_next > $max_token_index );
-
- # something remains on the line ... must be a side comment
- next;
- }
-
- next if ( ( $i > 0 ) || $type );
-
- # didn't find any token; start over
- $type = $pre_type;
- $tok = $pre_tok;
- }
-
- # handle whitespace tokens..
- next if ( $type eq 'b' );
- my $prev_tok = $i > 0 ? $rtokens->[ $i - 1 ] : ' ';
- my $prev_type = $i > 0 ? $rtoken_type->[ $i - 1 ] : 'b';
-
- # Build larger tokens where possible, since we are not in a quote.
- #
- # First try to assemble digraphs. The following tokens are
- # excluded and handled specially:
- # '/=' is excluded because the / might start a pattern.
- # 'x=' is excluded since it might be $x=, with $ on previous line
- # '**' and *= might be typeglobs of punctuation variables
- # I have allowed tokens starting with <, such as <=,
- # because I don't think these could be valid angle operators.
- # test file: storrs4.pl
- my $test_tok = $tok . $rtokens->[ $i + 1 ];
- my $combine_ok = $is_digraph{$test_tok};
-
- # check for special cases which cannot be combined
- if ($combine_ok) {
-
- # '//' must be defined_or operator if an operator is expected.
- # TODO: Code for other ambiguous digraphs (/=, x=, **, *=)
- # could be migrated here for clarity
-
- # Patch for RT#102371, misparsing a // in the following snippet:
- # state $b //= ccc();
- # The solution is to always accept the digraph (or trigraph) after
- # token type 'Z' (possible file handle). The reason is that
- # sub operator_expected gives TERM expected here, which is
- # wrong in this case.
- if ( $test_tok eq '//' && $last_nonblank_type ne 'Z' ) {
- my $next_type = $rtokens->[ $i + 1 ];
- my $expecting =
- operator_expected( [ $prev_type, $tok, $next_type ] );
-
- # Patched for RT#101547, was 'unless ($expecting==OPERATOR)'
- $combine_ok = 0 if ( $expecting == TERM );
- }
-
- # Patch for RT #114359: Missparsing of "print $x ** 0.5;
- # Accept the digraphs '**' only after type 'Z'
- # Otherwise postpone the decision.
- if ( $test_tok eq '**' ) {
- if ( $last_nonblank_type ne 'Z' ) { $combine_ok = 0 }
- }
- }
-
- if (
- $combine_ok
-
- && ( $test_tok ne '/=' ) # might be pattern
- && ( $test_tok ne 'x=' ) # might be $x
- && ( $test_tok ne '*=' ) # typeglob?
-
- # Moved above as part of fix for
- # RT #114359: Missparsing of "print $x ** 0.5;
- # && ( $test_tok ne '**' ) # typeglob?
- )
- {
- $tok = $test_tok;
- $i++;
-
- # Now try to assemble trigraphs. Note that all possible
- # perl trigraphs can be constructed by appending a character
- # to a digraph.
- $test_tok = $tok . $rtokens->[ $i + 1 ];
-
- if ( $is_trigraph{$test_tok} ) {
- $tok = $test_tok;
- $i++;
- }
-
- # The only current tetragraph is the double diamond operator
- # and its first three characters are not a trigraph, so
- # we do can do a special test for it
- elsif ( $test_tok eq '<<>' ) {
- $test_tok .= $rtokens->[ $i + 2 ];
- if ( $is_tetragraph{$test_tok} ) {
- $tok = $test_tok;
- $i += 2;
- }
- }
- }
-
- $type = $tok;
- $next_tok = $rtokens->[ $i + 1 ];
- $next_type = $rtoken_type->[ $i + 1 ];
-
- DEBUG_TOKENIZE && do {
- local $" = ')(';
- my @debug_list = (
- $last_nonblank_token, $tok,
- $next_tok, $brace_depth,
- $brace_type[$brace_depth], $paren_depth,
- $paren_type[$paren_depth]
- );
- print STDOUT "TOKENIZE:(@debug_list)\n";
- };
-
- # Turn off attribute list on first non-blank, non-bareword.
- # Added '#' to fix c038.
- if ( $pre_type ne 'w' && $pre_type ne '#' ) {
- $in_attribute_list = 0;
- }
-
- ###############################################################
- # We have the next token, $tok.
- # Now we have to examine this token and decide what it is
- # and define its $type
- #
- # section 1: bare words
- ###############################################################
-
- if ( $pre_type eq 'w' ) {
- $expecting =
- operator_expected( [ $prev_type, $tok, $next_type ] );
-
- # Patch for c043, part 3: A bareword after '->' expects a TERM
- # FIXME: It would be cleaner to give method calls a new type 'M'
- # and update sub operator_expected to handle this.
- if ( $last_nonblank_type eq '->' ) {
- $expecting = TERM;
- }
-
- my ( $next_nonblank_token, $i_next ) =
- find_next_nonblank_token( $i, $rtokens, $max_token_index );
-
- # ATTRS: handle sub and variable attributes
- if ($in_attribute_list) {
-
- # treat bare word followed by open paren like qw(
- if ( $next_nonblank_token eq '(' ) {
-
- # For something like:
- # : prototype($$)
- # we should let do_scan_sub see it so that it can see
- # the prototype. All other attributes get parsed as a
- # quoted string.
- if ( $tok eq 'prototype' ) {
- $id_scan_state = 'prototype';
-
- # start just after the word 'prototype'
- my $i_beg = $i + 1;
- ( $i, $tok, $type, $id_scan_state ) = do_scan_sub(
- {
- input_line => $input_line,
- i => $i,
- i_beg => $i_beg,
- tok => $tok,
- type => $type,
- rtokens => $rtokens,
- rtoken_map => $rtoken_map,
- id_scan_state => $id_scan_state,
- max_token_index => $max_token_index
- }
- );
-
- # If successful, mark as type 'q' to be consistent with other
- # attributes. Note that type 'w' would also work.
- if ( $i > $i_beg ) {
- $type = 'q';
- next;
- }
-
- # If not successful, continue and parse as a quote.
- }
-
- # All other attribute lists must be parsed as quotes
- # (see 'signatures.t' for good examples)
- $in_quote = $quote_items{'q'};
- $allowed_quote_modifiers = $quote_modifiers{'q'};
- $type = 'q';
- $quote_type = 'q';
- next;
- }
-
- # handle bareword not followed by open paren
- else {
- $type = 'w';
- next;
- }
- }
-
- # quote a word followed by => operator
- # unless the word __END__ or __DATA__ and the only word on
- # the line.
- if ( !$is_END_or_DATA && $next_nonblank_token eq '=' ) {
-
- if ( $rtokens->[ $i_next + 1 ] eq '>' ) {
- if ( $is_constant{$current_package}{$tok} ) {
- $type = 'C';
- }
- elsif ( $is_user_function{$current_package}{$tok} ) {
- $type = 'U';
- $prototype =
- $user_function_prototype{$current_package}{$tok};
- }
- elsif ( $tok =~ /^v\d+$/ ) {
- $type = 'v';
- report_v_string($tok);
- }
- else {
-
- # Bareword followed by a fat comma ... see 'git18.in'
- # If tok is something like 'x17' then it could
- # actually be operator x followed by number 17.
- # For example, here:
- # 123x17 => [ 792, 1224 ],
- # (a key of 123 repeated 17 times, perhaps not
- # what was intended). We will mark x17 as type
- # 'n' and it will be split. If the previous token
- # was also a bareword then it is not very clear is
- # going on. In this case we will not be sure that
- # an operator is expected, so we just mark it as a
- # bareword. Perl is a little murky in what it does
- # with stuff like this, and its behavior can change
- # over time. Something like
- # a x18 => [792, 1224], will compile as
- # a key with 18 a's. But something like
- # push @array, a x18;
- # is a syntax error.
- if (
- $expecting == OPERATOR
- && substr( $tok, 0, 1 ) eq 'x'
- && ( length($tok) == 1
- || substr( $tok, 1, 1 ) =~ /^\d/ )
- )
- {
- $type = 'n';
- if ( split_pretoken(1) ) {
- $type = 'x';
- $tok = 'x';
- }
- }
- else {
-
- # git #18
- $type = 'w';
- error_if_expecting_OPERATOR();
- }
- }
-
- next;
- }
- }
-
- # quote a bare word within braces..like xxx->{s}; note that we
- # must be sure this is not a structural brace, to avoid
- # mistaking {s} in the following for a quoted bare word:
- # for(@[){s}bla}BLA}
- # Also treat q in something like var{-q} as a bare word, not qoute operator
- if (
- $next_nonblank_token eq '}'
- && (
- $last_nonblank_type eq 'L'
- || ( $last_nonblank_type eq 'm'
- && $last_last_nonblank_type eq 'L' )
- )
- )
- {
- $type = 'w';
- next;
- }
-
- # Scan a bare word following a -> as an identifir; it could
- # have a long package name. Fixes c037, c041.
- if ( $last_nonblank_token eq '->' ) {
- scan_bare_identifier();
-
- # Patch for c043, part 4; use type 'w' after a '->'.
- # This is just a safety check on sub scan_bare_identifier,
- # which should get this case correct.
- $type = 'w';
- next;
- }
-
- # a bare word immediately followed by :: is not a keyword;
- # use $tok_kw when testing for keywords to avoid a mistake
- my $tok_kw = $tok;
- if ( $rtokens->[ $i + 1 ] eq ':'
- && $rtokens->[ $i + 2 ] eq ':' )
- {
- $tok_kw .= '::';
- }
-
- # Decide if 'sub :' can be the start of a sub attribute list.
- # We will decide based on if the colon is followed by a
- # bareword which is not a keyword.
- # Changed inext+1 to inext to fixed case b1190.
- my $sub_attribute_ok_here;
- if ( $is_sub{$tok_kw}
- && $expecting != OPERATOR
- && $next_nonblank_token eq ':' )
- {
- my ( $nn_nonblank_token, $i_nn ) =
- find_next_nonblank_token( $i_next,
- $rtokens, $max_token_index );
- $sub_attribute_ok_here =
- $nn_nonblank_token =~ /^\w/
- && $nn_nonblank_token !~ /^\d/
- && !$is_keyword{$nn_nonblank_token};
- }
-
- # handle operator x (now we know it isn't $x=)
- if (
- $expecting == OPERATOR
- && substr( $tok, 0, 1 ) eq 'x'
- && ( length($tok) == 1
- || substr( $tok, 1, 1 ) =~ /^\d/ )
- )
- {
-
- if ( $tok eq 'x' ) {
- if ( $rtokens->[ $i + 1 ] eq '=' ) { # x=
- $tok = 'x=';
- $type = $tok;
- $i++;
- }
- else {
- $type = 'x';
- }
- }
- else {
-
- # Split a pretoken like 'x10' into 'x' and '10'.
- # Note: In previous versions of perltidy it was marked
- # as a number, $type = 'n', and fixed downstream by the
- # Formatter.
- $type = 'n';
- if ( split_pretoken(1) ) {
- $type = 'x';
- $tok = 'x';
- }
+ $last_nonblank_token = '->' . $last_nonblank_token;
+ $last_nonblank_type = 'i';
}
}
- elsif ( $tok_kw eq 'CORE::' ) {
- $type = $tok = $tok_kw;
- $i += 2;
- }
- elsif ( ( $tok eq 'strict' )
- and ( $last_nonblank_token eq 'use' ) )
- {
- $tokenizer_self->[_saw_use_strict_] = 1;
- scan_bare_identifier();
- }
-
- elsif ( ( $tok eq 'warnings' )
- and ( $last_nonblank_token eq 'use' ) )
- {
- $tokenizer_self->[_saw_perl_dash_w_] = 1;
+ }
- # scan as identifier, so that we pick up something like:
- # use warnings::register
- scan_bare_identifier();
- }
+ # store previous token type
+ if ( $i_tok >= 0 ) {
+ $routput_token_type->[$i_tok] = $type;
+ $routput_block_type->[$i_tok] = $block_type;
+ $routput_container_type->[$i_tok] = $container_type;
+ $routput_type_sequence->[$i_tok] = $type_sequence;
+ $routput_indent_flag->[$i_tok] = $indent_flag;
+ }
- elsif (
- $tok eq 'AutoLoader'
- && $tokenizer_self->[_look_for_autoloader_]
- && (
- $last_nonblank_token eq 'use'
-
- # these regexes are from AutoSplit.pm, which we want
- # to mimic
- || $input_line =~ /^\s*(use|require)\s+AutoLoader\b/
- || $input_line =~ /\bISA\s*=.*\bAutoLoader\b/
- )
- )
- {
- write_logfile_entry("AutoLoader seen, -nlal deactivates\n");
- $tokenizer_self->[_saw_autoloader_] = 1;
- $tokenizer_self->[_look_for_autoloader_] = 0;
- scan_bare_identifier();
- }
+ # get the next pre-token and type
+ # $tok and $type will be modified to make the output token
+ my $pre_tok = $tok = $rtokens->[$i]; # get the next pre-token
+ my $pre_type = $type = $rtoken_type->[$i]; # and type
- elsif (
- $tok eq 'SelfLoader'
- && $tokenizer_self->[_look_for_selfloader_]
- && ( $last_nonblank_token eq 'use'
- || $input_line =~ /^\s*(use|require)\s+SelfLoader\b/
- || $input_line =~ /\bISA\s*=.*\bSelfLoader\b/ )
- )
- {
- write_logfile_entry("SelfLoader seen, -nlsl deactivates\n");
- $tokenizer_self->[_saw_selfloader_] = 1;
- $tokenizer_self->[_look_for_selfloader_] = 0;
- scan_bare_identifier();
- }
+ # remember the starting index of this token; we will be updating $i
+ $i_tok = $i;
- elsif ( ( $tok eq 'constant' )
- and ( $last_nonblank_token eq 'use' ) )
- {
- scan_bare_identifier();
- my ( $next_nonblank_token, $i_next ) =
- find_next_nonblank_token( $i, $rtokens,
- $max_token_index );
+ # re-initialize various flags for the next output token
+ $block_type &&= EMPTY_STRING;
+ $container_type &&= EMPTY_STRING;
+ $type_sequence &&= EMPTY_STRING;
+ $indent_flag &&= 0;
+ $prototype &&= EMPTY_STRING;
- if ($next_nonblank_token) {
+ # this pre-token will start an output token
+ push( @{$routput_token_list}, $i_tok );
- if ( $is_keyword{$next_nonblank_token} ) {
+ #--------------------------
+ # handle a whitespace token
+ #--------------------------
+ next if ( $pre_type eq 'b' );
- # Assume qw is used as a quote and okay, as in:
- # use constant qw{ DEBUG 0 };
- # Not worth trying to parse for just a warning
+ #-----------------
+ # handle a comment
+ #-----------------
+ last if ( $pre_type eq '#' );
- # NOTE: This warning is deactivated because recent
- # versions of perl do not complain here, but
- # the coding is retained for reference.
- if ( 0 && $next_nonblank_token ne 'qw' ) {
- warning(
-"Attempting to define constant '$next_nonblank_token' which is a perl keyword\n"
- );
- }
- }
+ # continue gathering identifier if necessary
+ if ($id_scan_state) {
- else {
- $is_constant{$current_package}{$next_nonblank_token}
- = 1;
- }
- }
+ if ( $is_sub{$id_scan_state} || $is_package{$id_scan_state} ) {
+ scan_id();
}
-
- # various quote operators
- elsif ( $is_q_qq_qw_qx_qr_s_y_tr_m{$tok} ) {
-##NICOL PATCH
- if ( $expecting == OPERATOR ) {
-
- # Be careful not to call an error for a qw quote
- # where a parenthesized list is allowed. For example,
- # it could also be a for/foreach construct such as
- #
- # foreach my $key qw\Uno Due Tres Quadro\ {
- # print "Set $key\n";
- # }
- #
-
- # Or it could be a function call.
- # NOTE: Braces in something like &{ xxx } are not
- # marked as a block, we might have a method call.
- # &method(...), $method->(..), &{method}(...),
- # $ref[2](list) is ok & short for $ref[2]->(list)
- #
- # See notes in 'sub code_block_type' and
- # 'sub is_non_structural_brace'
-
- unless (
- $tok eq 'qw'
- && ( $last_nonblank_token =~ /^([\]\}\&]|\-\>)/
- || $is_for_foreach{$want_paren} )
- )
- {
- error_if_expecting_OPERATOR();
- }
- }
- $in_quote = $quote_items{$tok};
- $allowed_quote_modifiers = $quote_modifiers{$tok};
-
- # All quote types are 'Q' except possibly qw quotes.
- # qw quotes are special in that they may generally be trimmed
- # of leading and trailing whitespace. So they are given a
- # separate type, 'q', unless requested otherwise.
- $type =
- ( $tok eq 'qw' && $tokenizer_self->[_trim_qw_] )
- ? 'q'
- : 'Q';
- $quote_type = $type;
+ else {
+ scan_identifier();
}
- # check for a statement label
- elsif (
- ( $next_nonblank_token eq ':' )
- && ( $rtokens->[ $i_next + 1 ] ne ':' )
- && ( $i_next <= $max_token_index ) # colon on same line
- && !$sub_attribute_ok_here # like 'sub : lvalue' ?
- && label_ok()
- )
- {
- if ( $tok !~ /[A-Z]/ ) {
- push @{ $tokenizer_self->[_rlower_case_labels_at_] },
- $input_line_number;
- }
- $type = 'J';
- $tok .= ':';
- $i = $i_next;
- next;
- }
+ if ($id_scan_state) {
- # 'sub' or alias
- elsif ( $is_sub{$tok_kw} ) {
- error_if_expecting_OPERATOR()
- if ( $expecting == OPERATOR );
- initialize_subname();
- scan_id();
- }
+ # Still scanning ...
+ # Check for side comment between sub and prototype (c061)
- # 'package'
- elsif ( $is_package{$tok_kw} ) {
- error_if_expecting_OPERATOR()
- if ( $expecting == OPERATOR );
- scan_id();
- }
+ # done if nothing left to scan on this line
+ last if ( $i > $max_token_index );
- # Fix for c035: split 'format' from 'is_format_END_DATA' to be
- # more restrictive. Require a new statement to be ok here.
- elsif ( $tok_kw eq 'format' && new_statement_ok() ) {
- $type = ';'; # make tokenizer look for TERM next
- $tokenizer_self->[_in_format_] = 1;
- last;
- }
+ my ( $next_nonblank_token, $i_next ) =
+ find_next_nonblank_token_on_this_line( $i, $rtokens,
+ $max_token_index );
- # Note on token types for format, __DATA__, __END__:
- # It simplifies things to give these type ';', so that when we
- # start rescanning we will be expecting a token of type TERM.
- # We will switch to type 'k' before outputting the tokens.
- elsif ( $is_END_DATA{$tok_kw} ) {
- $type = ';'; # make tokenizer look for TERM next
+ # done if it was just some trailing space
+ last if ( $i_next > $max_token_index );
- # Remember that we are in one of these three sections
- $tokenizer_self->[ $is_END_DATA{$tok_kw} ] = 1;
- last;
+ # something remains on the line ... must be a side comment
+ next;
}
- elsif ( $is_keyword{$tok_kw} ) {
- $type = 'k';
+ next if ( ( $i > 0 ) || $type );
- # Since for and foreach may not be followed immediately
- # by an opening paren, we have to remember which keyword
- # is associated with the next '('
- if ( $is_for_foreach{$tok} ) {
- if ( new_statement_ok() ) {
- $want_paren = $tok;
- }
- }
+ # didn't find any token; start over
+ $type = $pre_type;
+ $tok = $pre_tok;
+ }
- # recognize 'use' statements, which are special
- elsif ( $is_use_require{$tok} ) {
- $statement_type = $tok;
- error_if_expecting_OPERATOR()
- if ( $expecting == OPERATOR );
- }
+ my $prev_tok = $i > 0 ? $rtokens->[ $i - 1 ] : SPACE;
+ my $prev_type = $i > 0 ? $rtoken_type->[ $i - 1 ] : 'b';
- # remember my and our to check for trailing ": shared"
- elsif ( $is_my_our_state{$tok} ) {
- $statement_type = $tok;
- }
+ #-----------------------------------------------------------
+ # Combine pre-tokens into digraphs and trigraphs if possible
+ #-----------------------------------------------------------
- # Check for misplaced 'elsif' and 'else', but allow isolated
- # else or elsif blocks to be formatted. This is indicated
- # by a last noblank token of ';'
- elsif ( $tok eq 'elsif' ) {
- if ( $last_nonblank_token ne ';'
- && $last_nonblank_block_type !~
- /^(if|elsif|unless)$/ )
- {
- warning(
-"expecting '$tok' to follow one of 'if|elsif|unless'\n"
- );
- }
- }
- elsif ( $tok eq 'else' ) {
-
- # patched for SWITCH/CASE
- if (
- $last_nonblank_token ne ';'
- && $last_nonblank_block_type !~
- /^(if|elsif|unless|case|when)$/
-
- # patch to avoid an unwanted error message for
- # the case of a parenless 'case' (RT 105484):
- # switch ( 1 ) { case x { 2 } else { } }
- && $statement_type !~
- /^(if|elsif|unless|case|when)$/
- )
- {
- warning(
-"expecting '$tok' to follow one of 'if|elsif|unless|case|when'\n"
- );
- }
- }
- elsif ( $tok eq 'continue' ) {
- if ( $last_nonblank_token ne ';'
- && $last_nonblank_block_type !~
- /(^(\{|\}|;|while|until|for|foreach)|:$)/ )
- {
-
- # note: ';' '{' and '}' in list above
- # because continues can follow bare blocks;
- # ':' is labeled block
- #
- ############################################
- # NOTE: This check has been deactivated because
- # continue has an alternative usage for given/when
- # blocks in perl 5.10
- ## warning("'$tok' should follow a block\n");
- ############################################
- }
- }
+ # See if we can make a digraph...
+ # The following tokens are excluded and handled specially:
+ # '/=' is excluded because the / might start a pattern.
+ # 'x=' is excluded since it might be $x=, with $ on previous line
+ # '**' and *= might be typeglobs of punctuation variables
+ # I have allowed tokens starting with <, such as <=,
+ # because I don't think these could be valid angle operators.
+ # test file: storrs4.pl
+ if ( $can_start_digraph{$tok}
+ && $i < $max_token_index
+ && $is_digraph{ $tok . $rtokens->[ $i + 1 ] } )
+ {
- # patch for SWITCH/CASE if 'case' and 'when are
- # treated as keywords. Also 'default' for Switch::Plain
- elsif ($tok eq 'when'
- || $tok eq 'case'
- || $tok eq 'default' )
- {
- $statement_type = $tok; # next '{' is block
- }
+ my $combine_ok = 1;
+ my $test_tok = $tok . $rtokens->[ $i + 1 ];
- #
- # indent trailing if/unless/while/until
- # outdenting will be handled by later indentation loop
-## DEACTIVATED: unfortunately this can cause some unwanted indentation like:
-##$opt_o = 1
-## if !(
-## $opt_b
-## || $opt_c
-## || $opt_d
-## || $opt_f
-## || $opt_i
-## || $opt_l
-## || $opt_o
-## || $opt_x
-## );
-## if ( $tok =~ /^(if|unless|while|until)$/
-## && $next_nonblank_token ne '(' )
-## {
-## $indent_flag = 1;
-## }
- }
+ # check for special cases which cannot be combined
- # check for inline label following
- # /^(redo|last|next|goto)$/
- elsif (( $last_nonblank_type eq 'k' )
- && ( $is_redo_last_next_goto{$last_nonblank_token} ) )
- {
- $type = 'j';
- next;
- }
+ # '//' must be defined_or operator if an operator is expected.
+ # TODO: Code for other ambiguous digraphs (/=, x=, **, *=)
+ # could be migrated here for clarity
- # something else --
- else {
+ # Patch for RT#102371, misparsing a // in the following snippet:
+ # state $b //= ccc();
+ # The solution is to always accept the digraph (or trigraph)
+ # after type 'Z' (possible file handle). The reason is that
+ # sub operator_expected gives TERM expected here, which is
+ # wrong in this case.
+ if ( $test_tok eq '//' && $last_nonblank_type ne 'Z' ) {
- scan_bare_identifier();
+ # note that here $tok = '/' and the next tok and type is '/'
+ $expecting = operator_expected( [ $prev_type, $tok, '/' ] );
- if ( $statement_type eq 'use'
- && $last_nonblank_token eq 'use' )
- {
- $saw_use_module{$current_package}->{$tok} = 1;
- }
+ # Patched for RT#101547, was 'unless ($expecting==OPERATOR)'
+ $combine_ok = 0 if ( $expecting == TERM );
+ }
+
+ # Patch for RT #114359: Missparsing of "print $x ** 0.5;
+ # Accept the digraphs '**' only after type 'Z'
+ # Otherwise postpone the decision.
+ if ( $test_tok eq '**' ) {
+ if ( $last_nonblank_type ne 'Z' ) { $combine_ok = 0 }
+ }
- if ( $type eq 'w' ) {
+ if (
- if ( $expecting == OPERATOR ) {
+ # still ok to combine?
+ $combine_ok
- # Patch to avoid error message for RPerl overloaded
- # operator functions: use overload
- # '+' => \&sse_add,
- # '-' => \&sse_sub,
- # '*' => \&sse_mul,
- # '/' => \&sse_div;
- # FIXME: this should eventually be generalized
- if ( $saw_use_module{$current_package}->{'RPerl'}
- && $tok =~ /^sse_(mul|div|add|sub)$/ )
- {
+ && ( $test_tok ne '/=' ) # might be pattern
+ && ( $test_tok ne 'x=' ) # might be $x
+ && ( $test_tok ne '*=' ) # typeglob?
- }
+ # Moved above as part of fix for
+ # RT #114359: Missparsing of "print $x ** 0.5;
+ # && ( $test_tok ne '**' ) # typeglob?
+ )
+ {
+ $tok = $test_tok;
+ $i++;
- # Fix part 1 for git #63 in which a comment falls
- # between an -> and the following word. An
- # alternate fix would be to change operator_expected
- # to return an UNKNOWN for this type.
- elsif ( $last_nonblank_type eq '->' ) {
+ # Now try to assemble trigraphs. Note that all possible
+ # perl trigraphs can be constructed by appending a character
+ # to a digraph.
+ $test_tok = $tok . $rtokens->[ $i + 1 ];
- }
+ if ( $is_trigraph{$test_tok} ) {
+ $tok = $test_tok;
+ $i++;
+ }
- # don't complain about possible indirect object
- # notation.
- # For example:
- # package main;
- # sub new($) { ... }
- # $b = new A::; # calls A::new
- # $c = new A; # same thing but suspicious
- # This will call A::new but we have a 'new' in
- # main:: which looks like a constant.
- #
- elsif ( $last_nonblank_type eq 'C' ) {
- if ( $tok !~ /::$/ ) {
- complain(<<EOM);
-Expecting operator after '$last_nonblank_token' but found bare word '$tok'
- Maybe indirectet object notation?
-EOM
- }
- }
- else {
- error_if_expecting_OPERATOR("bareword");
- }
+ # The only current tetragraph is the double diamond operator
+ # and its first three characters are not a trigraph, so
+ # we do can do a special test for it
+ elsif ( $test_tok eq '<<>' ) {
+ $test_tok .= $rtokens->[ $i + 2 ];
+ if ( $is_tetragraph{$test_tok} ) {
+ $tok = $test_tok;
+ $i += 2;
}
+ }
+ }
+ }
- # mark bare words immediately followed by a paren as
- # functions
- $next_tok = $rtokens->[ $i + 1 ];
- if ( $next_tok eq '(' ) {
+ $type = $tok;
+ $next_tok = $rtokens->[ $i + 1 ];
+ $next_type = $rtoken_type->[ $i + 1 ];
- # Fix part 2 for git #63. Leave type as 'w' to keep
- # the type the same as if the -> were not separated
- $type = 'U' unless ( $last_nonblank_type eq '->' );
- }
+ DEBUG_TOKENIZE && do {
+ local $LIST_SEPARATOR = ')(';
+ my @debug_list = (
+ $last_nonblank_token, $tok,
+ $next_tok, $brace_depth,
+ $brace_type[$brace_depth], $paren_depth,
+ $paren_type[$paren_depth],
+ );
+ print STDOUT "TOKENIZE:(@debug_list)\n";
+ };
- # underscore after file test operator is file handle
- if ( $tok eq '_' && $last_nonblank_type eq 'F' ) {
- $type = 'Z';
- }
+ # Turn off attribute list on first non-blank, non-bareword.
+ # Added '#' to fix c038 (later moved above).
+ if ( $in_attribute_list && $pre_type ne 'w' ) {
+ $in_attribute_list = 0;
+ }
- # patch for SWITCH/CASE if 'case' and 'when are
- # not treated as keywords:
- if (
- (
- $tok eq 'case'
- && $brace_type[$brace_depth] eq 'switch'
- )
- || ( $tok eq 'when'
- && $brace_type[$brace_depth] eq 'given' )
- )
- {
- $statement_type = $tok; # next '{' is block
- $type = 'k'; # for keyword syntax coloring
- }
+ ###############################################################
+ # We have the next token, $tok.
+ # Now we have to examine this token and decide what it is
+ # and define its $type
+ #
+ # section 1: bare words
+ ###############################################################
- # patch for SWITCH/CASE if switch and given not keywords
- # Switch is not a perl 5 keyword, but we will gamble
- # and mark switch followed by paren as a keyword. This
- # is only necessary to get html syntax coloring nice,
- # and does not commit this as being a switch/case.
- if ( $next_nonblank_token eq '('
- && ( $tok eq 'switch' || $tok eq 'given' ) )
- {
- $type = 'k'; # for keyword syntax coloring
- }
- }
- }
+ if ( $pre_type eq 'w' ) {
+ $expecting =
+ operator_expected( [ $prev_type, $tok, $next_type ] );
+ my $is_last = do_BAREWORD($is_END_or_DATA);
+ last if ($is_last);
}
###############################################################
elsif ( $pre_type eq 'd' ) {
$expecting =
operator_expected( [ $prev_type, $tok, $next_type ] );
- error_if_expecting_OPERATOR("Number")
- if ( $expecting == OPERATOR );
-
- my $number = scan_number_fast();
- if ( !defined($number) ) {
-
- # shouldn't happen - we should always get a number
- if (DEVEL_MODE) {
- Fault(<<EOM);
-non-number beginning with digit--program bug
-EOM
- }
- warning(
-"Unexpected error condition: non-number beginning with digit\n"
- );
- report_definite_bug();
- }
+ do_DIGITS();
}
###############################################################
# section 3: all other tokens
###############################################################
-
else {
- last if ( $tok eq '#' );
my $code = $tokenization_code->{$tok};
if ($code) {
$expecting =
# end of main tokenization loop
# -----------------------------
+ # Store the final token
if ( $i_tok >= 0 ) {
$routput_token_type->[$i_tok] = $type;
$routput_block_type->[$i_tok] = $block_type;
$routput_indent_flag->[$i_tok] = $indent_flag;
}
+ # Remember last nonblank values
unless ( ( $type eq 'b' ) || ( $type eq '#' ) ) {
$last_last_nonblank_token = $last_nonblank_token;
$last_last_nonblank_type = $last_nonblank_type;
}
}
- # all done tokenizing this line ...
- # now prepare the final list of tokens and types
+ $tokenizer_self->[_in_attribute_list_] = $in_attribute_list;
+ $tokenizer_self->[_in_quote_] = $in_quote;
+ $tokenizer_self->[_quote_target_] =
+ $in_quote ? matching_end_token($quote_character) : EMPTY_STRING;
+ $tokenizer_self->[_rhere_target_list_] = $rhere_target_list;
- my @token_type = (); # stack of output token types
- my @block_type = (); # stack of output code block types
- my @container_type = (); # stack of output code container types
- my @type_sequence = (); # stack of output type sequence numbers
- my @tokens = (); # output tokens
- my @levels = (); # structural brace levels of output tokens
- my @slevels = (); # secondary nesting levels of output tokens
- my @nesting_tokens = (); # string of tokens leading to this depth
- my @nesting_types = (); # string of token types leading to this depth
- my @nesting_blocks = (); # string of block types leading to this depth
- my @nesting_lists = (); # string of list types leading to this depth
+ return;
+ } ## end sub tokenizer_main_loop
+
+ sub tokenizer_wrapup_line {
+ my ($line_of_tokens) = @_;
+
+ # We have broken the current line into tokens. Now we have to wrap up
+ # the result for shipping. Most of the remaining work involves
+ # defining the various indentation parameters that the formatter needs
+ # (indentation level and continuation indentation). This turns out to
+ # be somewhat complicated.
+
+ my @token_type = (); # stack of output token types
+ my @block_type = (); # stack of output code block types
+ my @type_sequence = (); # stack of output type sequence numbers
+ my @tokens = (); # output tokens
+ my @levels = (); # structural brace levels of output tokens
my @ci_string = (); # string needed to compute continuation indentation
- my @container_environment = (); # BLOCK or LIST
- my $container_environment = '';
- my $im = -1; # previous $i value
+ my $container_environment = EMPTY_STRING;
+ my $im = -1; # previous $i value
my $num;
# Count the number of '1's in the string (previously sub ones_count)
# and '(' -- , regardless of context, is used to compute a nesting
# depth.
- #my $nesting_block_flag = ($nesting_block_string =~ /1$/);
- #my $nesting_list_flag = ($nesting_list_string =~ /1$/);
+ $line_of_tokens->{_nesting_tokens_0} = $nesting_token_string;
- my ( $ci_string_i, $level_i, $nesting_block_string_i,
- $nesting_list_string_i, $nesting_token_string_i,
- $nesting_type_string_i, );
+ my ( $ci_string_i, $level_i );
- foreach my $i ( @{$routput_token_list} )
- { # scan the list of pre-tokens indexes
+ # loop over the list of pre-tokens indexes
+ foreach my $i ( @{$routput_token_list} ) {
- # self-checking for valid token types
- my $type = $routput_token_type->[$i];
- my $forced_indentation_flag = $routput_indent_flag->[$i];
+ # Get $tok_i, the PRE-token. It only equals the token for symbols
+ my $type_i = $routput_token_type->[$i];
+ my $tok_i = $rtokens->[$i];
- # See if we should undo the $forced_indentation_flag.
- # Forced indentation after 'if', 'unless', 'while' and 'until'
- # expressions without trailing parens is optional and doesn't
- # always look good. It is usually okay for a trailing logical
- # expression, but if the expression is a function call, code block,
- # or some kind of list it puts in an unwanted extra indentation
- # level which is hard to remove.
- #
- # Example where extra indentation looks ok:
- # return 1
- # if $det_a < 0 and $det_b > 0
- # or $det_a > 0 and $det_b < 0;
- #
- # Example where extra indentation is not needed because
- # the eval brace also provides indentation:
- # print "not " if defined eval {
- # reduce { die if $b > 2; $a + $b } 0, 1, 2, 3, 4;
- # };
- #
- # The following rule works fairly well:
- # Undo the flag if the end of this line, or start of the next
- # line, is an opening container token or a comma.
- # This almost always works, but if not after another pass it will
- # be stable.
- if ( $forced_indentation_flag && $type eq 'k' ) {
- my $ixlast = -1;
- my $ilast = $routput_token_list->[$ixlast];
- my $toklast = $routput_token_type->[$ilast];
- if ( $toklast eq '#' ) {
- $ixlast--;
- $ilast = $routput_token_list->[$ixlast];
- $toklast = $routput_token_type->[$ilast];
- }
- if ( $toklast eq 'b' ) {
- $ixlast--;
- $ilast = $routput_token_list->[$ixlast];
- $toklast = $routput_token_type->[$ilast];
- }
- if ( $toklast =~ /^[\{,]$/ ) {
- $forced_indentation_flag = 0;
- }
- else {
- ( $toklast, my $i_next ) =
- find_next_nonblank_token( $max_token_index, $rtokens,
- $max_token_index );
- if ( $toklast =~ /^[\{,]$/ ) {
- $forced_indentation_flag = 0;
- }
- }
+ # Quick handling of indentation levels for blanks and comments
+ if ( $type_i eq 'b' || $type_i eq '#' ) {
+ $ci_string_i = $ci_string_sum + $in_statement_continuation;
+ $level_i = $level_in_tokenizer;
}
- # if we are already in an indented if, see if we should outdent
- if ($indented_if_level) {
-
- # don't try to nest trailing if's - shouldn't happen
- if ( $type eq 'k' ) {
- $forced_indentation_flag = 0;
- }
+ # All other types
+ else {
- # check for the normal case - outdenting at next ';'
- elsif ( $type eq ';' ) {
- if ( $level_in_tokenizer == $indented_if_level ) {
- $forced_indentation_flag = -1;
- $indented_if_level = 0;
+ # Check for an invalid token type..
+ # This can happen by running perltidy on non-scripts although
+ # it could also be bug introduced by programming change. Perl
+ # silently accepts a 032 (^Z) and takes it as the end
+ if ( !$is_valid_token_type{$type_i} ) {
+ my $val = ord($type_i);
+ warning(
+"unexpected character decimal $val ($type_i) in script\n"
+ );
+ $tokenizer_self->[_in_error_] = 1;
+ }
+
+ # See if we should undo the $forced_indentation_flag.
+ # Forced indentation after 'if', 'unless', 'while' and 'until'
+ # expressions without trailing parens is optional and doesn't
+ # always look good. It is usually okay for a trailing logical
+ # expression, but if the expression is a function call, code block,
+ # or some kind of list it puts in an unwanted extra indentation
+ # level which is hard to remove.
+ #
+ # Example where extra indentation looks ok:
+ # return 1
+ # if $det_a < 0 and $det_b > 0
+ # or $det_a > 0 and $det_b < 0;
+ #
+ # Example where extra indentation is not needed because
+ # the eval brace also provides indentation:
+ # print "not " if defined eval {
+ # reduce { die if $b > 2; $a + $b } 0, 1, 2, 3, 4;
+ # };
+ #
+ # The following rule works fairly well:
+ # Undo the flag if the end of this line, or start of the next
+ # line, is an opening container token or a comma.
+ # This almost always works, but if not after another pass it will
+ # be stable.
+ my $forced_indentation_flag = $routput_indent_flag->[$i];
+ if ( $forced_indentation_flag && $type_i eq 'k' ) {
+ my $ixlast = -1;
+ my $ilast = $routput_token_list->[$ixlast];
+ my $toklast = $routput_token_type->[$ilast];
+ if ( $toklast eq '#' ) {
+ $ixlast--;
+ $ilast = $routput_token_list->[$ixlast];
+ $toklast = $routput_token_type->[$ilast];
}
- }
-
- # handle case of missing semicolon
- elsif ( $type eq '}' ) {
- if ( $level_in_tokenizer == $indented_if_level ) {
- $indented_if_level = 0;
-
- # TBD: This could be a subroutine call
- $level_in_tokenizer--;
- if ( @{$rslevel_stack} > 1 ) {
- pop( @{$rslevel_stack} );
- }
- if ( length($nesting_block_string) > 1 )
- { # true for valid script
- chop $nesting_block_string;
- chop $nesting_list_string;
+ if ( $toklast eq 'b' ) {
+ $ixlast--;
+ $ilast = $routput_token_list->[$ixlast];
+ $toklast = $routput_token_type->[$ilast];
+ }
+ if ( $toklast =~ /^[\{,]$/ ) {
+ $forced_indentation_flag = 0;
+ }
+ else {
+ ( $toklast, my $i_next ) =
+ find_next_nonblank_token( $max_token_index, $rtokens,
+ $max_token_index );
+ if ( $toklast =~ /^[\{,]$/ ) {
+ $forced_indentation_flag = 0;
}
-
}
- }
- }
-
- my $tok = $rtokens->[$i]; # the token, but ONLY if same as pretoken
- $level_i = $level_in_tokenizer;
-
- # This can happen by running perltidy on non-scripts
- # although it could also be bug introduced by programming change.
- # Perl silently accepts a 032 (^Z) and takes it as the end
- if ( !$is_valid_token_type{$type} ) {
- my $val = ord($type);
- warning(
- "unexpected character decimal $val ($type) in script\n");
- $tokenizer_self->[_in_error_] = 1;
- }
+ } ## end if ( $forced_indentation_flag...)
- # ----------------------------------------------------------------
- # TOKEN TYPE PATCHES
- # output __END__, __DATA__, and format as type 'k' instead of ';'
- # to make html colors correct, etc.
- my $fix_type = $type;
- if ( $type eq ';' && $tok =~ /\w/ ) { $fix_type = 'k' }
+ # if we are already in an indented if, see if we should outdent
+ if ($indented_if_level) {
- # output anonymous 'sub' as keyword
- if ( $type eq 't' && $is_sub{$tok} ) { $fix_type = 'k' }
+ # don't try to nest trailing if's - shouldn't happen
+ if ( $type_i eq 'k' ) {
+ $forced_indentation_flag = 0;
+ }
- # -----------------------------------------------------------------
+ # check for the normal case - outdenting at next ';'
+ elsif ( $type_i eq ';' ) {
+ if ( $level_in_tokenizer == $indented_if_level ) {
+ $forced_indentation_flag = -1;
+ $indented_if_level = 0;
+ }
+ }
- $nesting_token_string_i = $nesting_token_string;
- $nesting_type_string_i = $nesting_type_string;
- $nesting_block_string_i = $nesting_block_string;
- $nesting_list_string_i = $nesting_list_string;
+ # handle case of missing semicolon
+ elsif ( $type_i eq '}' ) {
+ if ( $level_in_tokenizer == $indented_if_level ) {
+ $indented_if_level = 0;
- # set primary indentation levels based on structural braces
- # Note: these are set so that the leading braces have a HIGHER
- # level than their CONTENTS, which is convenient for indentation
- # Also, define continuation indentation for each token.
- if ( $type eq '{' || $type eq 'L' || $forced_indentation_flag > 0 )
- {
+ $level_in_tokenizer--;
+ if ( @{$rslevel_stack} > 1 ) {
+ pop( @{$rslevel_stack} );
+ }
+ if ( length($nesting_block_string) > 1 )
+ { # true for valid script
+ chop $nesting_block_string;
+ chop $nesting_list_string;
+ }
+ }
+ }
+ } ## end if ($indented_if_level)
+
+ # Now we have the first approximation to the level
+ $level_i = $level_in_tokenizer;
+
+ # set primary indentation levels based on structural braces
+ # Note: these are set so that the leading braces have a HIGHER
+ # level than their CONTENTS, which is convenient for indentation
+ # Also, define continuation indentation for each token.
+ if ( $type_i eq '{'
+ || $type_i eq 'L'
+ || $forced_indentation_flag > 0 )
+ {
- # use environment before updating
- $container_environment =
- $nesting_block_flag ? 'BLOCK'
- : $nesting_list_flag ? 'LIST'
- : "";
-
- # if the difference between total nesting levels is not 1,
- # there are intervening non-structural nesting types between
- # this '{' and the previous unclosed '{'
- my $intervening_secondary_structure = 0;
- if ( @{$rslevel_stack} ) {
- $intervening_secondary_structure =
- $slevel_in_tokenizer - $rslevel_stack->[-1];
- }
+ # use environment before updating
+ $container_environment =
+ $nesting_block_flag ? 'BLOCK'
+ : $nesting_list_flag ? 'LIST'
+ : EMPTY_STRING;
+
+ # if the difference between total nesting levels is not 1,
+ # there are intervening non-structural nesting types between
+ # this '{' and the previous unclosed '{'
+ my $intervening_secondary_structure = 0;
+ if ( @{$rslevel_stack} ) {
+ $intervening_secondary_structure =
+ $slevel_in_tokenizer - $rslevel_stack->[-1];
+ }
# Continuation Indentation
#
# "$ci_string_in_tokenizer" is a stack of previous values of this
# variable.
- # save the current states
- push( @{$rslevel_stack}, 1 + $slevel_in_tokenizer );
- $level_in_tokenizer++;
+ # save the current states
+ push( @{$rslevel_stack}, 1 + $slevel_in_tokenizer );
+ $level_in_tokenizer++;
- if ( $level_in_tokenizer > $tokenizer_self->[_maximum_level_] )
- {
- $tokenizer_self->[_maximum_level_] = $level_in_tokenizer;
- }
+ if ( $level_in_tokenizer >
+ $tokenizer_self->[_maximum_level_] )
+ {
+ $tokenizer_self->[_maximum_level_] =
+ $level_in_tokenizer;
+ }
- if ($forced_indentation_flag) {
+ if ($forced_indentation_flag) {
- # break BEFORE '?' when there is forced indentation
- if ( $type eq '?' ) { $level_i = $level_in_tokenizer; }
- if ( $type eq 'k' ) {
- $indented_if_level = $level_in_tokenizer;
- }
+ # break BEFORE '?' when there is forced indentation
+ if ( $type_i eq '?' ) {
+ $level_i = $level_in_tokenizer;
+ }
+ if ( $type_i eq 'k' ) {
+ $indented_if_level = $level_in_tokenizer;
+ }
- # do not change container environment here if we are not
- # at a real list. Adding this check prevents "blinkers"
- # often near 'unless" clauses, such as in the following
- # code:
+ # do not change container environment here if we are not
+ # at a real list. Adding this check prevents "blinkers"
+ # often near 'unless" clauses, such as in the following
+ # code:
## next
## unless -e (
## $archive =
## File::Spec->catdir( $_, "auto", $root, "$sub$lib_ext" )
## );
- $nesting_block_string .= "$nesting_block_flag";
- }
- else {
-
- if ( $routput_block_type->[$i] ) {
- $nesting_block_flag = 1;
- $nesting_block_string .= '1';
- }
+ $nesting_block_string .= "$nesting_block_flag";
+ } ## end if ($forced_indentation_flag)
else {
- $nesting_block_flag = 0;
- $nesting_block_string .= '0';
+
+ if ( $routput_block_type->[$i] ) {
+ $nesting_block_flag = 1;
+ $nesting_block_string .= '1';
+ }
+ else {
+ $nesting_block_flag = 0;
+ $nesting_block_string .= '0';
+ }
}
- }
- # we will use continuation indentation within containers
- # which are not blocks and not logical expressions
- my $bit = 0;
- if ( !$routput_block_type->[$i] ) {
+ # we will use continuation indentation within containers
+ # which are not blocks and not logical expressions
+ my $bit = 0;
+ if ( !$routput_block_type->[$i] ) {
- # propagate flag down at nested open parens
- if ( $routput_container_type->[$i] eq '(' ) {
- $bit = 1 if $nesting_list_flag;
- }
+ # propagate flag down at nested open parens
+ if ( $routput_container_type->[$i] eq '(' ) {
+ $bit = 1 if $nesting_list_flag;
+ }
# use list continuation if not a logical grouping
# /^(if|elsif|unless|while|and|or|not|&&|!|\|\||for|foreach)$/
- else {
- $bit = 1
- unless
- $is_logical_container{ $routput_container_type->[$i]
- };
+ else {
+ $bit = 1
+ unless
+ $is_logical_container{ $routput_container_type
+ ->[$i] };
+ }
}
- }
- $nesting_list_string .= $bit;
- $nesting_list_flag = $bit;
+ $nesting_list_string .= $bit;
+ $nesting_list_flag = $bit;
- $ci_string_in_tokenizer .=
- ( $intervening_secondary_structure != 0 ) ? '1' : '0';
- $ci_string_sum =
- ( my $str = $ci_string_in_tokenizer ) =~ tr/1/0/;
- $continuation_string_in_tokenizer .=
- ( $in_statement_continuation > 0 ) ? '1' : '0';
+ $ci_string_in_tokenizer .=
+ ( $intervening_secondary_structure != 0 ) ? '1' : '0';
+ $ci_string_sum =
+ ( my $str = $ci_string_in_tokenizer ) =~ tr/1/0/;
+ $continuation_string_in_tokenizer .=
+ ( $in_statement_continuation > 0 ) ? '1' : '0';
# Sometimes we want to give an opening brace continuation indentation,
# and sometimes not. For code blocks, we don't do it, so that the leading
#
# This looks best when 'ci' is one-half of the indentation (i.e., 2 and 4)
- my $total_ci = $ci_string_sum;
- if (
- !$routput_block_type->[$i] # patch: skip for BLOCK
- && ($in_statement_continuation)
- && !( $forced_indentation_flag && $type eq ':' )
- )
- {
- $total_ci += $in_statement_continuation
- unless ( substr( $ci_string_in_tokenizer, -1 ) eq '1' );
- }
-
- $ci_string_i = $total_ci;
- $in_statement_continuation = 0;
- }
-
- elsif ($type eq '}'
- || $type eq 'R'
- || $forced_indentation_flag < 0 )
- {
-
- # only a nesting error in the script would prevent popping here
- if ( @{$rslevel_stack} > 1 ) { pop( @{$rslevel_stack} ); }
+ my $total_ci = $ci_string_sum;
+ if (
+ !$routput_block_type->[$i] # patch: skip for BLOCK
+ && ($in_statement_continuation)
+ && !( $forced_indentation_flag && $type_i eq ':' )
+ )
+ {
+ $total_ci += $in_statement_continuation
+ unless (
+ substr( $ci_string_in_tokenizer, -1 ) eq '1' );
+ }
- $level_i = --$level_in_tokenizer;
+ $ci_string_i = $total_ci;
+ $in_statement_continuation = 0;
+ } ## end if ( $type_i eq '{' ||...})
- # restore previous level values
- if ( length($nesting_block_string) > 1 )
- { # true for valid script
- chop $nesting_block_string;
- $nesting_block_flag =
- substr( $nesting_block_string, -1 ) eq '1';
- chop $nesting_list_string;
- $nesting_list_flag =
- substr( $nesting_list_string, -1 ) eq '1';
+ elsif ($type_i eq '}'
+ || $type_i eq 'R'
+ || $forced_indentation_flag < 0 )
+ {
- chop $ci_string_in_tokenizer;
- $ci_string_sum =
- ( my $str = $ci_string_in_tokenizer ) =~ tr/1/0/;
+ # only a nesting error in the script would prevent popping here
+ if ( @{$rslevel_stack} > 1 ) { pop( @{$rslevel_stack} ); }
+
+ $level_i = --$level_in_tokenizer;
+
+ # restore previous level values
+ if ( length($nesting_block_string) > 1 )
+ { # true for valid script
+ chop $nesting_block_string;
+ $nesting_block_flag =
+ substr( $nesting_block_string, -1 ) eq '1';
+ chop $nesting_list_string;
+ $nesting_list_flag =
+ substr( $nesting_list_string, -1 ) eq '1';
+
+ chop $ci_string_in_tokenizer;
+ $ci_string_sum =
+ ( my $str = $ci_string_in_tokenizer ) =~ tr/1/0/;
+
+ $in_statement_continuation =
+ chop $continuation_string_in_tokenizer;
+
+ # zero continuation flag at terminal BLOCK '}' which
+ # ends a statement.
+ my $block_type_i = $routput_block_type->[$i];
+ if ($block_type_i) {
+
+ # ...These include non-anonymous subs
+ # note: could be sub ::abc { or sub 'abc
+ if ( $block_type_i =~ m/^sub\s*/gc ) {
+
+ # note: older versions of perl require the /gc
+ # modifier here or else the \G does not work.
+ if ( $block_type_i =~ /\G('|::|\w)/gc ) {
+ $in_statement_continuation = 0;
+ }
+ }
- $in_statement_continuation =
- chop $continuation_string_in_tokenizer;
+ # ...and include all block types except user subs
+ # with block prototypes and these:
+ # (sort|grep|map|do|eval)
+ elsif (
+ $is_zero_continuation_block_type{$block_type_i}
+ )
+ {
+ $in_statement_continuation = 0;
+ }
- # zero continuation flag at terminal BLOCK '}' which
- # ends a statement.
- my $block_type_i = $routput_block_type->[$i];
- if ($block_type_i) {
+ # ..but these are not terminal types:
+ # /^(sort|grep|map|do|eval)$/ )
+ elsif ($is_sort_map_grep_eval_do{$block_type_i}
+ || $is_grep_alias{$block_type_i} )
+ {
+ }
- # ...These include non-anonymous subs
- # note: could be sub ::abc { or sub 'abc
- if ( $block_type_i =~ m/^sub\s*/gc ) {
+ # ..and a block introduced by a label
+ # /^\w+\s*:$/gc ) {
+ elsif ( $block_type_i =~ /:$/ ) {
+ $in_statement_continuation = 0;
+ }
- # note: older versions of perl require the /gc modifier
- # here or else the \G does not work.
- if ( $block_type_i =~ /\G('|::|\w)/gc ) {
+ # user function with block prototype
+ else {
$in_statement_continuation = 0;
}
+ } ## end if ($block_type_i)
+
+ # If we are in a list, then
+ # we must set continuation indentation at the closing
+ # paren of something like this (paren after $check):
+ # assert(
+ # __LINE__,
+ # ( not defined $check )
+ # or ref $check
+ # or $check eq "new"
+ # or $check eq "old",
+ # );
+ elsif ( $tok_i eq ')' ) {
+ $in_statement_continuation = 1
+ if (
+ $is_list_end_type{
+ $routput_container_type->[$i]
+ }
+ );
+ ##if $routput_container_type->[$i] =~ /^[;,\{\}]$/;
}
-# ...and include all block types except user subs with
-# block prototypes and these: (sort|grep|map|do|eval)
-# /^(\}|\{|BEGIN|END|CHECK|INIT|AUTOLOAD|DESTROY|UNITCHECK|continue|;|if|elsif|else|unless|while|until|for|foreach)$/
- elsif (
- $is_zero_continuation_block_type{$block_type_i} )
- {
+ elsif ( $tok_i eq ';' ) {
$in_statement_continuation = 0;
}
+ } ## end if ( length($nesting_block_string...))
- # ..but these are not terminal types:
- # /^(sort|grep|map|do|eval)$/ )
- elsif ($is_sort_map_grep_eval_do{$block_type_i}
- || $is_grep_alias{$block_type_i} )
- {
- }
+ # use environment after updating
+ $container_environment =
+ $nesting_block_flag ? 'BLOCK'
+ : $nesting_list_flag ? 'LIST'
+ : EMPTY_STRING;
+ $ci_string_i = $ci_string_sum + $in_statement_continuation;
+ } ## end elsif ( $type_i eq '}' ||...{)
- # ..and a block introduced by a label
- # /^\w+\s*:$/gc ) {
- elsif ( $block_type_i =~ /:$/ ) {
- $in_statement_continuation = 0;
- }
+ # not a structural indentation type..
+ else {
- # user function with block prototype
- else {
+ $container_environment =
+ $nesting_block_flag ? 'BLOCK'
+ : $nesting_list_flag ? 'LIST'
+ : EMPTY_STRING;
+
+ # zero the continuation indentation at certain tokens so
+ # that they will be at the same level as its container. For
+ # commas, this simplifies the -lp indentation logic, which
+ # counts commas. For ?: it makes them stand out.
+ if ($nesting_list_flag) {
+ ## $type_i =~ /^[,\?\:]$/
+ if ( $is_comma_question_colon{$type_i} ) {
$in_statement_continuation = 0;
}
}
- # If we are in a list, then
- # we must set continuation indentation at the closing
- # paren of something like this (paren after $check):
- # assert(
- # __LINE__,
- # ( not defined $check )
- # or ref $check
- # or $check eq "new"
- # or $check eq "old",
- # );
- elsif ( $tok eq ')' ) {
- $in_statement_continuation = 1
- if $routput_container_type->[$i] =~ /^[;,\{\}]$/;
- }
-
- elsif ( $tok eq ';' ) { $in_statement_continuation = 0 }
- }
-
- # use environment after updating
- $container_environment =
- $nesting_block_flag ? 'BLOCK'
- : $nesting_list_flag ? 'LIST'
- : "";
- $ci_string_i = $ci_string_sum + $in_statement_continuation;
- $nesting_block_string_i = $nesting_block_string;
- $nesting_list_string_i = $nesting_list_string;
- }
-
- # not a structural indentation type..
- else {
-
- $container_environment =
- $nesting_block_flag ? 'BLOCK'
- : $nesting_list_flag ? 'LIST'
- : "";
-
- # zero the continuation indentation at certain tokens so
- # that they will be at the same level as its container. For
- # commas, this simplifies the -lp indentation logic, which
- # counts commas. For ?: it makes them stand out.
- if ($nesting_list_flag) {
- ## $type =~ /^[,\?\:]$/
- if ( $is_comma_question_colon{$type} ) {
- $in_statement_continuation = 0;
+ # be sure binary operators get continuation indentation
+ if (
+ $container_environment
+ && ( $type_i eq 'k' && $is_binary_keyword{$tok_i}
+ || $is_binary_type{$type_i} )
+ )
+ {
+ $in_statement_continuation = 1;
}
- }
- # be sure binary operators get continuation indentation
- if (
- $container_environment
- && ( $type eq 'k' && $is_binary_keyword{$tok}
- || $is_binary_type{$type} )
- )
- {
- $in_statement_continuation = 1;
- }
+ # continuation indentation is sum of any open ci from
+ # previous levels plus the current level
+ $ci_string_i = $ci_string_sum + $in_statement_continuation;
- # continuation indentation is sum of any open ci from previous
- # levels plus the current level
- $ci_string_i = $ci_string_sum + $in_statement_continuation;
+ # update continuation flag ...
- # update continuation flag ...
- # if this isn't a blank or comment..
- if ( $type ne 'b' && $type ne '#' ) {
+ ## if ( $type_i ne 'b' && $type_i ne '#' ) { # moved above
- # and we are in a BLOCK
+ # if we are in a BLOCK
if ($nesting_block_flag) {
# the next token after a ';' and label starts a new stmt
- if ( $type eq ';' || $type eq 'J' ) {
+ if ( $type_i eq ';' || $type_i eq 'J' ) {
$in_statement_continuation = 0;
}
# as a non block, to simplify formatting. But these
# are actually blocks and can have semicolons.
# See code_block_type() and is_non_structural_brace().
- elsif ( $type eq ',' || $type eq ';' ) {
+ elsif ( $type_i eq ',' || $type_i eq ';' ) {
$in_statement_continuation = 0;
}
else {
$in_statement_continuation = 1;
}
- }
- }
- }
+ } ## end else [ if ($nesting_block_flag)]
+
+ ##} ## end if ( $type_i ne 'b' ... # (old moved above)
- if ( $level_in_tokenizer < 0 ) {
- unless ( $tokenizer_self->[_saw_negative_indentation_] ) {
- $tokenizer_self->[_saw_negative_indentation_] = 1;
- warning("Starting negative indentation\n");
+ } ## end else [ if ( $type_i eq '{' ||...})]
+
+ if ( $level_in_tokenizer < 0 ) {
+ unless ( $tokenizer_self->[_saw_negative_indentation_] ) {
+ $tokenizer_self->[_saw_negative_indentation_] = 1;
+ warning("Starting negative indentation\n");
+ }
}
- }
- # set secondary nesting levels based on all containment token types
- # Note: these are set so that the nesting depth is the depth
- # of the PREVIOUS TOKEN, which is convenient for setting
- # the strength of token bonds
- my $slevel_i = $slevel_in_tokenizer;
+ # set secondary nesting levels based on all containment token
+ # types Note: these are set so that the nesting depth is the
+ # depth of the PREVIOUS TOKEN, which is convenient for setting
+ # the strength of token bonds
- # /^[L\{\(\[]$/
- if ( $is_opening_type{$type} ) {
- $slevel_in_tokenizer++;
- $nesting_token_string .= $tok;
- $nesting_type_string .= $type;
- }
+ # /^[L\{\(\[]$/
+ if ( $is_opening_type{$type_i} ) {
+ $slevel_in_tokenizer++;
+ $nesting_token_string .= $tok_i;
+ $nesting_type_string .= $type_i;
+ }
- # /^[R\}\)\]]$/
- elsif ( $is_closing_type{$type} ) {
- $slevel_in_tokenizer--;
- my $char = chop $nesting_token_string;
+ # /^[R\}\)\]]$/
+ elsif ( $is_closing_type{$type_i} ) {
+ $slevel_in_tokenizer--;
+ my $char = chop $nesting_token_string;
- if ( $char ne $matching_start_token{$tok} ) {
- $nesting_token_string .= $char . $tok;
- $nesting_type_string .= $type;
+ if ( $char ne $matching_start_token{$tok_i} ) {
+ $nesting_token_string .= $char . $tok_i;
+ $nesting_type_string .= $type_i;
+ }
+ else {
+ chop $nesting_type_string;
+ }
}
- else {
- chop $nesting_type_string;
+
+ # apply token type patch:
+ # - output anonymous 'sub' as keyword (type 'k')
+ # - output __END__, __DATA__, and format as type 'k' instead
+ # of ';' to make html colors correct, etc.
+ # The following hash tests are equivalent to these older tests:
+ # if ( $type_i eq 't' && $is_sub{$tok_i} ) { $fix_type = 'k' }
+ # if ( $type_i eq ';' && $tok_i =~ /\w/ ) { $fix_type = 'k' }
+ if ( $is_END_DATA_format_sub{$tok_i}
+ && $is_semicolon_or_t{$type_i} )
+ {
+ $type_i = 'k';
}
- }
+ } ## end else [ if ( $type_i eq 'b' ||...)]
- push( @block_type, $routput_block_type->[$i] );
- push( @ci_string, $ci_string_i );
- push( @container_environment, $container_environment );
- push( @container_type, $routput_container_type->[$i] );
- push( @levels, $level_i );
- push( @nesting_tokens, $nesting_token_string_i );
- push( @nesting_types, $nesting_type_string_i );
- push( @slevels, $slevel_i );
- push( @token_type, $fix_type );
- push( @type_sequence, $routput_type_sequence->[$i] );
- push( @nesting_blocks, $nesting_block_string );
- push( @nesting_lists, $nesting_list_string );
-
- # now form the previous token
+ # Store the values for this token
+ push( @ci_string, $ci_string_i );
+ push( @levels, $level_i );
+ push( @block_type, $routput_block_type->[$i] );
+ push( @type_sequence, $routput_type_sequence->[$i] );
+ push( @token_type, $type_i );
+
+ # Form and store the previous token
if ( $im >= 0 ) {
$num =
$rtoken_map->[$i] - $rtoken_map->[$im]; # how many characters
substr( $input_line, $rtoken_map->[$im], $num ) );
}
}
+
+ # or grab some values for the leading token (needed for log output)
+ else {
+ $line_of_tokens->{_nesting_blocks_0} = $nesting_block_string;
+ }
+
$im = $i;
- }
+ } ## end foreach my $i ( @{$routput_token_list...})
+ # Form and store the final token
$num = length($input_line) - $rtoken_map->[$im]; # make the last token
if ( $num > 0 ) {
push( @tokens, substr( $input_line, $rtoken_map->[$im], $num ) );
}
- $tokenizer_self->[_in_attribute_list_] = $in_attribute_list;
- $tokenizer_self->[_in_quote_] = $in_quote;
- $tokenizer_self->[_quote_target_] =
- $in_quote ? matching_end_token($quote_character) : "";
- $tokenizer_self->[_rhere_target_list_] = $rhere_target_list;
-
- $line_of_tokens->{_rtoken_type} = \@token_type;
- $line_of_tokens->{_rtokens} = \@tokens;
- $line_of_tokens->{_rblock_type} = \@block_type;
- $line_of_tokens->{_rcontainer_type} = \@container_type;
- $line_of_tokens->{_rcontainer_environment} = \@container_environment;
- $line_of_tokens->{_rtype_sequence} = \@type_sequence;
- $line_of_tokens->{_rlevels} = \@levels;
- $line_of_tokens->{_rslevels} = \@slevels;
- $line_of_tokens->{_rnesting_tokens} = \@nesting_tokens;
- $line_of_tokens->{_rci_levels} = \@ci_string;
- $line_of_tokens->{_rnesting_blocks} = \@nesting_blocks;
+ $line_of_tokens->{_rtoken_type} = \@token_type;
+ $line_of_tokens->{_rtokens} = \@tokens;
+ $line_of_tokens->{_rblock_type} = \@block_type;
+ $line_of_tokens->{_rtype_sequence} = \@type_sequence;
+ $line_of_tokens->{_rlevels} = \@levels;
+ $line_of_tokens->{_rci_levels} = \@ci_string;
return;
- }
+ } ## end sub tokenizer_wrapup_line
} ## end tokenize_this_line
#########i#############################################################
my ($rarg) = @_;
- my $msg = "";
+ my $msg = EMPTY_STRING;
##############
# Table lookup
$op_expected = OPERATOR;
}
- # Patch to allow a ? following 'split' to be a depricated pattern
+ # Patch to allow a ? following 'split' to be a deprecated pattern
# delimiter. This patch is coordinated with the omission of split
# from the list
# %is_keyword_rejecting_question_as_pattern_delimiter. This patch
# Exception to weird parsing rules for 'x(' ... see case b1205:
# In something like 'print $vv x(...' the x is an operator;
- # Likewise in 'print $vv x$ww' the x is an operatory (case b1207)
+ # Likewise in 'print $vv x$ww' the x is an operator (case b1207)
# otherwise x follows the weird parsing rules.
elsif ( $tok eq 'x' && $next_type =~ /^[\(\$\@\%]$/ ) {
$op_expected = OPERATOR;
return $op_expected;
-} ## end of sub operator_expected
+} ## end sub operator_expected
sub new_statement_ok {
|| $last_nonblank_type eq 'J'; # or we follow a label
-}
+} ## end sub new_statement_ok
sub label_ok {
else {
return ( $last_nonblank_type eq ';' || $last_nonblank_type eq 'J' );
}
-}
+} ## end sub label_ok
sub code_block_type {
# cannot start a code block within an anonymous hash
else {
- return "";
+ return EMPTY_STRING;
}
}
# snippet is an anonymous hash ref and not a code block!
# print 'hi' if { x => 1, }->{x};
# We can identify this situation because the last nonblank type
- # will be a keyword (instead of a closing peren)
- if ( $last_nonblank_token =~ /^(if|unless)$/
- && $last_nonblank_type eq 'k' )
+ # will be a keyword (instead of a closing paren)
+ if (
+ $last_nonblank_type eq 'k'
+ && ( $last_nonblank_token eq 'if'
+ || $last_nonblank_token eq 'unless' )
+ )
{
- return "";
+ return EMPTY_STRING;
}
else {
return $last_nonblank_token;
# check for syntax 'use MODULE LIST'
# This fixes b1022 b1025 b1027 b1028 b1029 b1030 b1031
- return "" if ( $statement_type eq 'use' );
+ return EMPTY_STRING if ( $statement_type eq 'use' );
return decide_if_code_block( $i, $rtokens, $rtoken_type,
$max_token_index );
# Check for a code block within a parenthesized function call
elsif ( $last_nonblank_token eq '(' ) {
my $paren_type = $paren_type[$paren_depth];
- if ( $paren_type && $paren_type =~ /^(map|grep|sort)$/ ) {
+
+ # /^(map|grep|sort)$/
+ if ( $paren_type && $is_sort_map_grep{$paren_type} ) {
# We will mark this as a code block but use type 't' instead
- # of the name of the contining function. This will allow for
+ # of the name of the containing function. This will allow for
# correct parsing but will usually produce better formatting.
# Braces with block type 't' are not broken open automatically
# in the formatter as are other code block types, and this usually
return 't'; # (Not $paren_type)
}
else {
- return "";
+ return EMPTY_STRING;
}
}
# anything else must be anonymous hash reference
else {
- return "";
+ return EMPTY_STRING;
}
-}
+} ## end sub code_block_type
sub decide_if_code_block {
# Check for the common case of an empty anonymous hash reference:
# Maybe something like sub { { } }
if ( $next_nonblank_token eq '}' ) {
- $code_block_type = "";
+ $code_block_type = EMPTY_STRING;
}
else {
# Patched for RT #95708
if (
- # it is a comma which is not a pattern delimeter except for qw
+ # it is a comma which is not a pattern delimiter except for qw
(
- $pre_types[$j] eq ','
- && $pre_tokens[$jbeg] !~ /^(s|m|y|tr|qr|q|qq|qx)$/
+ $pre_types[$j] eq ','
+ ## !~ /^(s|m|y|tr|qr|q|qq|qx)$/
+ && !$is_q_qq_qx_qr_s_y_tr_m{ $pre_tokens[$jbeg] }
)
# or a =>
|| ( $pre_types[$j] eq '=' && $pre_types[ ++$j ] eq '>' )
)
{
- $code_block_type = "";
+ $code_block_type = EMPTY_STRING;
}
}
# If this brace follows a bareword, then append a space as a signal
# to the formatter that this may not be a block brace. To find the
# corresponding code in Formatter.pm search for 'b1085'.
- $code_block_type .= " " if ( $code_block_type =~ /^\w/ );
+ $code_block_type .= SPACE if ( $code_block_type =~ /^\w/ );
}
}
return $code_block_type;
-}
+} ## end sub decide_if_code_block
sub report_unexpected {
make_numbered_line( $input_line_number, $input_line, $pos );
$underline = write_on_underline( $underline, $pos - $offset, '^' );
- my $trailer = "";
+ my $trailer = EMPTY_STRING;
if ( ( $i_tok > 0 ) && ( $last_nonblank_i >= 0 ) ) {
my $pos_prev = $rpretoken_map->[$last_nonblank_i];
my $num;
resume_logfile();
}
return;
-}
+} ## end sub report_unexpected
my %is_sigil_or_paren;
my %is_R_closing_sb;
##|| $last_nonblank_type =~ /^([R\]])$/
|| $is_R_closing_sb{$last_nonblank_type}
);
-}
+} ## end sub is_non_structural_brace
#########i#############################################################
# Tokenizer routines for tracking container nesting depths
# Fix part #1 for git82: save last token type for propagation of type 'Z'
$nested_statement_type[$aa][ $current_depth[$aa] ] =
[ $statement_type, $last_nonblank_type, $last_nonblank_token ];
- $statement_type = "";
+ $statement_type = EMPTY_STRING;
return ( $seqno, $indent );
-}
+} ## end sub increase_nesting_depth
sub is_balanced_closing_container {
# OK, everything will be balanced
return 1;
-}
+} ## end sub is_balanced_closing_container
sub decrease_nesting_depth {
my ($ess);
if ( $diff == 1 || $diff == -1 ) {
- $ess = '';
+ $ess = EMPTY_STRING;
}
else {
$ess = 's';
if ( $closing_brace_names[$aa] ne "':'" );
}
return ( $seqno, $outdent );
-}
+} ## end sub decrease_nesting_depth
sub check_final_nesting_depths {
}
}
return;
-}
+} ## end sub check_final_nesting_depths
#########i#############################################################
# Tokenizer routines for looking ahead in input stream
last;
}
return ( $rpre_tokens, $rpre_types );
-}
+} ## end sub peek_ahead_for_n_nonblank_pre_tokens
# look ahead for next non-blank, non-comment line of code
sub peek_ahead_for_nonblank_token {
last;
}
return;
-}
+} ## end sub peek_ahead_for_nonblank_token
#########i#############################################################
# Tokenizer guessing routines for ambiguous situations
# look for a possible ending ? on this line..
my $in_quote = 1;
my $quote_depth = 0;
- my $quote_character = '';
+ my $quote_character = EMPTY_STRING;
my $quote_pos = 0;
my $quoted_string;
(
}
}
return ( $is_pattern, $msg );
-}
+} ## end sub guess_if_pattern_or_conditional
my %is_known_constant;
my %is_known_function;
# look for a possible ending / on this line..
my $in_quote = 1;
my $quote_depth = 0;
- my $quote_character = '';
+ my $quote_character = EMPTY_STRING;
my $quote_pos = 0;
my $quoted_string;
(
RETURN:
return ( $is_pattern, $msg );
-}
+} ## end sub guess_if_pattern_or_division
# try to resolve here-doc vs. shift by looking ahead for
# non-code or the end token (currently only looks for end token)
}
write_logfile_entry($msg);
return $here_doc_expected;
-}
+} ## end sub guess_if_here_doc
#########i#############################################################
# Tokenizer Routines for scanning identifiers and related items
# ($,%,@,*) including something like abc::def::ghi
$type = 'w';
- my $sub_name = "";
+ my $sub_name = EMPTY_STRING;
if ( defined($2) ) { $sub_name = $2; }
if ( defined($1) ) {
$package = $1;
warning("didn't find identifier after leading ::\n");
}
return ( $i, $tok, $type, $prototype );
-}
+} ## end sub scan_bare_identifier_do
sub scan_id_do {
$max_token_index )
= @_;
use constant DEBUG_NSCAN => 0;
- my $type = '';
+ my $type = EMPTY_STRING;
my ( $i_beg, $pos_beg );
#print "NSCAN:entering i=$i, tok=$tok, type=$type, state=$id_scan_state\n";
# on re-entry, start scanning at first token on the line
if ($id_scan_state) {
$i_beg = $i;
- $type = '';
+ $type = EMPTY_STRING;
}
# on initial entry, start scanning just after type token
( $i, $tok, $type ) =
do_scan_package( $input_line, $i, $i_beg, $tok, $type, $rtokens,
$rtoken_map, $max_token_index );
- $id_scan_state = '';
+ $id_scan_state = EMPTY_STRING;
}
else {
warning("invalid token in scan_id: $tok\n");
- $id_scan_state = '';
+ $id_scan_state = EMPTY_STRING;
}
}
"NSCAN: returns i=$i, tok=$tok, type=$type, state=$id_scan_state\n";
};
return ( $i, $tok, $type, $id_scan_state );
-}
+} ## end sub scan_id_do
sub check_prototype {
my ( $proto, $package, $subname ) = @_;
$is_user_function{$package}{$subname} = 1;
}
return;
-}
+} ## end sub check_prototype
sub do_scan_package {
}
return ( $i, $tok, $type );
-}
+} ## end sub do_scan_package
my %is_special_variable_char;
@{is_special_variable_char}{@q} = (1) x scalar(@q);
}
-sub scan_identifier_do {
+{ ## begin closure for sub scan_complex_identifier
+
+ use constant DEBUG_SCAN_ID => 0;
- # This routine assembles tokens into identifiers. It maintains a
- # scan state, id_scan_state. It updates id_scan_state based upon
- # current id_scan_state and token, and returns an updated
- # id_scan_state and the next index after the identifier.
+ # These are the possible states for this scanner:
+ my $scan_state_SIGIL = '$';
+ my $scan_state_ALPHA = 'A';
+ my $scan_state_COLON = ':';
+ my $scan_state_LPAREN = '(';
+ my $scan_state_RPAREN = ')';
+ my $scan_state_AMPERSAND = '&';
+ my $scan_state_SPLIT = '^';
+
+ # Only these non-blank states may be returned to caller:
+ my %is_returnable_scan_state = (
+ $scan_state_SIGIL => 1,
+ $scan_state_AMPERSAND => 1,
+ );
- # USES GLOBAL VARIABLES: $context, $last_nonblank_token,
- # $last_nonblank_type
+ # USES GLOBAL VARIABLES:
+ # $context, $last_nonblank_token, $last_nonblank_type
+ #-----------
+ # call args:
+ #-----------
my ( $i, $id_scan_state, $identifier, $rtokens, $max_token_index,
- $expecting, $container_type )
- = @_;
- use constant DEBUG_SCAN_ID => 0;
- my $i_begin = $i;
- my $type = '';
- my $tok_begin = $rtokens->[$i_begin];
- if ( $tok_begin eq ':' ) { $tok_begin = '::' }
- my $id_scan_state_begin = $id_scan_state;
- my $identifier_begin = $identifier;
- my $tok = $tok_begin;
- my $message = "";
- my $tok_is_blank; # a flag to speed things up
-
- my $in_prototype_or_signature =
- $container_type && $container_type =~ /^sub\b/;
-
- # these flags will be used to help figure out the type:
+ $expecting, $container_type );
+
+ #-------------------------------------------
+ # my variables, re-initialized on each call:
+ #-------------------------------------------
+ my $i_begin; # starting index $i
+ my $type; # returned identifier type
+ my $tok_begin; # starting token
+ my $tok; # returned token
+ my $id_scan_state_begin; # starting scan state
+ my $identifier_begin; # starting identifier
+ my $i_save; # a last good index, in case of error
+ my $message; # hold error message for log file
+ my $tok_is_blank;
+ my $last_tok_is_blank;
+ my $in_prototype_or_signature;
my $saw_alpha;
my $saw_type;
+ my $allow_tick;
- # allow old package separator (') except in 'use' statement
- my $allow_tick = ( $last_nonblank_token ne 'use' );
+ sub initialize_my_scan_id_vars {
- #########################################################
- # get started by defining a type and a state if necessary
- #########################################################
+ # Initialize all 'my' vars on entry
+ $i_begin = $i;
+ $type = EMPTY_STRING;
+ $tok_begin = $rtokens->[$i_begin];
+ $tok = $tok_begin;
+ if ( $tok_begin eq ':' ) { $tok_begin = '::' }
+ $id_scan_state_begin = $id_scan_state;
+ $identifier_begin = $identifier;
+ $i_save = undef;
- if ( !$id_scan_state ) {
- $context = UNKNOWN_CONTEXT;
+ $message = EMPTY_STRING;
+ $tok_is_blank = undef; # a flag to speed things up
+ $last_tok_is_blank = undef;
- # fixup for digraph
- if ( $tok eq '>' ) {
- $tok = '->';
- $tok_begin = $tok;
- }
- $identifier = $tok;
+ $in_prototype_or_signature =
+ $container_type && $container_type =~ /^sub\b/;
- if ( $tok eq '$' || $tok eq '*' ) {
- $id_scan_state = '$';
- $context = SCALAR_CONTEXT;
- }
- elsif ( $tok eq '%' || $tok eq '@' ) {
- $id_scan_state = '$';
- $context = LIST_CONTEXT;
- }
- elsif ( $tok eq '&' ) {
- $id_scan_state = '&';
- }
- elsif ( $tok eq 'sub' or $tok eq 'package' ) {
- $saw_alpha = 0; # 'sub' is considered type info here
- $id_scan_state = '$';
- $identifier .= ' '; # need a space to separate sub from sub name
- }
- elsif ( $tok eq '::' ) {
- $id_scan_state = 'A';
- }
- elsif ( $tok =~ /^\w/ ) {
- $id_scan_state = ':';
- $saw_alpha = 1;
- }
- elsif ( $tok eq '->' ) {
- $id_scan_state = '$';
- }
- else {
+ # these flags will be used to help figure out the type:
+ $saw_alpha = undef;
+ $saw_type = undef;
- # shouldn't happen: bad call parameter
- my $msg =
-"Program bug detected: scan_identifier received bad starting token = '$tok'\n";
- if (DEVEL_MODE) { Fault($msg) }
- if ( !$tokenizer_self->[_in_error_] ) {
- warning($msg);
- $tokenizer_self->[_in_error_] = 1;
- }
- $id_scan_state = '';
- goto RETURN;
- }
- $saw_type = !$saw_alpha;
- }
- else {
- $i--;
- $saw_alpha = ( $tok =~ /^\w/ );
- $saw_type = ( $tok =~ /([\$\%\@\*\&])/ );
- }
+ # allow old package separator (') except in 'use' statement
+ $allow_tick = ( $last_nonblank_token ne 'use' );
+ return;
+ } ## end sub initialize_my_scan_id_vars
- ###############################
- # loop to gather the identifier
- ###############################
+ #----------------------------------
+ # Routines for handling scan states
+ #----------------------------------
+ sub do_id_scan_state_dollar {
- my $i_save = $i;
+ # We saw a sigil, now looking to start a variable name
- while ( $i < $max_token_index ) {
- my $last_tok_is_blank = $tok_is_blank;
- if ($tok_is_blank) { $tok_is_blank = undef }
- else { $i_save = $i }
+ if ( $tok eq '$' ) {
- $tok = $rtokens->[ ++$i ];
+ $identifier .= $tok;
- # patch to make digraph :: if necessary
- if ( ( $tok eq ':' ) && ( $rtokens->[ $i + 1 ] eq ':' ) ) {
- $tok = '::';
- $i++;
+ # we've got a punctuation variable if end of line (punct.t)
+ if ( $i == $max_token_index ) {
+ $type = 'i';
+ $id_scan_state = EMPTY_STRING;
+ }
+ }
+ elsif ( $tok =~ /^\w/ ) { # alphanumeric ..
+ $saw_alpha = 1;
+ $id_scan_state = $scan_state_COLON; # now need ::
+ $identifier .= $tok;
+ }
+ elsif ( $tok eq '::' ) {
+ $id_scan_state = $scan_state_ALPHA;
+ $identifier .= $tok;
}
- ########################
- # Starting variable name
- ########################
-
- if ( $id_scan_state eq '$' ) {
-
- if ( $tok eq '$' ) {
-
- $identifier .= $tok;
+ # POSTDEFREF ->@ ->% ->& ->*
+ elsif ( ( $tok =~ /^[\@\%\&\*]$/ ) && $identifier =~ /\-\>$/ ) {
+ $identifier .= $tok;
+ }
+ elsif ( $tok eq "'" && $allow_tick ) { # alphanumeric ..
+ $saw_alpha = 1;
+ $id_scan_state = $scan_state_COLON; # now need ::
+ $identifier .= $tok;
- # we've got a punctuation variable if end of line (punct.t)
- if ( $i == $max_token_index ) {
- $type = 'i';
- $id_scan_state = '';
- last;
- }
- }
- elsif ( $tok =~ /^\w/ ) { # alphanumeric ..
- $saw_alpha = 1;
- $id_scan_state = ':'; # now need ::
- $identifier .= $tok;
- }
- elsif ( $tok eq '::' ) {
- $id_scan_state = 'A';
- $identifier .= $tok;
- }
+ # Perl will accept leading digits in identifiers,
+ # although they may not always produce useful results.
+ # Something like $main::0 is ok. But this also works:
+ #
+ # sub howdy::123::bubba{ print "bubba $54321!\n" }
+ # howdy::123::bubba();
+ #
+ }
+ elsif ( $tok eq '#' ) {
- # POSTDEFREF ->@ ->% ->& ->*
- elsif ( ( $tok =~ /^[\@\%\&\*]$/ ) && $identifier =~ /\-\>$/ ) {
- $identifier .= $tok;
- }
- elsif ( $tok eq "'" && $allow_tick ) { # alphanumeric ..
- $saw_alpha = 1;
- $id_scan_state = ':'; # now need ::
- $identifier .= $tok;
+ my $is_punct_var = $identifier eq '$$';
- # Perl will accept leading digits in identifiers,
- # although they may not always produce useful results.
- # Something like $main::0 is ok. But this also works:
- #
- # sub howdy::123::bubba{ print "bubba $54321!\n" }
- # howdy::123::bubba();
- #
- }
- elsif ( $tok eq '#' ) {
+ # side comment or identifier?
+ if (
- # side comment or identifier?
- if (
+ # A '#' starts a comment if it follows a space. For example,
+ # the following is equivalent to $ans=40.
+ # my $ #
+ # ans = 40;
+ !$last_tok_is_blank
- # A '#' starts a comment if it follows a space. For example,
- # the following is equivalent to $ans=40.
- # my $ #
- # ans = 40;
- !$last_tok_is_blank
+ # a # inside a prototype or signature can only start a
+ # comment
+ && !$in_prototype_or_signature
- # a # inside a prototype or signature can only start a
- # comment
- && !$in_prototype_or_signature
+ # these are valid punctuation vars: *# %# @# $#
+ # May also be '$#array' or POSTDEFREF ->$#
+ && ( $identifier =~ /^[\%\@\$\*]$/
+ || $identifier =~ /\$$/ )
- # these are valid punctuation vars: *# %# @# $#
- # May also be '$#array' or POSTDEFREF ->$#
- && ( $identifier =~ /^[\%\@\$\*]$/ || $identifier =~ /\$$/ )
+ # but a '#' after '$$' is a side comment; see c147
+ && !$is_punct_var
- )
- {
- $identifier .= $tok; # keep same state, a $ could follow
- }
- else {
+ )
+ {
+ $identifier .= $tok; # keep same state, a $ could follow
+ }
+ else {
- # otherwise it is a side comment
- if ( $identifier eq '->' ) { }
- elsif ( $id_scan_state eq '$' ) { $type = 't' }
- else { $type = 'i' }
- $i = $i_save;
- $id_scan_state = '';
- last;
- }
+ # otherwise it is a side comment
+ if ( $identifier eq '->' ) { }
+ elsif ($is_punct_var) { $type = 'i' }
+ elsif ( $id_scan_state eq $scan_state_SIGIL ) { $type = 't' }
+ else { $type = 'i' }
+ $i = $i_save;
+ $id_scan_state = EMPTY_STRING;
}
+ }
- elsif ( $tok eq '{' ) {
+ elsif ( $tok eq '{' ) {
- # check for something like ${#} or ${©}
- if (
- (
- $identifier eq '$'
- || $identifier eq '@'
- || $identifier eq '$#'
- )
- && $i + 2 <= $max_token_index
- && $rtokens->[ $i + 2 ] eq '}'
- && $rtokens->[ $i + 1 ] !~ /[\s\w]/
- )
- {
- my $next2 = $rtokens->[ $i + 2 ];
- my $next1 = $rtokens->[ $i + 1 ];
- $identifier .= $tok . $next1 . $next2;
- $i += 2;
- $id_scan_state = '';
- last;
- }
+ # check for something like ${#} or ${©}
+ if (
+ (
+ $identifier eq '$'
+ || $identifier eq '@'
+ || $identifier eq '$#'
+ )
+ && $i + 2 <= $max_token_index
+ && $rtokens->[ $i + 2 ] eq '}'
+ && $rtokens->[ $i + 1 ] !~ /[\s\w]/
+ )
+ {
+ my $next2 = $rtokens->[ $i + 2 ];
+ my $next1 = $rtokens->[ $i + 1 ];
+ $identifier .= $tok . $next1 . $next2;
+ $i += 2;
+ $id_scan_state = EMPTY_STRING;
+ }
+ else {
# skip something like ${xxx} or ->{
- $id_scan_state = '';
+ $id_scan_state = EMPTY_STRING;
# if this is the first token of a line, any tokens for this
# identifier have already been accumulated
- if ( $identifier eq '$' || $i == 0 ) { $identifier = ''; }
+ if ( $identifier eq '$' || $i == 0 ) {
+ $identifier = EMPTY_STRING;
+ }
$i = $i_save;
- last;
}
+ }
+
+ # space ok after leading $ % * & @
+ elsif ( $tok =~ /^\s*$/ ) {
- # space ok after leading $ % * & @
- elsif ( $tok =~ /^\s*$/ ) {
+ $tok_is_blank = 1;
- $tok_is_blank = 1;
+ # note: an id with a leading '&' does not actually come this way
+ if ( $identifier =~ /^[\$\%\*\&\@]/ ) {
- if ( $identifier =~ /^[\$\%\*\&\@]/ ) {
+ if ( length($identifier) > 1 ) {
+ $id_scan_state = EMPTY_STRING;
+ $i = $i_save;
+ $type = 'i'; # probably punctuation variable
+ }
+ else {
- if ( length($identifier) > 1 ) {
- $id_scan_state = '';
- $i = $i_save;
- $type = 'i'; # probably punctuation variable
- last;
+ # fix c139: trim line-ending type 't'
+ if ( $i == $max_token_index ) {
+ $i = $i_save;
+ $type = 't';
}
- else {
- # spaces after $'s are common, and space after @
- # is harmless, so only complain about space
- # after other type characters. Space after $ and
- # @ will be removed in formatting. Report space
- # after % and * because they might indicate a
- # parsing error. In other words '% ' might be a
- # modulo operator. Delete this warning if it
- # gets annoying.
- if ( $identifier !~ /^[\@\$]$/ ) {
- $message =
- "Space in identifier, following $identifier\n";
- }
+ # spaces after $'s are common, and space after @
+ # is harmless, so only complain about space
+ # after other type characters. Space after $ and
+ # @ will be removed in formatting. Report space
+ # after % and * because they might indicate a
+ # parsing error. In other words '% ' might be a
+ # modulo operator. Delete this warning if it
+ # gets annoying.
+ elsif ( $identifier !~ /^[\@\$]$/ ) {
+ $message =
+ "Space in identifier, following $identifier\n";
+ }
+ else {
+ ## ok: silently accept space after '$' and '@' sigils
}
}
+ }
+
+ elsif ( $identifier eq '->' ) {
- # else:
- # space after '->' is ok
+ # space after '->' is ok except at line end ..
+ # so trim line-ending in type '->' (fixes c139)
+ if ( $i == $max_token_index ) {
+ $i = $i_save;
+ $type = '->';
+ }
}
- elsif ( $tok eq '^' ) {
- # check for some special variables like $^ $^W
- if ( $identifier =~ /^[\$\*\@\%]$/ ) {
- $identifier .= $tok;
- $type = 'i';
+ # stop at space after something other than -> or sigil
+ # Example of what can arrive here:
+ # eval { $MyClass->$$ };
+ else {
+ $id_scan_state = EMPTY_STRING;
+ $i = $i_save;
+ $type = 'i';
+ }
+ }
+ elsif ( $tok eq '^' ) {
- # There may be one more character, not a space, after the ^
- my $next1 = $rtokens->[ $i + 1 ];
- my $chr = substr( $next1, 0, 1 );
- if ( $is_special_variable_char{$chr} ) {
+ # check for some special variables like $^ $^W
+ if ( $identifier =~ /^[\$\*\@\%]$/ ) {
+ $identifier .= $tok;
+ $type = 'i';
- # It is something like $^W
- # Test case (c066) : $^Oeq'linux'
- $i++;
- $identifier .= $next1;
+ # There may be one more character, not a space, after the ^
+ my $next1 = $rtokens->[ $i + 1 ];
+ my $chr = substr( $next1, 0, 1 );
+ if ( $is_special_variable_char{$chr} ) {
- # If pretoken $next1 is more than one character long,
- # set a flag indicating that it needs to be split.
- $id_scan_state = ( length($next1) > 1 ) ? '^' : "";
- last;
- }
- else {
+ # It is something like $^W
+ # Test case (c066) : $^Oeq'linux'
+ $i++;
+ $identifier .= $next1;
- # it is just $^
- # Simple test case (c065): '$aa=$^if($bb)';
- $id_scan_state = "";
- last;
- }
+ # If pretoken $next1 is more than one character long,
+ # set a flag indicating that it needs to be split.
+ $id_scan_state =
+ ( length($next1) > 1 ) ? $scan_state_SPLIT : EMPTY_STRING;
}
else {
- $id_scan_state = '';
- $i = $i_save;
- last; # c106
+
+ # it is just $^
+ # Simple test case (c065): '$aa=$^if($bb)';
+ $id_scan_state = EMPTY_STRING;
}
}
- else { # something else
-
- if ( $in_prototype_or_signature && $tok =~ /^[\),=#]/ ) {
-
- # We might be in an extrusion of
- # sub foo2 ( $first, $, $third ) {
- # looking at a line starting with a comma, like
- # $
- # ,
- # in this case the comma ends the signature variable
- # '$' which will have been previously marked type 't'
- # rather than 'i'.
- if ( $i == $i_begin ) {
- $identifier = "";
- $type = "";
- }
+ else {
+ $id_scan_state = EMPTY_STRING;
+ $i = $i_save;
+ }
+ }
+ else { # something else
- # at a # we have to mark as type 't' because more may
- # follow, otherwise, in a signature we can let '$' be an
- # identifier here for better formatting.
- # See 'mangle4.in' for a test case.
- else {
- $type = 'i';
- if ( $id_scan_state eq '$' && $tok eq '#' ) {
- $type = 't';
- }
- $i = $i_save;
- }
- $id_scan_state = '';
- last;
- }
+ if ( $in_prototype_or_signature && $tok =~ /^[\),=#]/ ) {
- # check for various punctuation variables
- if ( $identifier =~ /^[\$\*\@\%]$/ ) {
- $identifier .= $tok;
+ # We might be in an extrusion of
+ # sub foo2 ( $first, $, $third ) {
+ # looking at a line starting with a comma, like
+ # $
+ # ,
+ # in this case the comma ends the signature variable
+ # '$' which will have been previously marked type 't'
+ # rather than 'i'.
+ if ( $i == $i_begin ) {
+ $identifier = EMPTY_STRING;
+ $type = EMPTY_STRING;
}
- # POSTDEFREF: Postfix reference ->$* ->%* ->@* ->** ->&* ->$#*
- elsif ($tok eq '*'
- && $identifier =~ /\-\>([\@\%\$\*\&]|\$\#)$/ )
- {
- $identifier .= $tok;
+ # at a # we have to mark as type 't' because more may
+ # follow, otherwise, in a signature we can let '$' be an
+ # identifier here for better formatting.
+ # See 'mangle4.in' for a test case.
+ else {
+ $type = 'i';
+ if ( $id_scan_state eq $scan_state_SIGIL && $tok eq '#' ) {
+ $type = 't';
+ }
+ $i = $i_save;
}
+ $id_scan_state = EMPTY_STRING;
+ }
- elsif ( $identifier eq '$#' ) {
+ # check for various punctuation variables
+ elsif ( $identifier =~ /^[\$\*\@\%]$/ ) {
+ $identifier .= $tok;
+ }
- if ( $tok eq '{' ) { $type = 'i'; $i = $i_save }
+ # POSTDEFREF: Postfix reference ->$* ->%* ->@* ->** ->&* ->$#*
+ elsif ($tok eq '*'
+ && $identifier =~ /\-\>([\@\%\$\*\&]|\$\#)$/ )
+ {
+ $identifier .= $tok;
+ }
- # perl seems to allow just these: $#: $#- $#+
- elsif ( $tok =~ /^[\:\-\+]$/ ) {
- $type = 'i';
- $identifier .= $tok;
- }
- else {
- $i = $i_save;
- write_logfile_entry( 'Use of $# is deprecated' . "\n" );
- }
- }
- elsif ( $identifier eq '$$' ) {
+ elsif ( $identifier eq '$#' ) {
- # perl does not allow references to punctuation
- # variables without braces. For example, this
- # won't work:
- # $:=\4;
- # $a = $$:;
- # You would have to use
- # $a = ${$:};
+ if ( $tok eq '{' ) { $type = 'i'; $i = $i_save }
- # '$$' alone is punctuation variable for PID
- $i = $i_save;
- if ( $tok eq '{' ) { $type = 't' }
- else { $type = 'i' }
- }
- elsif ( $identifier eq '->' ) {
- $i = $i_save;
+ # perl seems to allow just these: $#: $#- $#+
+ elsif ( $tok =~ /^[\:\-\+]$/ ) {
+ $type = 'i';
+ $identifier .= $tok;
}
else {
$i = $i_save;
- if ( length($identifier) == 1 ) { $identifier = ''; }
+ write_logfile_entry( 'Use of $# is deprecated' . "\n" );
+ }
+ }
+ elsif ( $identifier eq '$$' ) {
+
+ # perl does not allow references to punctuation
+ # variables without braces. For example, this
+ # won't work:
+ # $:=\4;
+ # $a = $$:;
+ # You would have to use
+ # $a = ${$:};
+
+ # '$$' alone is punctuation variable for PID
+ $i = $i_save;
+ if ( $tok eq '{' ) { $type = 't' }
+ else { $type = 'i' }
+ }
+ elsif ( $identifier eq '->' ) {
+ $i = $i_save;
+ }
+ else {
+ $i = $i_save;
+ if ( length($identifier) == 1 ) {
+ $identifier = EMPTY_STRING;
}
- $id_scan_state = '';
- last;
}
+ $id_scan_state = EMPTY_STRING;
}
+ return;
+ } ## end sub do_id_scan_state_dollar
+
+ sub do_id_scan_state_alpha {
- ###################################
# looking for alphanumeric after ::
- ###################################
+ $tok_is_blank = $tok =~ /^\s*$/;
+
+ if ( $tok =~ /^\w/ ) { # found it
+ $identifier .= $tok;
+ $id_scan_state = $scan_state_COLON; # now need ::
+ $saw_alpha = 1;
+ }
+ elsif ( $tok eq "'" && $allow_tick ) {
+ $identifier .= $tok;
+ $id_scan_state = $scan_state_COLON; # now need ::
+ $saw_alpha = 1;
+ }
+ elsif ( $tok_is_blank && $identifier =~ /^sub / ) {
+ $id_scan_state = $scan_state_LPAREN;
+ $identifier .= $tok;
+ }
+ elsif ( $tok eq '(' && $identifier =~ /^sub / ) {
+ $id_scan_state = $scan_state_RPAREN;
+ $identifier .= $tok;
+ }
+ else {
+ $id_scan_state = EMPTY_STRING;
+ $i = $i_save;
+ }
+ return;
+ } ## end sub do_id_scan_state_alpha
- elsif ( $id_scan_state eq 'A' ) {
+ sub do_id_scan_state_colon {
- $tok_is_blank = $tok =~ /^\s*$/;
+ # looking for possible :: after alphanumeric
- if ( $tok =~ /^\w/ ) { # found it
- $identifier .= $tok;
- $id_scan_state = ':'; # now need ::
- $saw_alpha = 1;
- }
- elsif ( $tok eq "'" && $allow_tick ) {
- $identifier .= $tok;
- $id_scan_state = ':'; # now need ::
- $saw_alpha = 1;
- }
- elsif ( $tok_is_blank && $identifier =~ /^sub / ) {
- $id_scan_state = '(';
- $identifier .= $tok;
- }
- elsif ( $tok eq '(' && $identifier =~ /^sub / ) {
- $id_scan_state = ')';
- $identifier .= $tok;
+ $tok_is_blank = $tok =~ /^\s*$/;
+
+ if ( $tok eq '::' ) { # got it
+ $identifier .= $tok;
+ $id_scan_state = $scan_state_ALPHA; # now require alpha
+ }
+ elsif ( $tok =~ /^\w/ ) { # more alphanumeric is ok here
+ $identifier .= $tok;
+ $id_scan_state = $scan_state_COLON; # now need ::
+ $saw_alpha = 1;
+ }
+ elsif ( $tok eq "'" && $allow_tick ) { # tick
+
+ if ( $is_keyword{$identifier} ) {
+ $id_scan_state = EMPTY_STRING; # that's all
+ $i = $i_save;
}
else {
- $id_scan_state = '';
- $i = $i_save;
- last;
+ $identifier .= $tok;
}
}
+ elsif ( $tok_is_blank && $identifier =~ /^sub / ) {
+ $id_scan_state = $scan_state_LPAREN;
+ $identifier .= $tok;
+ }
+ elsif ( $tok eq '(' && $identifier =~ /^sub / ) {
+ $id_scan_state = $scan_state_RPAREN;
+ $identifier .= $tok;
+ }
+ else {
+ $id_scan_state = EMPTY_STRING; # that's all
+ $i = $i_save;
+ }
+ return;
+ } ## end sub do_id_scan_state_colon
+
+ sub do_id_scan_state_left_paren {
+
+ # looking for possible '(' of a prototype
+
+ if ( $tok eq '(' ) { # got it
+ $identifier .= $tok;
+ $id_scan_state = $scan_state_RPAREN; # now find the end of it
+ }
+ elsif ( $tok =~ /^\s*$/ ) { # blank - keep going
+ $identifier .= $tok;
+ $tok_is_blank = 1;
+ }
+ else {
+ $id_scan_state = EMPTY_STRING; # that's all - no prototype
+ $i = $i_save;
+ }
+ return;
+ } ## end sub do_id_scan_state_left_paren
- ###################################
- # looking for :: after alphanumeric
- ###################################
+ sub do_id_scan_state_right_paren {
- elsif ( $id_scan_state eq ':' ) { # looking for :: after alpha
+ # looking for a ')' of prototype to close a '('
- $tok_is_blank = $tok =~ /^\s*$/;
+ $tok_is_blank = $tok =~ /^\s*$/;
- if ( $tok eq '::' ) { # got it
- $identifier .= $tok;
- $id_scan_state = 'A'; # now require alpha
+ if ( $tok eq ')' ) { # got it
+ $identifier .= $tok;
+ $id_scan_state = EMPTY_STRING; # all done
+ }
+ elsif ( $tok =~ /^[\s\$\%\\\*\@\&\;]/ ) {
+ $identifier .= $tok;
+ }
+ else { # probable error in script, but keep going
+ warning("Unexpected '$tok' while seeking end of prototype\n");
+ $identifier .= $tok;
+ }
+ return;
+ } ## end sub do_id_scan_state_right_paren
+
+ sub do_id_scan_state_ampersand {
+
+ # Starting sub call after seeing an '&'
+
+ if ( $tok =~ /^[\$\w]/ ) { # alphanumeric ..
+ $id_scan_state = $scan_state_COLON; # now need ::
+ $saw_alpha = 1;
+ $identifier .= $tok;
+ }
+ elsif ( $tok eq "'" && $allow_tick ) { # alphanumeric ..
+ $id_scan_state = $scan_state_COLON; # now need ::
+ $saw_alpha = 1;
+ $identifier .= $tok;
+ }
+ elsif ( $tok =~ /^\s*$/ ) { # allow space
+ $tok_is_blank = 1;
+
+ # fix c139: trim line-ending type 't'
+ if ( length($identifier) == 1 && $i == $max_token_index ) {
+ $i = $i_save;
+ $type = 't';
}
- elsif ( $tok =~ /^\w/ ) { # more alphanumeric is ok here
- $identifier .= $tok;
- $id_scan_state = ':'; # now need ::
- $saw_alpha = 1;
+ }
+ elsif ( $tok eq '::' ) { # leading ::
+ $id_scan_state = $scan_state_ALPHA; # accept alpha next
+ $identifier .= $tok;
+ }
+ elsif ( $tok eq '{' ) {
+ if ( $identifier eq '&' || $i == 0 ) {
+ $identifier = EMPTY_STRING;
}
- elsif ( $tok eq "'" && $allow_tick ) { # tick
+ $i = $i_save;
+ $id_scan_state = EMPTY_STRING;
+ }
+ elsif ( $tok eq '^' ) {
+ if ( $identifier eq '&' ) {
- if ( $is_keyword{$identifier} ) {
- $id_scan_state = ''; # that's all
- $i = $i_save;
+ # Special variable (c066)
+ $identifier .= $tok;
+ $type = '&';
+
+ # There may be one more character, not a space, after the ^
+ my $next1 = $rtokens->[ $i + 1 ];
+ my $chr = substr( $next1, 0, 1 );
+ if ( $is_special_variable_char{$chr} ) {
+
+ # It is something like &^O
+ $i++;
+ $identifier .= $next1;
+
+ # If pretoken $next1 is more than one character long,
+ # set a flag indicating that it needs to be split.
+ $id_scan_state =
+ ( length($next1) > 1 ) ? $scan_state_SPLIT : EMPTY_STRING;
}
else {
- $identifier .= $tok;
+
+ # it is &^
+ $id_scan_state = EMPTY_STRING;
}
}
- elsif ( $tok_is_blank && $identifier =~ /^sub / ) {
- $id_scan_state = '(';
- $identifier .= $tok;
- }
- elsif ( $tok eq '(' && $identifier =~ /^sub / ) {
- $id_scan_state = ')';
- $identifier .= $tok;
- }
else {
- $id_scan_state = ''; # that's all
- $i = $i_save;
- last;
+ $identifier = EMPTY_STRING;
+ $i = $i_save;
}
}
+ else {
- ##############################
- # looking for '(' of prototype
- ##############################
-
- elsif ( $id_scan_state eq '(' ) {
-
- if ( $tok eq '(' ) { # got it
- $identifier .= $tok;
- $id_scan_state = ')'; # now find the end of it
- }
- elsif ( $tok =~ /^\s*$/ ) { # blank - keep going
+ # punctuation variable?
+ # testfile: cunningham4.pl
+ #
+ # We have to be careful here. If we are in an unknown state,
+ # we will reject the punctuation variable. In the following
+ # example the '&' is a binary operator but we are in an unknown
+ # state because there is no sigil on 'Prima', so we don't
+ # know what it is. But it is a bad guess that
+ # '&~' is a function variable.
+ # $self->{text}->{colorMap}->[
+ # Prima::PodView::COLOR_CODE_FOREGROUND
+ # & ~tb::COLOR_INDEX ] =
+ # $sec->{ColorCode}
+
+ # Fix for case c033: a '#' here starts a side comment
+ if ( $identifier eq '&' && $expecting && $tok ne '#' ) {
$identifier .= $tok;
- $tok_is_blank = 1;
}
else {
- $id_scan_state = ''; # that's all - no prototype
- $i = $i_save;
- last;
+ $identifier = EMPTY_STRING;
+ $i = $i_save;
+ $type = '&';
}
+ $id_scan_state = EMPTY_STRING;
}
+ return;
+ } ## end sub do_id_scan_state_ampersand
+
+ #-------------------
+ # hash of scanner subs
+ #-------------------
+ my $scan_identifier_code = {
+ $scan_state_SIGIL => \&do_id_scan_state_dollar,
+ $scan_state_ALPHA => \&do_id_scan_state_alpha,
+ $scan_state_COLON => \&do_id_scan_state_colon,
+ $scan_state_LPAREN => \&do_id_scan_state_left_paren,
+ $scan_state_RPAREN => \&do_id_scan_state_right_paren,
+ $scan_state_AMPERSAND => \&do_id_scan_state_ampersand,
+ };
- ##############################
- # looking for ')' of prototype
- ##############################
+ sub scan_complex_identifier {
- elsif ( $id_scan_state eq ')' ) {
+ # This routine assembles tokens into identifiers. It maintains a
+ # scan state, id_scan_state. It updates id_scan_state based upon
+ # current id_scan_state and token, and returns an updated
+ # id_scan_state and the next index after the identifier.
- $tok_is_blank = $tok =~ /^\s*$/;
+ # This routine now serves a a backup for sub scan_simple_identifier
+ # which handles most identifiers.
- if ( $tok eq ')' ) { # got it
- $identifier .= $tok;
- $id_scan_state = ''; # all done
- last;
- }
- elsif ( $tok =~ /^[\s\$\%\\\*\@\&\;]/ ) {
- $identifier .= $tok;
- }
- else { # probable error in script, but keep going
- warning("Unexpected '$tok' while seeking end of prototype\n");
- $identifier .= $tok;
- }
- }
+ (
+ $i, $id_scan_state, $identifier, $rtokens, $max_token_index,
+ $expecting, $container_type
+ ) = @_;
- ###################
- # Starting sub call
- ###################
+ # return flag telling caller to split the pretoken
+ my $split_pretoken_flag;
- elsif ( $id_scan_state eq '&' ) {
+ ####################
+ # Initialize my vars
+ ####################
- if ( $tok =~ /^[\$\w]/ ) { # alphanumeric ..
- $id_scan_state = ':'; # now need ::
- $saw_alpha = 1;
- $identifier .= $tok;
+ initialize_my_scan_id_vars();
+
+ #########################################################
+ # get started by defining a type and a state if necessary
+ #########################################################
+
+ if ( !$id_scan_state ) {
+ $context = UNKNOWN_CONTEXT;
+
+ # fixup for digraph
+ if ( $tok eq '>' ) {
+ $tok = '->';
+ $tok_begin = $tok;
+ }
+ $identifier = $tok;
+
+ if ( $tok eq '$' || $tok eq '*' ) {
+ $id_scan_state = $scan_state_SIGIL;
+ $context = SCALAR_CONTEXT;
+ }
+ elsif ( $tok eq '%' || $tok eq '@' ) {
+ $id_scan_state = $scan_state_SIGIL;
+ $context = LIST_CONTEXT;
+ }
+ elsif ( $tok eq '&' ) {
+ $id_scan_state = $scan_state_AMPERSAND;
+ }
+ elsif ( $tok eq 'sub' or $tok eq 'package' ) {
+ $saw_alpha = 0; # 'sub' is considered type info here
+ $id_scan_state = $scan_state_SIGIL;
+ $identifier .=
+ SPACE; # need a space to separate sub from sub name
+ }
+ elsif ( $tok eq '::' ) {
+ $id_scan_state = $scan_state_ALPHA;
}
- elsif ( $tok eq "'" && $allow_tick ) { # alphanumeric ..
- $id_scan_state = ':'; # now need ::
+ elsif ( $tok =~ /^\w/ ) {
+ $id_scan_state = $scan_state_COLON;
$saw_alpha = 1;
- $identifier .= $tok;
}
- elsif ( $tok =~ /^\s*$/ ) { # allow space
- $tok_is_blank = 1;
+ elsif ( $tok eq '->' ) {
+ $id_scan_state = $scan_state_SIGIL;
}
- elsif ( $tok eq '::' ) { # leading ::
- $id_scan_state = 'A'; # accept alpha next
- $identifier .= $tok;
+ else {
+
+ # shouldn't happen: bad call parameter
+ my $msg =
+"Program bug detected: scan_identifier received bad starting token = '$tok'\n";
+ if (DEVEL_MODE) { Fault($msg) }
+ if ( !$tokenizer_self->[_in_error_] ) {
+ warning($msg);
+ $tokenizer_self->[_in_error_] = 1;
+ }
+ $id_scan_state = EMPTY_STRING;
+ goto RETURN;
}
- elsif ( $tok eq '{' ) {
- if ( $identifier eq '&' || $i == 0 ) { $identifier = ''; }
- $i = $i_save;
- $id_scan_state = '';
- last;
+ $saw_type = !$saw_alpha;
+ }
+ else {
+ $i--;
+ $saw_alpha = ( $tok =~ /^\w/ );
+ $saw_type = ( $tok =~ /([\$\%\@\*\&])/ );
+
+ # check for a valid starting state
+ if ( DEVEL_MODE && !$is_returnable_scan_state{$id_scan_state} ) {
+ Fault(<<EOM);
+Unexpected starting scan state in sub scan_complex_identifier: '$id_scan_state'
+EOM
}
- elsif ( $tok eq '^' ) {
- if ( $identifier eq '&' ) {
+ }
- # Special variable (c066)
- $identifier .= $tok;
- $type = '&';
+ ###############################
+ # loop to gather the identifier
+ ###############################
- # There may be one more character, not a space, after the ^
- my $next1 = $rtokens->[ $i + 1 ];
- my $chr = substr( $next1, 0, 1 );
- if ( $is_special_variable_char{$chr} ) {
+ $i_save = $i;
- # It is something like &^O
- $i++;
- $identifier .= $next1;
+ while ( $i < $max_token_index && $id_scan_state ) {
- # If pretoken $next1 is more than one character long,
- # set a flag indicating that it needs to be split.
- $id_scan_state = ( length($next1) > 1 ) ? '^' : "";
- }
- else {
+ # Be sure we have code to handle this state before we proceed
+ my $code = $scan_identifier_code->{$id_scan_state};
+ if ( !$code ) {
- # it is &^
- $id_scan_state = "";
- }
- last;
+ if ( $id_scan_state eq $scan_state_SPLIT ) {
+ ## OK: this is the signal to exit and split the pretoken
}
+
+ # unknown state - should not happen
else {
- $identifier = '';
- $i = $i_save;
+ if (DEVEL_MODE) {
+ Fault(<<EOM);
+Unknown scan state in sub scan_complex_identifier: '$id_scan_state'
+Scan state at sub entry was '$id_scan_state_begin'
+EOM
+ }
+ $id_scan_state = EMPTY_STRING;
+ $i = $i_save;
}
last;
}
- else {
- # punctuation variable?
- # testfile: cunningham4.pl
- #
- # We have to be careful here. If we are in an unknown state,
- # we will reject the punctuation variable. In the following
- # example the '&' is a binary operator but we are in an unknown
- # state because there is no sigil on 'Prima', so we don't
- # know what it is. But it is a bad guess that
- # '&~' is a function variable.
- # $self->{text}->{colorMap}->[
- # Prima::PodView::COLOR_CODE_FOREGROUND
- # & ~tb::COLOR_INDEX ] =
- # $sec->{ColorCode}
-
- # Fix for case c033: a '#' here starts a side comment
- if ( $identifier eq '&' && $expecting && $tok ne '#' ) {
- $identifier .= $tok;
+ # Remember the starting index for progress check below
+ my $i_start_loop = $i;
+
+ $last_tok_is_blank = $tok_is_blank;
+ if ($tok_is_blank) { $tok_is_blank = undef }
+ else { $i_save = $i }
+
+ $tok = $rtokens->[ ++$i ];
+
+ # patch to make digraph :: if necessary
+ if ( ( $tok eq ':' ) && ( $rtokens->[ $i + 1 ] eq ':' ) ) {
+ $tok = '::';
+ $i++;
+ }
+
+ $code->();
+
+ # check for forward progress: a decrease in the index $i
+ # implies that scanning has finished
+ last if ( $i <= $i_start_loop );
+
+ } ## end of main loop
+
+ ##############
+ # Check result
+ ##############
+
+ # Be sure a valid state is returned
+ if ($id_scan_state) {
+
+ if ( !$is_returnable_scan_state{$id_scan_state} ) {
+
+ if ( $id_scan_state eq $scan_state_SPLIT ) {
+ $split_pretoken_flag = 1;
}
- else {
- $identifier = '';
- $i = $i_save;
- $type = '&';
+
+ if ( $id_scan_state eq $scan_state_RPAREN ) {
+ warning(
+ "Hit end of line while seeking ) to end prototype\n");
}
- $id_scan_state = '';
- last;
- }
- }
- ######################
- # unknown state - quit
- ######################
+ $id_scan_state = EMPTY_STRING;
+ }
- else { # can get here due to error in initialization
- $id_scan_state = '';
- $i = $i_save;
- last;
+ # Patch: the deprecated variable $# does not combine with anything
+ # on the next line.
+ if ( $identifier eq '$#' ) { $id_scan_state = EMPTY_STRING }
}
- } ## end of main loop
-
- if ( $id_scan_state eq ')' ) {
- warning("Hit end of line while seeking ) to end prototype\n");
- }
- # once we enter the actual identifier, it may not extend beyond
- # the end of the current line
- if ( $id_scan_state =~ /^[A\:\(\)]/ ) {
- $id_scan_state = '';
- }
+ # Be sure the token index is valid
+ if ( $i < 0 ) { $i = 0 }
- # Patch: the deprecated variable $# does not combine with anything on the
- # next line.
- if ( $identifier eq '$#' ) { $id_scan_state = '' }
+ # Be sure a token type is defined
+ if ( !$type ) {
- if ( $i < 0 ) { $i = 0 }
+ if ($saw_type) {
- # Be sure a token type is defined
- if ( !$type ) {
+ if ($saw_alpha) {
- if ($saw_type) {
+ # The type without the -> should be the same as with the -> so
+ # that if they get separated we get the same bond strengths,
+ # etc. See b1234
+ if ( $identifier =~ /^->/
+ && $last_nonblank_type eq 'w'
+ && substr( $identifier, 2, 1 ) =~ /^\w/ )
+ {
+ $type = 'w';
+ }
+ else { $type = 'i' }
+ }
+ elsif ( $identifier eq '->' ) {
+ $type = '->';
+ }
+ elsif (
+ ( length($identifier) > 1 )
- if ($saw_alpha) {
+ # In something like '@$=' we have an identifier '@$'
+ # In something like '$${' we have type '$$' (and only
+ # part of an identifier)
+ && !( $identifier =~ /\$$/ && $tok eq '{' )
- # The type without the -> should be the same as with the -> so
- # that if they get separated we get the same bond strengths,
- # etc. See b1234
- if ( $identifier =~ /^->/
- && $last_nonblank_type eq 'w'
- && substr( $identifier, 2, 1 ) =~ /^\w/ )
+ ## && ( $identifier !~ /^(sub |package )$/ )
+ && $identifier ne 'sub '
+ && $identifier ne 'package '
+ )
{
- $type = 'w';
+ $type = 'i';
}
- else { $type = 'i' }
- }
- elsif ( $identifier eq '->' ) {
- $type = '->';
+ else { $type = 't' }
}
- elsif (
- ( length($identifier) > 1 )
+ elsif ($saw_alpha) {
- # In something like '@$=' we have an identifier '@$'
- # In something like '$${' we have type '$$' (and only
- # part of an identifier)
- && !( $identifier =~ /\$$/ && $tok eq '{' )
- && ( $identifier !~ /^(sub |package )$/ )
- )
- {
- $type = 'i';
+ # type 'w' includes anything without leading type info
+ # ($,%,@,*) including something like abc::def::ghi
+ $type = 'w';
+
+ # Fix for b1337, if restarting scan after line break between
+ # '->' or sigil and identifier name, use type 'i'
+ if ( $id_scan_state_begin
+ && $identifier =~ /^([\$\%\@\*\&]|->)/ )
+ {
+ $type = 'i';
+ }
}
- else { $type = 't' }
+ else {
+ $type = EMPTY_STRING;
+ } # this can happen on a restart
}
- elsif ($saw_alpha) {
- # type 'w' includes anything without leading type info
- # ($,%,@,*) including something like abc::def::ghi
- $type = 'w';
+ # See if we formed an identifier...
+ if ($identifier) {
+ $tok = $identifier;
+ if ($message) { write_logfile_entry($message) }
}
- else {
- $type = '';
- } # this can happen on a restart
- }
-
- # See if we formed an identifier...
- if ($identifier) {
- $tok = $identifier;
- if ($message) { write_logfile_entry($message) }
- }
- # did not find an identifier, back up
- else {
- $tok = $tok_begin;
- $i = $i_begin;
- }
+ # did not find an identifier, back up
+ else {
+ $tok = $tok_begin;
+ $i = $i_begin;
+ }
- RETURN:
+ RETURN:
- DEBUG_SCAN_ID && do {
- my ( $a, $b, $c ) = caller;
- print STDOUT
+ DEBUG_SCAN_ID && do {
+ my ( $a, $b, $c ) = caller;
+ print STDOUT
"SCANID: called from $a $b $c with tok, i, state, identifier =$tok_begin, $i_begin, $id_scan_state_begin, $identifier_begin\n";
- print STDOUT
+ print STDOUT
"SCANID: returned with tok, i, state, identifier =$tok, $i, $id_scan_state, $identifier\n";
- };
- return ( $i, $tok, $type, $id_scan_state, $identifier );
-}
+ };
+ return ( $i, $tok, $type, $id_scan_state, $identifier,
+ $split_pretoken_flag );
+ } ## end sub scan_complex_identifier
+} ## end closure for sub scan_complex_identifier
{ ## closure for sub do_scan_sub
# initialize subname each time a new 'sub' keyword is encountered
sub initialize_subname {
- $package_saved = "";
- $subname_saved = "";
+ $package_saved = EMPTY_STRING;
+ $subname_saved = EMPTY_STRING;
return;
}
: $tok eq '(' ? PAREN_CALL
: SUB_CALL;
- $id_scan_state = ""; # normally we get everything in one call
+ $id_scan_state = EMPTY_STRING; # normally we get everything in one call
my $subname = $subname_saved;
my $package = $package_saved;
my $proto = undef;
}
}
elsif ($next_nonblank_token) { # EOF technically ok
- $subname = "" unless defined($subname);
+ $subname = EMPTY_STRING unless defined($subname);
warning(
"expecting ':' or ';' or '{' after definition or declaration of sub '$subname' but saw '$next_nonblank_token'\n"
);
}
return ( $i, $tok, $type, $id_scan_state );
- }
+ } ## end sub do_scan_sub
}
#########i###############################################################
}
my $next_nonblank_token = $rtokens->[ ++$i ];
- return ( " ", $i ) unless defined($next_nonblank_token);
+ return ( SPACE, $i ) unless defined($next_nonblank_token);
if ( $next_nonblank_token =~ /^\s*$/ ) {
$next_nonblank_token = $rtokens->[ ++$i ];
- return ( " ", $i ) unless defined($next_nonblank_token);
+ return ( SPACE, $i ) unless defined($next_nonblank_token);
}
return ( $next_nonblank_token, $i );
-}
+} ## end sub find_next_nonblank_token
sub find_next_noncomment_type {
my ( $i, $rtokens, $max_token_index ) = @_;
find_next_nonblank_token( $i_next, $rtokens, $max_token_index );
}
- goto RETURN if ( !$next_nonblank_token || $next_nonblank_token eq " " );
+ goto RETURN if ( !$next_nonblank_token || $next_nonblank_token eq SPACE );
# check for possible a digraph
goto RETURN if ( !defined( $rtokens->[ $i_next + 1 ] ) );
RETURN:
return ( $next_nonblank_token, $i_next );
-}
+} ## end sub find_next_noncomment_type
sub is_possible_numerator {
}
return $is_possible_numerator;
-}
+} ## end sub is_possible_numerator
{ ## closure for sub pattern_expected
my %pattern_test;
}
}
return $is_pattern;
- }
+ } ## end sub pattern_expected
}
sub find_next_nonblank_token_on_this_line {
}
}
else {
- $next_nonblank_token = "";
+ $next_nonblank_token = EMPTY_STRING;
}
return ( $next_nonblank_token, $i );
-}
+} ## end sub find_next_nonblank_token_on_this_line
sub find_angle_operator_termination {
}
}
return ( $i, $type );
-}
+} ## end sub find_angle_operator_termination
sub scan_number_do {
if ($error) { warning("Possibly invalid number\n") }
return ( $i, $type, $number );
-}
+} ## end sub scan_number_do
sub inverse_pretoken_map {
}
}
return ( $i, $error );
-}
+} ## end sub inverse_pretoken_map
sub find_here_doc {
my ( $expecting, $i, $rtokens, $rtoken_map, $max_token_index ) = @_;
my $ibeg = $i;
my $found_target = 0;
- my $here_doc_target = '';
- my $here_quote_character = '';
+ my $here_doc_target = EMPTY_STRING;
+ my $here_quote_character = EMPTY_STRING;
my $saw_error = 0;
my ( $next_nonblank_token, $i_next_nonblank, $next_token );
$next_token = $rtokens->[ $i + 1 ];
return ( $found_target, $here_doc_target, $here_quote_character, $i,
$saw_error );
-}
+} ## end sub find_here_doc
sub do_quote {
$quoted_string_2 .= $quoted_string;
if ( $in_quote == 1 ) {
if ( $quote_character =~ /[\{\[\<\(]/ ) { $i++; }
- $quote_character = '';
+ $quote_character = EMPTY_STRING;
}
else {
$quoted_string_2 .= "\n";
}
return ( $i, $in_quote, $quote_character, $quote_pos, $quote_depth,
$quoted_string_1, $quoted_string_2 );
-}
+} ## end sub do_quote
sub follow_quoted_string {
= @_;
my ( $tok, $end_tok );
my $i = $i_beg - 1;
- my $quoted_string = "";
+ my $quoted_string = EMPTY_STRING;
0 && do {
print STDOUT
if ( $i > $max_token_index ) { $i = $max_token_index }
return ( $i, $in_quote, $beginning_tok, $quote_pos, $quote_depth,
$quoted_string );
-}
+} ## end sub follow_quoted_string
sub indicate_error {
my ( $msg, $line_number, $input_line, $pos, $carrat ) = @_;
$underline =~ s/\s*$//;
warning( $underline . "\n" );
return;
-}
+} ## end sub write_error_indicator_pair
sub make_numbered_line {
my $numbered_line = sprintf( "%d: ", $lineno );
$offset -= length($numbered_line);
$numbered_line .= $str;
- my $underline = " " x length($numbered_line);
+ my $underline = SPACE x length($numbered_line);
return ( $offset, $numbered_line, $underline );
-}
+} ## end sub make_numbered_line
sub write_on_underline {
}
substr( $underline, $pos, length($pos_chr) ) = $pos_chr;
return ($underline);
-}
+} ## end sub write_on_underline
sub pre_tokenize {
# We cannot do better than this yet because we might be in a quoted
# string or pattern. Caller sets $max_tokens_wanted to 0 to get all
# tokens.
+
+ # An advantage of doing this pre-tokenization step is that it keeps almost
+ # all of the regex work highly localized. A disadvantage is that in some
+ # very rare instances we will have to go back and split a pre-token.
my ( $str, $max_tokens_wanted ) = @_;
# we return references to these 3 arrays:
} while ( --$max_tokens_wanted != 0 );
return ( \@tokens, \@token_map, \@type );
-}
+} ## end sub pre_tokenize
sub show_tokens {
print STDOUT "$i:$len:$rtoken_map->[$i]:$rtokens->[$i]:\n";
}
return;
-}
+} ## end sub show_tokens
{ ## closure for sub matching end token
my %matching_end_token;
END_OF_LIST
return;
-}
+} ## end sub dump_token_types
BEGIN {
my @q;
my @digraphs = qw(
- .. :: << >> ** && .. || // -> => += -= .= %= &= |= ^= *= <>
+ .. :: << >> ** && || // -> => += -= .= %= &= |= ^= *= <>
<= >= == =~ !~ != ++ -- /= x= ~~ ~. |. &. ^.
);
@is_digraph{@digraphs} = (1) x scalar(@digraphs);
+ @q = qw(
+ . : < > * & | / - = + - % ^ ! x ~
+ );
+ @can_start_digraph{@q} = (1) x scalar(@q);
+
my @trigraphs = qw( ... **= <<= >>= &&= ||= //= <=> !~~ &.= |.= ^.= <<~);
@is_trigraph{@trigraphs} = (1) x scalar(@trigraphs);
@q = qw( sort map grep eval do );
@is_sort_map_grep_eval_do{@q} = (1) x scalar(@q);
+ @q = qw( sort map grep );
+ @is_sort_map_grep{@q} = (1) x scalar(@q);
+
%is_grep_alias = ();
# I'll build the list of keywords incrementally
delete $really_want_term{'F'}; # file test works on $_ if no following term
delete $really_want_term{'Y'}; # indirect object, too risky to check syntax;
# let perl do it
+ @q = qw(q qq qx qr s y tr m);
+ @is_q_qq_qx_qr_s_y_tr_m{@q} = (1) x scalar(@q);
+ # Note added 'qw' here
@q = qw(q qq qw qx qr s y tr m);
@is_q_qq_qw_qx_qr_s_y_tr_m{@q} = (1) x scalar(@q);
push @q, ',';
@is_comma_question_colon{@q} = (1) x scalar(@q);
+ @q = qw( if elsif unless );
+ @is_if_elsif_unless{@q} = (1) x scalar(@q);
+
+ @q = qw( ; t );
+ @is_semicolon_or_t{@q} = (1) x scalar(@q);
+
+ @q = qw( if elsif unless case when );
+ @is_if_elsif_unless_case_when{@q} = (1) x scalar(@q);
+
# Hash of other possible line endings which may occur.
# Keep these coordinated with the regex where this is used.
# Note: chr(13) = chr(015)="\r".
# These are keywords for which an arg may optionally be omitted. They are
# currently only used to disambiguate a ? used as a ternary from one used
- # as a (depricated) pattern delimiter. In the future, they might be used
+ # as a (deprecated) pattern delimiter. In the future, they might be used
# to give a warning about ambiguous syntax before a /.
# Note: split has been omitted (see not below).
my @keywords_taking_optional_arg = qw(
@is_keyword_taking_optional_arg{@keywords_taking_optional_arg} =
(1) x scalar(@keywords_taking_optional_arg);
- # This list is used to decide if a pattern delmited by question marks,
+ # This list is used to decide if a pattern delimited by question marks,
# ?pattern?, can follow one of these keywords. Note that from perl 5.22
# on, a ?pattern? is not recognized, so we can be much more strict than
# with a /pattern/. Note that 'split' is not in this list. In current
use strict;
use warnings;
use Carp;
-our $VERSION = '20220217';
+use English qw( -no_match_vars );
+our $VERSION = '20220613';
use Perl::Tidy::VerticalAligner::Alignment;
use Perl::Tidy::VerticalAligner::Line;
-use constant DEVEL_MODE => 0;
+use constant DEVEL_MODE => 0;
+use constant EMPTY_STRING => q{};
+use constant SPACE => q{ };
# The Perl::Tidy::VerticalAligner package collects output lines and
# attempts to line up certain common tokens, such as => and #, which are
#
# The sub valign_input collects lines into groups. When a group reaches
# the maximum possible size it is processed for alignment and output.
-# The maximum group size is reached whenerver there is a change in indentation
+# The maximum group size is reached whenever there is a change in indentation
# level, a blank line, a block comment, or an external flush call. The calling
# routine may also force a break in alignment at any time.
#
# Batch of lines being collected
$self->[_rgroup_lines_] = [];
$self->[_group_level_] = 0;
- $self->[_group_type_] = "";
+ $self->[_group_type_] = EMPTY_STRING;
$self->[_group_maximum_line_length_] = undef;
$self->[_zero_count_] = 0;
$self->[_comment_leading_space_count_] = 0;
# flush() is the external call to completely empty the pipeline.
my ($self) = @_;
- # push things out the pipline...
+ # push things out the pipeline...
# push out any current group lines
$self->_flush_group_lines();
my ($self) = @_;
$self->[_rgroup_lines_] = [];
- $self->[_group_type_] = "";
+ $self->[_group_type_] = EMPTY_STRING;
$self->[_zero_count_] = 0;
$self->[_comment_leading_space_count_] = 0;
$self->[_last_leading_space_count_] = 0;
}
sub get_input_stream_name {
- my $input_stream_name = "";
+ my $input_stream_name = EMPTY_STRING;
if ($logger_object) {
$input_stream_name = $logger_object->get_input_stream_name();
}
@is_closing_token{@q} = (1) x scalar(@q);
}
+#--------------------------------------------
+# VTFLAGS: Vertical tightness types and flags
+#--------------------------------------------
+# Vertical tightness is controlled by a 'type' and associated 'flags' for each
+# line. These values are set by sub Formatter::set_vertical_tightness_flags.
+# These are defined as follows:
+
+# Vertical Tightness Line Type Codes:
+# Type 0, no vertical tightness condition
+# Type 1, last token of this line is a non-block opening token
+# Type 2, first token of next line is a non-block closing
+# Type 3, isolated opening block brace
+# type 4, isolated closing block brace
+
+# Opening token flag values are the vertical tightness flags
+# 0 do not join with next line
+# 1 just one join per line
+# 2 any number of joins
+
+# Closing token flag values indicate spacing:
+# 0 = no space added before closing token
+# 1 = single space added before closing token
+
sub valign_input {
# Place one line in the current vertical group.
}
}
- # do not join an opening block brace with an unbalanced line
- # unless requested with a flag value of 2
+ # do not join an opening block brace (type 3, see VTFLAGS)
+ # with an unbalanced line unless requested with a flag value of 2
if ( $cached_line_type == 3
&& !$self->group_line_count()
&& $cached_line_opening_flag < 2
# --------------------------------------------------------------------
# Collect outdentable block COMMENTS
# --------------------------------------------------------------------
- my $is_blank_line = "";
+ my $is_blank_line = EMPTY_STRING;
if ( $self->[_group_type_] eq 'COMMENT' ) {
if (
(
if ( ( $jmax == 0 ) || ( $rtokens->[ $jmax - 1 ] ne '#' ) ) {
$jmax += 1;
$rtokens->[ $jmax - 1 ] = '#';
- $rfields->[$jmax] = '';
+ $rfields->[$jmax] = EMPTY_STRING;
$rfield_lengths->[$jmax] = 0;
$rpatterns->[$jmax] = '#';
}
leading_space_count => $leading_space_count,
outdent_long_lines => $outdent_long_lines,
list_seqno => $list_seqno,
- list_type => "",
+ list_type => EMPTY_STRING,
is_hanging_side_comment => $is_hanging_side_comment,
rvertical_tightness_flags => $rvertical_tightness_flags,
is_terminal_ternary => $is_terminal_ternary,
$rtokens->[ $jmax - 1 ] = $rtokens->[0];
$rpatterns->[ $jmax - 1 ] = $rpatterns->[0];
foreach my $j ( 1 .. $jmax - 1 ) {
- $rfields->[$j] = '';
+ $rfields->[$j] = EMPTY_STRING;
$rfield_lengths->[$j] = 0;
- $rtokens->[ $j - 1 ] = "";
- $rpatterns->[ $j - 1 ] = "";
+ $rtokens->[ $j - 1 ] = EMPTY_STRING;
+ $rpatterns->[ $j - 1 ] = EMPTY_STRING;
}
return 1;
}
( $raw_tok, $lev, $tag, $tok_count ) =
decode_alignment_token( $rtokens->[$_] );
if ( !$is_comma_token{$raw_tok} ) {
- $list_type = "";
+ $list_type = EMPTY_STRING;
last;
}
}
# look for the question mark after the :
my ($jquestion);
my $depth_question;
- my $pad = "";
+ my $pad = EMPTY_STRING;
my $pad_length = 0;
foreach my $j ( 0 .. $maximum_field_index - 1 ) {
my $tok = $rtokens_old->[$j];
$jquestion = $j;
if ( $rfields_old->[ $j + 1 ] =~ /^(\?\s*)/ ) {
$pad_length = length($1);
- $pad = " " x $pad_length;
+ $pad = SPACE x $pad_length;
}
else {
return; # shouldn't happen
my @field_lengths = @{$rfield_lengths};
EXPLAIN_TERNARY && do {
- local $" = '><';
+ local $LIST_SEPARATOR = '><';
print STDOUT "CURRENT FIELDS=<@{$rfields_old}>\n";
print STDOUT "CURRENT TOKENS=<@{$rtokens_old}>\n";
print STDOUT "CURRENT PATTERNS=<@{$rpatterns_old}>\n";
unshift( @patterns, @{$rpatterns_old}[ 0 .. $jquestion ] );
# insert appropriate number of empty fields
- splice( @fields, 1, 0, ('') x $jadd ) if $jadd;
- splice( @field_lengths, 1, 0, (0) x $jadd ) if $jadd;
+ splice( @fields, 1, 0, (EMPTY_STRING) x $jadd ) if $jadd;
+ splice( @field_lengths, 1, 0, (0) x $jadd ) if $jadd;
}
# handle sub-case of first field just equal to leading colon.
# leading token and inserting appropriate number of empty fields
splice( @tokens, 0, 1, @{$rtokens_old}[ 0 .. $jquestion ] );
splice( @patterns, 1, 0, @{$rpatterns_old}[ 1 .. $jquestion ] );
- splice( @fields, 1, 0, ('') x $jadd ) if $jadd;
- splice( @field_lengths, 1, 0, (0) x $jadd ) if $jadd;
+ splice( @fields, 1, 0, (EMPTY_STRING) x $jadd ) if $jadd;
+ splice( @field_lengths, 1, 0, (0) x $jadd ) if $jadd;
}
}
$jadd = $jquestion + 1;
$fields[0] = $pad . $fields[0];
$field_lengths[0] = $pad_length + $field_lengths[0];
- splice( @fields, 0, 0, ('') x $jadd ) if $jadd;
- splice( @field_lengths, 0, 0, (0) x $jadd ) if $jadd;
+ splice( @fields, 0, 0, (EMPTY_STRING) x $jadd ) if $jadd;
+ splice( @field_lengths, 0, 0, (0) x $jadd ) if $jadd;
}
EXPLAIN_TERNARY && do {
- local $" = '><';
+ local $LIST_SEPARATOR = '><';
print STDOUT "MODIFIED TOKENS=<@tokens>\n";
print STDOUT "MODIFIED PATTERNS=<@patterns>\n";
print STDOUT "MODIFIED FIELDS=<@fields>\n";
my $jadd = $jbrace - $jparen;
splice( @{$rtokens}, 0, 0, @{$rtokens_old}[ $jparen .. $jbrace - 1 ] );
splice( @{$rpatterns}, 1, 0, @{$rpatterns_old}[ $jparen + 1 .. $jbrace ] );
- splice( @{$rfields}, 1, 0, ('') x $jadd );
+ splice( @{$rfields}, 1, 0, (EMPTY_STRING) x $jadd );
splice( @{$rfield_lengths}, 1, 0, (0) x $jadd );
# force a flush after this line if it does not follow a case
my $imax_align = -1;
# variable $GoToMsg explains reason for no match, for debugging
- my $GoToMsg = "";
+ my $GoToMsg = EMPTY_STRING;
use constant EXPLAIN_CHECK_MATCH => 0;
# This is a flag for testing alignment by sub sweep_left_to_right only.
sub dump_array {
# debug routine to dump array contents
- local $" = ')(';
+ local $LIST_SEPARATOR = ')(';
print STDOUT "(@_)\n";
return;
}
# If this line has no matching tokens, then flush out the lines
# BEFORE this line unless both it and the previous line have side
- # comments. This prevents this line from pushing side coments out
+ # comments. This prevents this line from pushing side comments out
# to the right.
elsif ( $new_line->get_jmax() == 1 ) {
# two isolated (list) lines
# imax_min = number of common alignment tokens
# Return:
- # $pad_max = maximum suggested pad distnce
+ # $pad_max = maximum suggested pad distance
# = 0 if alignment not recommended
# Note that this is only for two lines which do not have alignment tokens
# in common with any other lines. It is intended for lists, but it might
my $lensum_m = 0;
my $lensum = 0;
- for ( my $i = 0 ; $i <= $imax_min ; $i++ ) {
+ foreach my $i ( 0 .. $imax_min ) {
$lensum_m += $rfield_lengths_m->[$i];
$lensum += $rfield_lengths->[$i];
}
$patterns_match = 1;
my $rpatterns_m = $line_m->get_rpatterns();
my $rpatterns = $line->get_rpatterns();
- for ( my $i = 0 ; $i <= $imax_min ; $i++ ) {
+ foreach my $i ( 0 .. $imax_min ) {
my $pat = $rpatterns->[$i];
my $pat_m = $rpatterns_m->[$i];
if ( $pat ne $pat_m ) { $patterns_match = 0; last }
# my $unknown6 = pack( "VV", 0x00, 0x1000 );
# On the other hand, it is okay to keep matching at the same
- # level such as in a simple list of commas and/or fat arrors.
+ # level such as in a simple list of commas and/or fat commas.
my $is_blocked = defined( $blocking_level[$ng] )
&& $lev > $blocking_level[$ng];
# Do not let one or two lines with a **different number of
# alignments** open up a big gap in a large block. For
# example, we will prevent something like this, where the first
- # line prys open the rest:
+ # line pries open the rest:
# $worksheet->write( "B7", "http://www.perl.com", undef, $format );
# $worksheet->write( "C7", "", $format );
use constant EXPLAIN_DELETE_SELECTED => 0;
- local $" = '> <';
+ local $LIST_SEPARATOR = '> <';
EXPLAIN_DELETE_SELECTED && print <<EOM;
delete indexes: <@{$ridel}>
old jmax: $jmax_old
my %delete_me;
@delete_me{ @{$ridel} } = (1) x scalar( @{$ridel} );
- my $pattern = $rpatterns_old->[0];
- my $field = $rfields_old->[0];
- my $field_length = $rfield_lengths_old->[0];
- push @{$rfields_new}, $field;
- push @{$rfield_lengths_new}, $field_length;
- push @{$rpatterns_new}, $pattern;
+ my $pattern_0 = $rpatterns_old->[0];
+ my $field_0 = $rfields_old->[0];
+ my $field_length_0 = $rfield_lengths_old->[0];
+ push @{$rfields_new}, $field_0;
+ push @{$rfield_lengths_new}, $field_length_0;
+ push @{$rpatterns_new}, $pattern_0;
# Loop to either copy items or concatenate fields and patterns
my $jmin_del;
- for ( my $j = 0 ; $j < $jmax_old ; $j++ ) {
+ foreach my $j ( 0 .. $jmax_old - 1 ) {
my $token = $rtokens_old->[$j];
my $field = $rfields_old->[ $j + 1 ];
my $field_length = $rfield_lengths_old->[ $j + 1 ];
# An existing list will still be a list but with possibly different
# leading token
my $old_list_type = $line_obj->get_list_type();
- my $new_list_type = "";
+ my $new_list_type = EMPTY_STRING;
if ( $rtokens_new->[0] =~ /^(=>|,)/ ) {
$new_list_type = $rtokens_new->[0];
}
return @{ $decoded_token{$tok} };
}
- my ( $raw_tok, $lev, $tag, $tok_count ) = ( $tok, 0, "", 1 );
+ my ( $raw_tok, $lev, $tag, $tok_count ) = ( $tok, 0, EMPTY_STRING, 1 );
if ( $tok =~ /^(\D+)(\d+)([^\.]*)(\.(\d+))?$/ ) {
$raw_tok = $1;
$lev = $2;
my @equals_info;
my @line_info;
- my %is_good_tok;
# create a hash of tokens for each line
my $rline_hashes = [];
# compare each line pair and record matches
my $rtok_hash = {};
my $nr = 0;
- for ( my $jl = 0 ; $jl < $jmax ; $jl++ ) {
+ foreach my $jl ( 0 .. $jmax - 1 ) {
my $nl = $nr;
$nr = 0;
my $jr = $jl + 1;
# find subgroups
my @subgroups;
push @subgroups, [ 0, $jmax ];
- for ( my $jl = 0 ; $jl < $jmax ; $jl++ ) {
+ foreach my $jl ( 0 .. $jmax - 1 ) {
if ( $rnew_lines->[$jl]->get_end_group() ) {
$subgroups[-1]->[1] = $jl;
push @subgroups, [ $jl + 1, $jmax ];
my %token_line_count;
if ( $nlines > 2 ) {
- for ( my $jj = $jbeg ; $jj <= $jend ; $jj++ ) {
+ foreach my $jj ( $jbeg .. $jend ) {
my %seen;
my $line = $rnew_lines->[$jj];
my $rtokens = $line->get_rtokens();
#####################################################
# Loop over lines to remove unwanted alignment tokens
#####################################################
- for ( my $jj = $jbeg ; $jj <= $jend ; $jj++ ) {
+ foreach my $jj ( $jbeg .. $jend ) {
my $line = $rnew_lines->[$jj];
my $rtokens = $line->get_rtokens();
my $rhash = $rline_hashes->[$jj];
my $delete_above_level;
my $deleted_assignment_token;
- my $saw_dividing_token = "";
+ my $saw_dividing_token = EMPTY_STRING;
$saw_large_group ||= $nlines > 2 && $imax > 1;
# Loop over all alignment tokens
- for ( my $i = 0 ; $i <= $imax ; $i++ ) {
+ foreach my $i ( 0 .. $imax ) {
my $tok = $rtokens->[$i];
next if ( $tok eq '#' ); # shouldn't happen
my ( $iii, $il, $ir, $raw_tok, $lev, $tag, $tok_count ) =
$j_match_end = $jj;
# Keep track of any padding that would be needed for each token
- for ( my $i = 0 ; $i <= $imax ; $i++ ) {
+ foreach my $i ( 0 .. $imax ) {
next if ( $rneed_pad->[$i] );
my $length = $rfield_lengths->[$i];
my $length_match = $rfield_lengths_match->[$i];
);
# Note that we are skipping the token at i=0
- for ( my $i = 1 ; $i <= $imax_match ; $i++ ) {
+ foreach my $i ( 1 .. $imax_match ) {
# do not delete a token which requires padding to align
next if ( $rneed_pad->[$i] );
my $nlines = $jend - $jbeg + 1;
next unless ( $nlines > 2 );
- for ( my $jj = $jbeg ; $jj <= $jend ; $jj++ ) {
+ foreach my $jj ( $jbeg .. $jend ) {
my $line = $rnew_lines->[$jj];
$rtokens = $line->get_rtokens();
$rfield_lengths = $line->get_rfield_lengths();
# see if all tokens of this line match the current group
my $match;
if ( $imax == $imax_match ) {
- for ( my $i = 0 ; $i <= $imax ; $i++ ) {
+ foreach my $i ( 0 .. $imax ) {
my $tok = $rtokens->[$i];
my $tok_match = $rtokens_match->[$i];
last if ( $tok ne $tok_match );
# 2 = no match, and lines do not match at all
my ( $tok, $tok_m, $pat, $pat_m, $pad ) = @_;
- my $GoToMsg = "";
+ my $GoToMsg = EMPTY_STRING;
my $return_code = 1;
my ( $alignment_token, $lev, $tag, $tok_count ) =
# left with scalars on the left. We will also prevent
# any partial alignments.
- # set return code 2 if the = is at line level, but
- # set return code 1 if the = is below line level, i.e.
- # sub new { my ( $p, $v ) = @_; bless \$v, $p }
- # sub iter { my ($x) = @_; return undef if $$x < 0; return $$x--; }
+ # set return code 2 if the = is at line level, but
+ # set return code 1 if the = is below line level, i.e.
+ # sub new { my ( $p, $v ) = @_; bless \$v, $p }
+ # sub iter { my ($x) = @_; return undef if $$x < 0; return $$x--; }
elsif (
( index( $pat_m, ',' ) >= 0 ) ne ( index( $pat, ',' ) >= 0 ) )
next unless ( $nlines > 1 );
# loop over lines in a subgroup
- for ( my $jj = $jbeg ; $jj <= $jend ; $jj++ ) {
+ foreach my $jj ( $jbeg .. $jend ) {
$line_m = $line;
$rtokens_m = $rtokens;
if ($ci_jump) { $imax_min = -1 }
my $i_nomatch = $imax_min + 1;
- for ( my $i = 0 ; $i <= $imax_min ; $i++ ) {
+ foreach my $i ( 0 .. $imax_min ) {
my $tok = $rtokens->[$i];
my $tok_m = $rtokens_m->[$i];
if ( $tok ne $tok_m ) {
##################
else {
my $i_nomatch = $imax_min + 1;
- for ( my $i = 0 ; $i <= $imax_min ; $i++ ) {
+ foreach my $i ( 0 .. $imax_min ) {
my $tok = $rtokens->[$i];
my $tok_m = $rtokens_m->[$i];
if ( $tok ne $tok_m ) {
$tok, $tok_m, $pat, $pat_m, $pad
);
if ($match_code) {
- if ( $match_code eq 1 ) { $i_nomatch = $i }
- elsif ( $match_code eq 2 ) { $i_nomatch = 0 }
+ if ( $match_code == 1 ) { $i_nomatch = $i }
+ elsif ( $match_code == 2 ) { $i_nomatch = 0 }
last;
}
}
# $$d{"hours"} = [ "h", "hr", "hrs", "hour", "hours" ];
my @all_token_info;
my $all_monotonic = 1;
- for ( my $jj = 0 ; $jj < @{$rlines} ; $jj++ ) {
+ foreach my $jj ( 0 .. @{$rlines} - 1 ) {
my ($line) = $rlines->[$jj];
my $rtokens = $line->get_rtokens();
my $last_lev;
}
my $rline_values = [];
- for ( my $jj = 0 ; $jj < @{$rlines} ; $jj++ ) {
+ foreach my $jj ( 0 .. @{$rlines} - 1 ) {
my ($line) = $rlines->[$jj];
my $rtokens = $line->get_rtokens();
my $i = -1;
my ( $lev_min, $lev_max );
- my $token_pattern_max = "";
+ my $token_pattern_max = EMPTY_STRING;
my %saw_level;
- my @token_info;
my $is_monotonic = 1;
# find the index of the last token before the side comment
my $tok_end = fat_comma_to_comma( $rtokens->[$imax] );
if ( $all_monotonic && $tok_end =~ /^,/ ) {
- my $i = $imax - 1;
- while ( $i >= 0
- && fat_comma_to_comma( $rtokens->[$i] ) eq $tok_end )
+ my $ii = $imax - 1;
+ while ( $ii >= 0
+ && fat_comma_to_comma( $rtokens->[$ii] ) eq $tok_end )
{
- $imax = $i;
- $i--;
+ $imax = $ii;
+ $ii--;
}
}
$lev_min = -1;
$lev_max = -1;
$levs[0] = -1;
- $rtoken_patterns->{$lev_min} = "";
+ $rtoken_patterns->{$lev_min} = EMPTY_STRING;
$rtoken_indexes->{$lev_min} = [];
}
# debug
0 && do {
- local $" = ')(';
+ local $LIST_SEPARATOR = ')(';
print "lev_min=$lev_min, lev_max=$lev_max, levels=(@levs)\n";
foreach my $key ( sort keys %{$rtoken_patterns} ) {
print "$key => $rtoken_patterns->{$key}\n";
# );
# In the above example, all lines have three commas at the lowest depth
- # (zero), so if there were no other alignements, these lines would all
+ # (zero), so if there were no other alignments, these lines would all
# align considering only the zero depth alignment token. But some lines
# have additional comma alignments at the next depth, so we need to decide
# if we should drop those to keep the top level alignments, or keep those
######################################################
# Prune Tree Step 2. Loop to form the tree of matches.
######################################################
- for ( my $jp = 0 ; $jp <= $jmax ; $jp++ ) {
+ foreach my $jp ( 0 .. $jmax ) {
# working with two adjacent line indexes, 'm'=minus, 'p'=plus
my $jm = $jp - 1;
$levels_next[$MAX_DEPTH] = $rlevs->[-1];
}
my $depth = 0;
- foreach (@levels_next) {
+ foreach my $item (@levels_next) {
$token_patterns_next[$depth] =
- defined($_) ? $rtoken_patterns->{$_} : undef;
+ defined($item) ? $rtoken_patterns->{$item} : undef;
$token_indexes_next[$depth] =
- defined($_) ? $rtoken_indexes->{$_} : undef;
+ defined($item) ? $rtoken_indexes->{$item} : undef;
$depth++;
}
# construction. The children nodes have links up to the parent node which
# created them. Now make links in the opposite direction, so the parents
# can find the children. We store the range of children nodes ($nc_beg,
- # $nc_end) of each parent with two additional indexes in the orignal array.
+ # $nc_end) of each parent with two additional indexes in the original array.
# These will be undef if no children.
- for ( my $depth = $MAX_DEPTH ; $depth > 0 ; $depth-- ) {
+ foreach my $depth ( reverse( 1 .. $MAX_DEPTH ) ) {
next unless defined( $match_tree[$depth] );
my $nc_max = @{ $match_tree[$depth] } - 1;
my $np_now;
# $level_keep is the minimum level to keep
my @delete_list;
+ # Not currently used:
# Groups with ending comma lists and their range of sizes:
# $ragged_comma_group{$id} = [ imax_group_min, imax_group_max ]
- my %ragged_comma_group;
+ ## my %ragged_comma_group;
# Define a threshold line count for forcing a break
my $nlines_break = 3;
@todo_list = ( 0 .. @{ $match_tree[0] } - 1 );
}
- for ( my $depth = 0 ; $depth <= $MAX_DEPTH ; $depth++ ) {
+ foreach my $depth ( 0 .. $MAX_DEPTH ) {
last unless (@todo_list);
my @todo_next;
foreach my $np (@todo_list) {
my @idel;
my $rtokens = $line->get_rtokens();
my $imax = @{$rtokens} - 2;
- for ( my $i = 0 ; $i <= $imax ; $i++ ) {
+ foreach my $i ( 0 .. $imax ) {
my $tok = $rtokens->[$i];
my ( $raw_tok, $lev, $tag, $tok_count ) =
decode_alignment_token($tok);
sub Dump_tree_groups {
my ( $rgroup, $msg ) = @_;
print "$msg\n";
- local $" = ')(';
+ local $LIST_SEPARATOR = ')(';
foreach my $item ( @{$rgroup} ) {
my @fix = @{$item};
- foreach (@fix) { $_ = "undef" unless defined $_; }
+ foreach my $val (@fix) { $val = "undef" unless defined $val; }
$fix[4] = "...";
print "(@fix)\n";
}
# it seems that the an alignment would look bad.
my $max_pad = 0;
my $saw_good_alignment = 0;
- my $saw_if_or; # if we saw an 'if' or 'or' at group level
- my $raw_tokb = ""; # first token seen at group level
+ my $saw_if_or; # if we saw an 'if' or 'or' at group level
+ my $raw_tokb = EMPTY_STRING; # first token seen at group level
my $jfirst_bad;
my $line_ending_fat_comma; # is last token just a '=>' ?
my $j0_eq_pad;
my $j0_max_pad = 0;
- for ( my $j = 0 ; $j < $jmax_1 - 1 ; $j++ ) {
+ foreach my $j ( 0 .. $jmax_1 - 2 ) {
my ( $raw_tok, $lev, $tag, $tok_count ) =
decode_alignment_token( $rtokens_1->[$j] );
if ( $raw_tok && $lev == $group_level ) {
# and fake side comments. This has the consequence that the lengths of
# long lines without real side comments can cause 'push' all side comments
# to the right. This seems unusual, but testing with and without this
- # feature shows that it is usually better this way. Othewise, side
+ # feature shows that it is usually better this way. Otherwise, side
# comments can be hidden between long lines without side comments and
# thus be harder to read.
# Count $num5 = number of comments in the 5 lines after the first comment
# This is an important factor in a decision formula
my $num5 = 1;
- for ( my $jj = $j_sc_beg + 1 ; $jj < @{$rlines} ; $jj++ ) {
+ foreach my $jj ( $j_sc_beg + 1 .. @{$rlines} - 1 ) {
my $ldiff = $jj - $j_sc_beg;
last if ( $ldiff > 5 );
my $line = $rlines->[$jj];
}
# Forget the old side comment location if necessary
- my $line = $rlines->[$j_sc_beg];
+ my $line_0 = $rlines->[$j_sc_beg];
my $lnum =
$j_sc_beg + $self->[_file_writer_object_]->get_output_line_number();
my $keep_it =
- $self->is_good_side_comment_column( $line, $lnum, $group_level, $num5 );
+ $self->is_good_side_comment_column( $line_0, $lnum, $group_level, $num5 );
my $last_side_comment_column =
$keep_it ? $self->[_last_side_comment_column_] : 0;
# Loop over passes
my $max_comment_column = $last_side_comment_column;
- for ( my $PASS = 1 ; $PASS <= $MAX_PASS ; $PASS++ ) {
+ foreach my $PASS ( 1 .. $MAX_PASS ) {
# If there are two passes, then on the last pass make the old column
# equal to the largest of the group. This will result in the comments
my $j_sc_last;
my $ng_last = $todo[-1];
my ( $jbeg, $jend ) = @{ $rgroups->[$ng_last] };
- for ( my $jj = $jend ; $jj >= $jbeg ; $jj-- ) {
+ foreach my $jj ( reverse( $jbeg .. $jend ) ) {
my $line = $rlines->[$jj];
my $jmax = $line->get_jmax();
if ( $line->get_rfield_lengths()->[$jmax] ) {
# only add padding when we have a finite field;
# this avoids extra terminal spaces if we have empty fields
if ( $rfield_lengths->[$j] > 0 ) {
- $str .= ' ' x $total_pad_count;
+ $str .= SPACE x $total_pad_count;
$str_len += $total_pad_count;
$total_pad_count = 0;
$str .= $rfields->[$j];
my $cached_seqno_string;
my $cached_line_Kend;
my $cached_line_maximum_length;
+
+ # These are passed to step_C:
my $seqno_string;
my $last_nonblank_seqno_string;
- sub get_seqno_string {
- return $seqno_string;
- }
-
- sub get_last_nonblank_seqno_string {
- return $last_nonblank_seqno_string;
- }
-
sub set_last_nonblank_seqno_string {
my ($val) = @_;
$last_nonblank_seqno_string = $val;
sub initialize_step_B_cache {
# valign_output_step_B cache:
- $cached_line_text = "";
+ $cached_line_text = EMPTY_STRING;
$cached_line_text_length = 0;
$cached_line_type = 0;
$cached_line_opening_flag = 0;
$cached_seqno = 0;
$cached_line_valid = 0;
$cached_line_leading_space_count = 0;
- $cached_seqno_string = "";
+ $cached_seqno_string = EMPTY_STRING;
$cached_line_Kend = undef;
$cached_line_maximum_length = undef;
# These vars hold a string of sequence numbers joined together used by
# the cache
- $seqno_string = "";
- $last_nonblank_seqno_string = "";
+ $seqno_string = EMPTY_STRING;
+ $last_nonblank_seqno_string = EMPTY_STRING;
return;
}
if ($cached_line_type) {
$seqno_string = $cached_seqno_string;
$self->valign_output_step_C(
+ $seqno_string,
+ $last_nonblank_seqno_string,
+
$cached_line_text,
$cached_line_leading_space_count,
$self->[_last_level_written_],
$cached_line_Kend,
);
$cached_line_type = 0;
- $cached_line_text = "";
+ $cached_line_text = EMPTY_STRING;
$cached_line_text_length = 0;
- $cached_seqno_string = "";
+ $cached_seqno_string = EMPTY_STRING;
$cached_line_Kend = undef;
$cached_line_maximum_length = undef;
}
# later by entabbing, so we have to keep track of any changes
# to the leading_space_count from here on.
my $leading_string =
- $leading_space_count > 0 ? ( ' ' x $leading_space_count ) : "";
+ $leading_space_count > 0
+ ? ( SPACE x $leading_space_count )
+ : EMPTY_STRING;
my $leading_string_length = length($leading_string);
# Unpack any recombination data; it was packed by
# Dump an invalid cached line
if ( !$cached_line_valid ) {
$self->valign_output_step_C(
- $cached_line_text, $cached_line_leading_space_count,
- $last_level_written, $cached_line_Kend
+ $seqno_string,
+ $last_nonblank_seqno_string,
+
+ $cached_line_text,
+ $cached_line_leading_space_count,
+ $last_level_written,
+ $cached_line_Kend
);
}
if ( $gap >= 0 && defined($seqno_beg) ) {
$maximum_line_length = $cached_line_maximum_length;
- $leading_string = $cached_line_text . ' ' x $gap;
+ $leading_string = $cached_line_text . SPACE x $gap;
$leading_string_length = $cached_line_text_length + $gap;
$leading_space_count = $cached_line_leading_space_count;
$seqno_string = $cached_seqno_string . ':' . $seqno_beg;
}
else {
$self->valign_output_step_C(
- $cached_line_text, $cached_line_leading_space_count,
- $last_level_written, $cached_line_Kend
+ $seqno_string,
+ $last_nonblank_seqno_string,
+
+ $cached_line_text,
+ $cached_line_leading_space_count,
+ $last_level_written,
+ $cached_line_Kend
);
}
}
# Handle cached line ending in CLOSING tokens
else {
my $test_line =
- $cached_line_text . ' ' x $cached_line_closing_flag . $str;
+ $cached_line_text . SPACE x $cached_line_closing_flag . $str;
my $test_line_length =
$cached_line_text_length +
$cached_line_closing_flag +
# Change the args to look like we received the combined line
$str = $test_line;
$str_length = $test_line_length;
- $leading_string = "";
+ $leading_string = EMPTY_STRING;
$leading_string_length = 0;
$leading_space_count = $cached_line_leading_space_count;
$level = $last_level_written;
}
else {
$self->valign_output_step_C(
- $cached_line_text, $cached_line_leading_space_count,
- $last_level_written, $cached_line_Kend
+ $seqno_string,
+ $last_nonblank_seqno_string,
+
+ $cached_line_text,
+ $cached_line_leading_space_count,
+ $last_level_written,
+ $cached_line_Kend
);
}
}
}
$cached_line_type = 0;
- $cached_line_text = "";
+ $cached_line_text = EMPTY_STRING;
$cached_line_text_length = 0;
$cached_line_Kend = undef;
$cached_line_maximum_length = undef;
# fix for case b999: do not cache an outdented line
if ( !$open_or_close || $side_comment_length > 0 || $is_outdented_line )
{
- $self->valign_output_step_C( $line, $leading_space_count, $level,
- $Kend );
+ $self->valign_output_step_C(
+ $seqno_string,
+ $last_nonblank_seqno_string,
+
+ $line,
+ $leading_space_count,
+ $level,
+ $Kend
+ );
}
else {
$cached_line_text = $line;
sub initialize_valign_buffer {
@valign_buffer = ();
- $valign_buffer_filling = "";
+ $valign_buffer_filling = EMPTY_STRING;
return;
}
}
@valign_buffer = ();
}
- $valign_buffer_filling = "";
+ $valign_buffer_filling = EMPTY_STRING;
return;
}
# The reason for storing lines is that we may later want to reduce their
# indentation when -sot and -sct are both used.
###############################################################
- my ( $self, @args ) = @_;
+ my (
+ $self,
+ $seqno_string,
+ $last_nonblank_seqno_string,
- my $seqno_string = get_seqno_string();
- my $last_nonblank_seqno_string = get_last_nonblank_seqno_string();
+ @args_to_D
+ ) = @_;
# Dump any saved lines if we see a line with an unbalanced opening or
# closing token.
# Either store or write this line
if ($valign_buffer_filling) {
- push @valign_buffer, [@args];
+ push @valign_buffer, [@args_to_D];
}
else {
- $self->valign_output_step_D(@args);
+ $self->valign_output_step_D(@args_to_D);
}
# For lines starting or ending with opening or closing tokens..
# opening tokens.
# patch for RT #94354, requested by Colin Williams
if ( $seqno_string =~ /^\d+(\:+\d+)+$/
- && $args[0] !~ /^[\}\)\]\:\?]/ )
+ && $args_to_D[0] !~ /^[\}\)\]\:\?]/ )
{
# This test is efficient but a little subtle: The first test
$leading_space_count % $rOpts_entab_leading_whitespace;
my $tab_count =
int( $leading_space_count / $rOpts_entab_leading_whitespace );
- my $leading_string = "\t" x $tab_count . ' ' x $space_count;
+ my $leading_string = "\t" x $tab_count . SPACE x $space_count;
if ( $line =~ /^\s{$leading_space_count,$leading_space_count}/ ) {
substr( $line, 0, $leading_space_count ) = $leading_string;
}
"Error entabbing in valign_output_step_D: for level=$level count=$leading_space_count\n"
);
}
- $leading_string = ( ' ' x $leading_space_count );
+ $leading_string = ( SPACE x $leading_space_count );
}
else {
- $leading_string .= ( ' ' x $space_count );
+ $leading_string .= ( SPACE x $space_count );
}
if ( $line =~ /^\s{$leading_space_count,$leading_space_count}/ ) {
substr( $line, 0, $leading_space_count ) = $leading_string;
# Handle case of zero whitespace, which includes multi-line quotes
# (which may have a finite level; this prevents tab problems)
if ( $leading_whitespace_count <= 0 ) {
- return "";
+ return EMPTY_STRING;
}
# look for previous result
if ( !( $rOpts_tabs || $rOpts_entab_leading_whitespace )
|| $rOpts_indent_columns <= 0 )
{
- $leading_string = ( ' ' x $leading_whitespace_count );
+ $leading_string = ( SPACE x $leading_whitespace_count );
}
# Handle entab option
$leading_whitespace_count % $rOpts_entab_leading_whitespace;
my $tab_count = int(
$leading_whitespace_count / $rOpts_entab_leading_whitespace );
- $leading_string = "\t" x $tab_count . ' ' x $space_count;
+ $leading_string = "\t" x $tab_count . SPACE x $space_count;
}
# Handle option of one tab per level
);
# -- skip entabbing
- $leading_string = ( ' ' x $leading_whitespace_count );
+ $leading_string = ( SPACE x $leading_whitespace_count );
}
else {
- $leading_string .= ( ' ' x $space_count );
+ $leading_string .= ( SPACE x $space_count );
}
}
$leading_string_cache[$leading_whitespace_count] = $leading_string;
{ #<<< A non-indenting brace
-our $VERSION = '20220217';
+our $VERSION = '20220613';
BEGIN {
package Perl::Tidy::VerticalAligner::Line;
use strict;
use warnings;
-our $VERSION = '20220217';
+our $VERSION = '20220613';
BEGIN {
params => "def",
expect => <<'#15...........',
# Keep the space before the '()' here:
-use Foo::Bar ();
-use Foo::Bar ();
+use Foo::Bar ();
+use Foo::Bar ();
use Foo::Bar 1.0 ();
-use Foo::Bar qw(baz);
+use Foo::Bar qw(baz);
use Foo::Bar 1.0 qw(baz);
#15...........
},
expect => <<'#5...........',
log_something_with_long_function ( 'This is a log message.', 2 );
Coro::AnyEvent::sleep ( 3, 4 );
-use Carp ();
+use Carp ();
use File::Spec ();
use File::Path ();
$self -> method ( 'parameter_0', 'parameter_1' );
#1 bal.bal2
#2 bal.def
#3 lpxl.lpxl6
+#4 c133.c133
+#5 c133.def
+#6 git93.def
+#7 git93.git93
+#8 c139.def
# To locate test #13 you can search for its name or the string '#13'
###########################################
$rparams = {
'bal2' => "-bal=2",
+ 'c133' => "-boc",
'def' => "",
+ 'git93' => <<'----------',
+-vxl='q'
+----------
'lpxl6' => <<'----------',
# equivalent to -lpxl='{ [ F(2'
-lp -lpil='f(2'
L2:
L3: return;
};
+----------
+
+ 'c133' => <<'----------',
+# this will make 1 line unless -boc is used
+return (
+ $x * cos($a) - $y * sin($a),
+ $x * sin($a) + $y * cos($a)
+);
+
+# broken list - issue c133
+return (
+ $x * cos($a) - $y * sin($a),
+ $x * sin($a) + $y * cos($a)
+
+);
+
+# no parens
+return
+ $x * cos($a) - $y * sin($a),
+ $x * sin($a) + $y * cos($a);
+----------
+
+ 'c139' => <<'----------',
+# The '&' has trailing spaces
+@l = &
+_
+( -49, -71 );
+
+# This '$' has trailing spaces
+my $
+b = 40;
+
+# this arrow has trailing spaces
+$r = $c->
+sql_set_env_attr( $evh, $SQL_ATTR_ODBC_VERSION, $SQL_OV_ODBC2, 0 );
+
+# spaces and blank line
+@l = &
+
+_
+( -49, -71 );
+
+# spaces and blank line
+$r = $c->
+
+sql_set_env_attr( $evh, $SQL_ATTR_ODBC_VERSION, $SQL_OV_ODBC2, 0 );
+----------
+
+ 'git93' => <<'----------',
+use Cwd qw[cwd];
+use Carp qw(carp);
+use IPC::Cmd qw{can_run run QUOTE};
+use File::Path qw/mkpath/;
+use File::Temp qw[tempdir];
+use Params::Check qw<check>;
+use Module::Load::Conditional qw#can_load#;
+use Locale::Maketext::Simple Style => 'gettext'; # does not align
+
+# do not align on these 'q' token types - not use statements...
+my $gene_color_sets = [
+ [ qw( blue blue blue blue ) => 'blue' ],
+ [ qw( brown blue blue blue ) => 'brown' ],
+ [ qw( brown brown green green ) => 'brown' ],
+];
+
+sub quux : PluginKeyword { 'quux' }
+sub qaax : PluginKeyword(qiix) { die "unimplemented" }
+
+use vars qw($curdir);
+no strict qw(vars);
----------
'lpxl' => <<'----------',
};
#3...........
},
+
+ 'c133.c133' => {
+ source => "c133",
+ params => "c133",
+ expect => <<'#4...........',
+# this will make 1 line unless -boc is used
+return (
+ $x * cos($a) - $y * sin($a),
+ $x * sin($a) + $y * cos($a)
+);
+
+# broken list - issue c133
+return (
+ $x * cos($a) - $y * sin($a),
+ $x * sin($a) + $y * cos($a)
+
+);
+
+# no parens
+return
+ $x * cos($a) - $y * sin($a),
+ $x * sin($a) + $y * cos($a);
+#4...........
+ },
+
+ 'c133.def' => {
+ source => "c133",
+ params => "def",
+ expect => <<'#5...........',
+# this will make 1 line unless -boc is used
+return ( $x * cos($a) - $y * sin($a), $x * sin($a) + $y * cos($a) );
+
+# broken list - issue c133
+return (
+ $x * cos($a) - $y * sin($a),
+ $x * sin($a) + $y * cos($a)
+
+);
+
+# no parens
+return
+ $x * cos($a) - $y * sin($a),
+ $x * sin($a) + $y * cos($a);
+#5...........
+ },
+
+ 'git93.def' => {
+ source => "git93",
+ params => "def",
+ expect => <<'#6...........',
+use Cwd qw[cwd];
+use Carp qw(carp);
+use IPC::Cmd qw{can_run run QUOTE};
+use File::Path qw/mkpath/;
+use File::Temp qw[tempdir];
+use Params::Check qw<check>;
+use Module::Load::Conditional qw#can_load#;
+use Locale::Maketext::Simple Style => 'gettext'; # does not align
+
+# do not align on these 'q' token types - not use statements...
+my $gene_color_sets = [
+ [ qw( blue blue blue blue ) => 'blue' ],
+ [ qw( brown blue blue blue ) => 'brown' ],
+ [ qw( brown brown green green ) => 'brown' ],
+];
+
+sub quux : PluginKeyword { 'quux' }
+sub qaax : PluginKeyword(qiix) { die "unimplemented" }
+
+use vars qw($curdir);
+no strict qw(vars);
+#6...........
+ },
+
+ 'git93.git93' => {
+ source => "git93",
+ params => "git93",
+ expect => <<'#7...........',
+use Cwd qw[cwd];
+use Carp qw(carp);
+use IPC::Cmd qw{can_run run QUOTE};
+use File::Path qw/mkpath/;
+use File::Temp qw[tempdir];
+use Params::Check qw<check>;
+use Module::Load::Conditional qw#can_load#;
+use Locale::Maketext::Simple Style => 'gettext'; # does not align
+
+# do not align on these 'q' token types - not use statements...
+my $gene_color_sets = [
+ [ qw( blue blue blue blue ) => 'blue' ],
+ [ qw( brown blue blue blue ) => 'brown' ],
+ [ qw( brown brown green green ) => 'brown' ],
+];
+
+sub quux : PluginKeyword { 'quux' }
+sub qaax : PluginKeyword(qiix) { die "unimplemented" }
+
+use vars qw($curdir);
+no strict qw(vars);
+#7...........
+ },
+
+ 'c139.def' => {
+ source => "c139",
+ params => "def",
+ expect => <<'#8...........',
+# The '&' has trailing spaces
+@l = &_( -49, -71 );
+
+# This '$' has trailing spaces
+my $b = 40;
+
+# this arrow has trailing spaces
+$r = $c->sql_set_env_attr( $evh, $SQL_ATTR_ODBC_VERSION, $SQL_OV_ODBC2, 0 );
+
+# spaces and blank line
+@l = &
+
+ _( -49, -71 );
+
+# spaces and blank line
+$r = $c->
+
+ sql_set_env_attr( $evh, $SQL_ATTR_ODBC_VERSION, $SQL_OV_ODBC2, 0 );
+#8...........
+ },
};
my $ntests = 0 + keys %{$rtests};
--- /dev/null
+use strict;
+use warnings;
+use utf8;
+
+use FindBin qw($Bin);
+use File::Temp qw(tempfile);
+use Test::More;
+
+BEGIN { unshift @INC, "./" }
+use Perl::Tidy;
+
+# This tests the -eos (--encode-output-strings) which was added for issue
+# git #83 to fix an issue with tidyall.
+
+# NOTE: to prevent automatic conversion of line endings LF to CRLF under github
+# Actions with Windows, which would cause test failure, it is essential that
+# there be a file 't/.gitattributes' with the line:
+# * -text
+
+# The test file has no tidying needs but is UTF-8 encoded, so all passes
+# through perltidy should read/write identical contents (previously only
+# file test behaved correctly)
+
+plan( tests => 6 );
+
+test_all();
+
+sub test_all {
+ my $test_file = "$Bin/testwide-passthrough.pl.src";
+ test_file2file($test_file);
+ test_scalar2scalar($test_file);
+ test_scalararray2scalararray($test_file);
+}
+
+sub test_file2file {
+ my $test_file = shift;
+
+ my $tmp_file = File::Temp->new( TMPDIR => 1 );
+
+ my $source = $test_file;
+ my $destination = $tmp_file->filename();
+
+ note("Testing file2file: '$source' => '$destination'\n");
+
+ my $tidyresult = Perl::Tidy::perltidy(
+ argv => '-utf8 -npro',
+ source => $source,
+ destination => $destination
+ );
+ ok( !$tidyresult, 'perltidy' );
+
+ my $source_str = slurp_raw($source);
+ my $destination_str = slurp_raw($destination);
+
+ my $source_hex = unpack( 'H*', $source_str );
+ my $destination_hex = unpack( 'H*', $destination_str );
+ note("Comparing contents:\n $source_hex\n $destination_hex\n");
+
+ ok( $source_hex eq $destination_hex, 'file content compare' );
+}
+
+sub test_scalar2scalar {
+ my $testfile = shift;
+
+ my $source = slurp_raw($testfile);
+ my $destination;
+
+ note("Testing scalar2scalar\n");
+
+ my $tidyresult = Perl::Tidy::perltidy(
+ argv => '-utf8 -eos -npro',
+ source => \$source,
+ destination => \$destination
+ );
+ ok( !$tidyresult, 'perltidy' );
+
+ my $source_hex = unpack( 'H*', $source );
+ my $destination_hex = unpack( 'H*', $destination );
+
+ note("Comparing contents:\n $source_hex\n $destination_hex\n");
+ ok( $source_hex eq $destination_hex, 'scalar content compare' );
+}
+
+sub test_scalararray2scalararray {
+ my $testfile = shift;
+
+ my $source = [ lines_raw($testfile) ];
+ my $destination = [];
+
+ note("Testing scalararray2scalararray\n");
+
+ my $tidyresult = Perl::Tidy::perltidy(
+ argv => '-utf8 -eos -npro',
+ source => $source,
+ destination => $destination
+ );
+ ok( !$tidyresult, 'perltidy' );
+
+ my $source_str = join( "", @$source );
+ my $destination_str = join( "", @$destination );
+
+ my $source_hex = unpack( 'H*', $source_str );
+ my $destination_hex = unpack( 'H*', $destination_str );
+
+ note("Comparing contents:\n $source_hex\n $destination_hex\n");
+ ok( $source_hex eq $destination_hex, 'scalararray content compare' );
+}
+
+sub slurp_raw {
+ my $filename = shift;
+
+ open( TMP, '<', $filename );
+ binmode( TMP, ':raw' );
+ local $/;
+ my $contents = <TMP>;
+ close(TMP);
+
+ return $contents;
+}
+
+sub lines_raw {
+ my $filename = shift;
+
+ open( TMP, '<', $filename );
+ binmode( TMP, ':raw' );
+ my @contents = <TMP>;
+ close(TMP);
+
+ return @contents;
+}
+++ /dev/null
-use strict;
-use warnings;
-use utf8;
-
-use FindBin qw($Bin);
-use File::Temp qw(tempfile);
-use Test::More;
-
-BEGIN { unshift @INC, "./" }
-use Perl::Tidy;
-
-# This tests the -eos (--encode-output-strings) which was added for issue
-# git #83 to fix an issue with tidyall.
-
-# NOTE: to prevent automatic conversion of line endings LF to CRLF under github
-# Actions with Windows, which would cause test failure, it is essential that
-# there be a file 't/.gitattributes' with the line:
-# * -text
-
-# The test file has no tidying needs but is UTF-8 encoded, so all passes
-# through perltidy should read/write identical contents (previously only
-# file test behaved correctly)
-
-plan( tests => 6 );
-
-test_all();
-
-sub test_all {
- my $test_file = "$Bin/testwide-passthrough.pl.src";
- test_file2file($test_file);
- test_scalar2scalar($test_file);
- test_scalararray2scalararray($test_file);
-}
-
-sub test_file2file {
- my $test_file = shift;
-
- my $tmp_file = File::Temp->new( TMPDIR => 1 );
-
- my $source = $test_file;
- my $destination = $tmp_file->filename();
-
- note("Testing file2file: '$source' => '$destination'\n");
-
- my $tidyresult = Perl::Tidy::perltidy(
- argv => '-utf8',
- source => $source,
- destination => $destination
- );
- ok( !$tidyresult, 'perltidy' );
-
- my $source_str = slurp_raw($source);
- my $destination_str = slurp_raw($destination);
-
- my $source_hex = unpack( 'H*', $source_str );
- my $destination_hex = unpack( 'H*', $destination_str );
- note("Comparing contents:\n $source_hex\n $destination_hex\n");
-
- ok( $source_hex eq $destination_hex, 'file content compare' );
-}
-
-sub test_scalar2scalar {
- my $testfile = shift;
-
- my $source = slurp_raw($testfile);
- my $destination;
-
- note("Testing scalar2scalar\n");
-
- my $tidyresult = Perl::Tidy::perltidy(
- argv => '-utf8 -eos',
- source => \$source,
- destination => \$destination
- );
- ok( !$tidyresult, 'perltidy' );
-
- my $source_hex = unpack( 'H*', $source );
- my $destination_hex = unpack( 'H*', $destination );
-
- note("Comparing contents:\n $source_hex\n $destination_hex\n");
- ok( $source_hex eq $destination_hex, 'scalar content compare' );
-}
-
-sub test_scalararray2scalararray {
- my $testfile = shift;
-
- my $source = [ lines_raw($testfile) ];
- my $destination = [];
-
- note("Testing scalararray2scalararray\n");
-
- my $tidyresult = Perl::Tidy::perltidy(
- argv => '-utf8 -eos',
- source => $source,
- destination => $destination
- );
- ok( !$tidyresult, 'perltidy' );
-
- my $source_str = join( "", @$source );
- my $destination_str = join( "", @$destination );
-
- my $source_hex = unpack( 'H*', $source_str );
- my $destination_hex = unpack( 'H*', $destination_str );
-
- note("Comparing contents:\n $source_hex\n $destination_hex\n");
- ok( $source_hex eq $destination_hex, 'scalararray content compare' );
-}
-
-sub slurp_raw {
- my $filename = shift;
-
- open( TMP, '<', $filename );
- binmode( TMP, ':raw' );
- local $/;
- my $contents = <TMP>;
- close(TMP);
-
- return $contents;
-}
-
-sub lines_raw {
- my $filename = shift;
-
- open( TMP, '<', $filename );
- binmode( TMP, ':raw' );
- my @contents = <TMP>;
- close(TMP);
-
- return @contents;
-}
--- /dev/null
+use strict;
+use warnings;
+use utf8;
+
+use FindBin qw($Bin);
+use File::Temp qw(tempfile);
+use Test::More;
+
+BEGIN { unshift @INC, "./" }
+use Perl::Tidy;
+
+# This tests the -eos (--encode-output-strings) which was added for issue
+# git #83 to fix an issue with tidyall.
+
+# NOTE: to prevent automatic conversion of line endings LF to CRLF under github
+# Actions with Windows, which would cause test failure, it is essential that
+# there be a file 't/.gitattributes' with the line:
+# * -text
+
+# The test file is UTF-8 encoded
+
+plan( tests => 6 );
+
+test_all();
+
+sub test_all {
+ my $test_file = "$Bin/testwide-tidy.pl.src";
+ my $tidy_file = "$Bin/testwide-tidy.pl.srctdy";
+ my $tidy_str = slurp_raw($tidy_file);
+ test_file2file( $test_file, $tidy_str );
+ test_scalar2scalar( $test_file, $tidy_str );
+ test_scalararray2scalararray( $test_file, $tidy_str );
+}
+
+sub test_file2file {
+ my $test_file = shift;
+ my $tidy_str = shift;
+ my $tidy_hex = unpack( 'H*', $tidy_str );
+
+ my $tmp_file = File::Temp->new( TMPDIR => 1 );
+
+ my $source = $test_file;
+ my $destination = $tmp_file->filename();
+
+ note("Testing file2file: '$source' => '$destination'\n");
+
+ my $tidyresult = Perl::Tidy::perltidy(
+ argv => '-utf8 -npro',
+ source => $source,
+ destination => $destination
+ );
+ ok( !$tidyresult, 'perltidy' );
+
+ my $destination_str = slurp_raw($destination);
+ my $destination_hex = unpack( 'H*', $destination_str );
+
+ note("Comparing contents:\n $tidy_hex\n $destination_hex\n");
+ ok($tidy_hex eq $destination_hex, 'file content compare');
+
+}
+
+sub test_scalar2scalar {
+ my $test_file = shift;
+ my $tidy_str = shift;
+ my $tidy_hex = unpack( 'H*', $tidy_str );
+
+ my $source = slurp_raw($test_file);
+ my $destination;
+
+ note("Testing scalar2scalar\n");
+
+ my $tidyresult = Perl::Tidy::perltidy(
+ argv => '-utf8 -eos -npro',
+ source => \$source,
+ destination => \$destination
+ );
+ ok( !$tidyresult, 'perltidy' );
+
+ my $destination_hex = unpack( 'H*', $destination );
+
+ note("Comparing contents:\n $tidy_hex\n $destination_hex\n");
+ ok($tidy_hex eq $destination_hex, 'scalar content compare');
+
+}
+
+sub test_scalararray2scalararray {
+ my $test_file = shift;
+ my $tidy_str = shift;
+ my $tidy_hex = unpack( 'H*', $tidy_str );
+
+ my $source = [ lines_raw($test_file) ];
+ my $destination = [];
+
+ note("Testing scalararray2scalararray\n");
+
+ my $tidyresult = Perl::Tidy::perltidy(
+ argv => '-utf8 -eos -npro',
+ source => $source,
+ destination => $destination
+ );
+ ok( !$tidyresult, 'perltidy' );
+
+ my $destination_str = join( '', @$destination );
+ my $destination_hex = unpack( 'H*', $destination_str );
+
+ note("Comparing contents:\n $tidy_hex\n $destination_hex\n");
+ ok($tidy_hex eq $destination_hex, 'scalararray content compare');
+}
+
+sub slurp_raw {
+ my $filename = shift;
+
+ open( TMP, '<', $filename );
+ binmode( TMP, ':raw' );
+ local $/;
+ my $contents = <TMP>;
+ close(TMP);
+
+ return $contents;
+}
+
+sub lines_raw {
+ my $filename = shift;
+
+ open( TMP, '<', $filename );
+ binmode( TMP, ':raw' );
+ my @contents = <TMP>;
+ close(TMP);
+
+ return @contents;
+}
+++ /dev/null
-use strict;
-use warnings;
-use utf8;
-
-use FindBin qw($Bin);
-use File::Temp qw(tempfile);
-use Test::More;
-
-BEGIN { unshift @INC, "./" }
-use Perl::Tidy;
-
-# This tests the -eos (--encode-output-strings) which was added for issue
-# git #83 to fix an issue with tidyall.
-
-# NOTE: to prevent automatic conversion of line endings LF to CRLF under github
-# Actions with Windows, which would cause test failure, it is essential that
-# there be a file 't/.gitattributes' with the line:
-# * -text
-
-# The test file is UTF-8 encoded
-
-plan( tests => 6 );
-
-test_all();
-
-sub test_all {
- my $test_file = "$Bin/testwide-tidy.pl.src";
- my $tidy_file = "$Bin/testwide-tidy.pl.srctdy";
- my $tidy_str = slurp_raw($tidy_file);
- test_file2file( $test_file, $tidy_str );
- test_scalar2scalar( $test_file, $tidy_str );
- test_scalararray2scalararray( $test_file, $tidy_str );
-}
-
-sub test_file2file {
- my $test_file = shift;
- my $tidy_str = shift;
- my $tidy_hex = unpack( 'H*', $tidy_str );
-
- my $tmp_file = File::Temp->new( TMPDIR => 1 );
-
- my $source = $test_file;
- my $destination = $tmp_file->filename();
-
- note("Testing file2file: '$source' => '$destination'\n");
-
- my $tidyresult = Perl::Tidy::perltidy(
- argv => '-utf8',
- source => $source,
- destination => $destination
- );
- ok( !$tidyresult, 'perltidy' );
-
- my $destination_str = slurp_raw($destination);
- my $destination_hex = unpack( 'H*', $destination_str );
-
- note("Comparing contents:\n $tidy_hex\n $destination_hex\n");
- ok($tidy_hex eq $destination_hex, 'file content compare');
-
-}
-
-sub test_scalar2scalar {
- my $test_file = shift;
- my $tidy_str = shift;
- my $tidy_hex = unpack( 'H*', $tidy_str );
-
- my $source = slurp_raw($test_file);
- my $destination;
-
- note("Testing scalar2scalar\n");
-
- my $tidyresult = Perl::Tidy::perltidy(
- argv => '-utf8 -eos',
- source => \$source,
- destination => \$destination
- );
- ok( !$tidyresult, 'perltidy' );
-
- my $destination_hex = unpack( 'H*', $destination );
-
- note("Comparing contents:\n $tidy_hex\n $destination_hex\n");
- ok($tidy_hex eq $destination_hex, 'scalar content compare');
-
-}
-
-sub test_scalararray2scalararray {
- my $test_file = shift;
- my $tidy_str = shift;
- my $tidy_hex = unpack( 'H*', $tidy_str );
-
- my $source = [ lines_raw($test_file) ];
- my $destination = [];
-
- note("Testing scalararray2scalararray\n");
-
- my $tidyresult = Perl::Tidy::perltidy(
- argv => '-utf8 -eos',
- source => $source,
- destination => $destination
- );
- ok( !$tidyresult, 'perltidy' );
-
- my $destination_str = join( '', @$destination );
- my $destination_hex = unpack( 'H*', $destination_str );
-
- note("Comparing contents:\n $tidy_hex\n $destination_hex\n");
- ok($tidy_hex eq $destination_hex, 'scalararray content compare');
-}
-
-sub slurp_raw {
- my $filename = shift;
-
- open( TMP, '<', $filename );
- binmode( TMP, ':raw' );
- local $/;
- my $contents = <TMP>;
- close(TMP);
-
- return $contents;
-}
-
-sub lines_raw {
- my $filename = shift;
-
- open( TMP, '<', $filename );
- binmode( TMP, ':raw' );
- my @contents = <TMP>;
- close(TMP);
-
- return @contents;
-}
use Test;
use Carp;
use FindBin;
-BEGIN {unshift @INC, "./"}
-BEGIN {plan tests => 3}
-use Perl::Tidy;
-
+BEGIN { unshift @INC, "./" }
+BEGIN { plan tests => 3 }
+use Perl::Tidy;
my $source = <<'EOM';
%pangrams=("Plain","ASCII",
"Любя, съешь щипцы, — вздохнёт мэр, — кайф жгуч.","RU");
EOM
-my $expected_output=<<'EOM';
+my $expected_output = <<'EOM';
%pangrams = (
"Plain", "ASCII",
"Zwölf große Boxkämpfer jagen Vik quer über den Sylter.", "DE",
my $output;
+# The source is in character mode here, so perltidy will not decode.
+# So here we do not need to set -eos or -neos
Perl::Tidy::perltidy(
source => \$source,
destination => \$output,
argv => '-nsyn',
);
-ok($output, $expected_output);
+ok( $output, $expected_output );
Perl::Tidy::perltidy(
source => $FindBin::Bin . '/testwide.pl.src',
argv => '-nsyn',
);
-ok($output, $expected_output);
+# We have to be careful here ... In this test we are comparing $output to a
+# source string which is in character mode (since it is in this file declared
+# with 'use utf8'). We need to compare strings which have the same storage
+# mode.
+
+# The internal storage mode of $output was character mode (decoded) for
+# vesions prior to 20220217.02, but is byte mode (encoded) for the latest
+# version of perltidy.
+
+# The following statement will decode $output if it is stored in byte mode,
+# and leave it unchanged (and return an error) otherwise. So this will work
+# with all version of perltidy. See https://perldoc.perl.org/utf8
+utf8::decode($output);
+
+ok( $output, $expected_output );
# Test writing encoded output to stdout with the -st flag
# References: RT #133166, RT #133171, git #35
source => \$source,
##destination => ... we are using -st, so no destination is specified
perltidyrc => \$perltidyrc,
- argv => '-nsyn -st', # added -st
+ argv => '-nsyn -st', # added -st
);
close STDOUT;
while ( my $line = <TMP> ) { $output .= $line }
};
-ok($output, $expected_output);
+ok( $output, $expected_output );
projects / perltidy.git / commitdiff