# Perltidy Change Log
+## 2019 06 01
+
+ - rt #128477: Prevent inconsistent owner/group and setuid/setgid bits.
+ In the -b (--backup-and-modify-in-place) mode, an attempt is made to set ownership
+ of the output file equal to the input file, if they differ.
+ In all cases, if the final output file ownership differs from input file, any setuid/setgid bits are cleared.
+
+ - Added option -bom (--break-at-old-method-breakpoints) by
+ merrillymeredith which preserves breakpoints of method chains. Modified to also handle a cuddled call style.
+
+ - Merged patch to fix Windows EOL translation error with UTF-8 written by
+ Ron Ivy. This update prevents automatic conversion to 'DOS' CRLF line
+ endings. Also, Windows system testing at the appveyor site is working again.
+
+ - RT #128280, added flag --one-line-block-semicolons=n (-olbs=n)
+ to control semicolons in one-line blocks. The values of n are:
+ n=0 means no semicolons termininating simple one-line blocks
+ n=1 means stable; do not change from input file [DEFAULT and current]
+ n=2 means always add semicolons in one-line blocks
+ The current behavior corresponds to the default n=1.
+
+ - RT #128216, Minor update to prevent inserting unwanted blank line at
+ indentation level change. This should not change existing scripts.
+
+ - RT #81852: Improved indentation when quoted word (qw) lists are
+ nested within other containers using the --weld-nested (-wn) flag.
+ The example given previously (below) is now closer to what it would
+ be with a simple list instead of qw:
+
+ # perltidy -wn
+ use_all_ok( qw{
+ PPI
+ PPI::Tokenizer
+ PPI::Lexer
+ PPI::Dumper
+ PPI::Find
+ PPI::Normal
+ PPI::Util
+ PPI::Cache
+ } );
+
+ - RT#12764, introduced new feature allowing placement of blanks around
+ sequences of selected keywords. This can be activated with the -kgb*
+ series of parameters described in the manual.
+
+ - Rewrote vertical algnment module. It is better at finding
+ patterns in complex code. For example,
+
+ OLD:
+ /^-std$/ && do { $std = 1; next; };
+ /^--$/ && do { @link_args = @argv; last; };
+ /^-I(.*)/ && do { $path = $1 || shift @argv; next; };
+
+ NEW:
+ /^-std$/ && do { $std = 1; next; };
+ /^--$/ && do { @link_args = @argv; last; };
+ /^-I(.*)/ && do { $path = $1 || shift @argv; next; };
+
+ - Add repository URLs to META files
+
+ - RT #118553, "leave only one newline at end of file". This option was not
+ added because of undesirable side effects, but a new filter script
+ was added which can do this, "examples/delete_ending_blank_lines.pl".
+
## 2018 11 20
- fix RT#127736 Perl-Tidy-20181119 has the EXE_FILES entry commented out in
docs/tutorial.html
examples/bbtidy.pl
examples/break_long_quotes.pl
+examples/delete_ending_blank_lines.pl
examples/ex_mp.pl
examples/filter_example.in
examples/filter_example.pl
t/snippets11.t
t/snippets12.t
t/snippets13.t
+t/snippets14.t
+t/snippets15.t
t/snippets2.t
t/snippets3.t
t/snippets4.t
t/snippets7.t
t/snippets8.t
t/snippets9.t
+t/test-eol.t
t/test.t
t/testsa.t
t/testss.t
"requires" : {
"ExtUtils::MakeMaker" : "0"
}
- },
- "runtime" : {
- "requires" : {}
}
},
"release_status" : "stable",
- "version" : "20181120"
+ "resources" : {
+ "repository" : {
+ "type" : "git",
+ "url" : "https://github.com/perltidy/perltidy.git",
+ "web" : "https://github.com/perltidy/perltidy"
+ }
+ },
+ "version" : "20190601"
}
directory:
- t
- inc
-requires: {}
-version: '20181120'
+resources:
+ repository: https://github.com/perltidy/perltidy.git
+version: '20190601'
: ()
),
- EXE_FILES => ['bin/perltidy'],
- dist => { COMPRESS => 'gzip', SUFFIX => 'gz' },
+ EXE_FILES => ['bin/perltidy'],
+ dist => { COMPRESS => 'gzip', SUFFIX => 'gz' },
+ META_MERGE => {
+ 'meta-spec' => { version => 2 },
+ resources => {
+ repository => {
+ type => 'git',
+ url => 'https://github.com/perltidy/perltidy.git',
+ web => 'https://github.com/perltidy/perltidy',
+ },
+ },
+ },
);
License -- please see the included file "COPYING" for details.
Documentation can be found at the web site [at GitHub](https://perltidy.github.io/perltidy/)
-or [at Sourceforge](perltidy.sourceforge.net)
+or [at Sourceforge](http://perltidy.sourceforge.net)
-A copy of the web site in contained in the docs folder of the distribution.
+A copy of the web site is contained in the docs folder of the distribution.
Name of the output file (only if a single input file is being
processed). If no output file is specified, and output is not
-redirected to the standard output, the output will go to F<filename.tdy>.
+redirected to the standard output (see B<-st>), the output will go to
+F<filename.tdy>. [Note: - does not redirect to standard output. Use
+B<-st> instead.]
=item B<-st>, B<--standard-output>
This format option is quite general but there are some limitations.
-One limitiation is that any line length limit still applies and can cause long
+One limitation is that any line length limit still applies and can cause long
welded sections to be broken into multiple lines.
Another limitation is that an opening symbol which delimits quoted text cannot
The flag B<-sot> is an abbreviation for B<-sop -sohb -sosb>.
-The flag B<-sobb> is a abbreviation for B<-bbvt=2 -bbvtl='*'>. This
+The flag B<-sobb> is an abbreviation for B<-bbvt=2 -bbvtl='*'>. This
will case a cascade of opening block braces to appear on a single line,
although this an uncommon occurrence except in test scripts.
at internal keywords C<if> and C<unless> will normally be retained.
To prevent this, and thus form longer lines, use B<-nbol>.
+=item B<-bom>, B<--break-at-old-method-breakpoints>
+
+By default, a method call arrow C<-E<gt>> is considered a candidate for
+a breakpoint, but method chains will fill to the line width before a break is
+considered. With B<-bom>, breaks before the arrow are preserved, so if you
+have preformatted a method chain:
+
+ my $q = $rs
+ ->related_resultset('CDs')
+ ->related_resultset('Tracks')
+ ->search({
+ 'track.id' => {-ident => 'none_search.id'},
+ })->as_query;
+
+It will B<keep> these breaks, rather than become this:
+
+ my $q = $rs->related_resultset('CDs')->related_resultset('Tracks')->search({
+ 'track.id' => {-ident => 'none_search.id'},
+ })->as_query;
+
+This flag will also look for and keep a 'cuddled' style of calls,
+in which lines begin with a closing paren followed by a call arrow,
+as in this example:
+
+ my $q = $rs->related_resultset(
+ 'CDs'
+ )->related_resultset(
+ 'Tracks'
+ )->search( {
+ 'track.id' => { -ident => 'none_search.id' },
+ } )->as_query;
+
+You may want to include the B<-weld-nested-containers> flag in this case to keep
+nested braces and parens together, as in the last line.
+
+
=item B<-bok>, B<--break-at-old-keyword-breakpoints>
By default, perltidy will retain a breakpoint before keywords which may
=back
+B<Controls for blank lines around lines of consecutive keywords>
+
+The parameters in this section provide some control over the placement of blank
+lines within and around groups of statements beginning with selected keywords.
+These blank lines are called here B<keyword group blanks>, and all of the
+parameters begin with B<--keyword-group-blanks*>, or B<-kgb*> for short. The
+default settings do not employ these controls but they can be enabled with the
+following parameters:
+
+B<-kgbl=s> or B<--keyword-group-blanks-list=s>; B<s> is a quoted string of keywords
+
+B<-kgbs=s> or B<--keyword-group-blanks-size=s>; B<s> gives the number of keywords required to form a group.
+
+B<-kgbb=n> or B<--keyword-group-blanks-before=n>; B<n> = (0, 1, or 2) controls a leading blank
+
+B<-kgba=n> or B<--keyword-group-blanks-after=n>; B<n> = (0, 1, or 2) controls a trailing blank
+
+B<-kgbi> or B<--keyword-group-blanks-inside> is a switch for adding blanks between subgroups
+
+B<-kgbd> or B<--keyword-group-blanks-delete> is a switch for removing initial blank lines between keywords
+
+B<-kgbr=n> or B<--keyword-group-blanks-repeat-count=n> can limit the number of times this logic is applied
+
+In addition, the following abbreviations are available to for simplified usage:
+
+B<-kgb> or B<--keyword-group-blanks> is short for B<-kgbb=2 -kgba=2 kgbi>
+
+B<-nkgb> or B<--nokeyword-group-blanks>, is short for B<-kgbb=1 -kgba=1 nkgbi>
+
+Before describing the meaning of the parameters in detail let us look at an
+example which is formatted with default parameter settings.
+
+ print "Entering test 2\n";
+ use Test;
+ use Encode qw(from_to encode decode
+ encode_utf8 decode_utf8
+ find_encoding is_utf8);
+ use charnames qw(greek);
+ my @encodings = grep( /iso-?8859/, Encode::encodings() );
+ my @character_set = ( '0' .. '9', 'A' .. 'Z', 'a' .. 'z' );
+ my @source = qw(ascii iso8859-1 cp1250);
+ my @destiny = qw(cp1047 cp37 posix-bc);
+ my @ebcdic_sets = qw(cp1047 cp37 posix-bc);
+ my $str = join( '', map( chr($_), 0x20 .. 0x7E ) );
+ return unless ($str);
+
+using B<perltidy -kgb> gives:
+
+ print "Entering test 2\n";
+ <----------this blank controlled by -kgbb
+ use Test;
+ use Encode qw(from_to encode decode
+ encode_utf8 decode_utf8
+ find_encoding is_utf8);
+ use charnames qw(greek);
+ <---------this blank controlled by -kgbi
+ my @encodings = grep( /iso-?8859/, Encode::encodings() );
+ my @character_set = ( '0' .. '9', 'A' .. 'Z', 'a' .. 'z' );
+ my @source = qw(ascii iso8859-1 cp1250);
+ my @destiny = qw(cp1047 cp37 posix-bc);
+ my @ebcdic_sets = qw(cp1047 cp37 posix-bc);
+ my $str = join( '', map( chr($_), 0x20 .. 0x7E ) );
+ <----------this blank controlled by -kgba
+ return unless ($str);
+
+Blank lines have been introduced around the B<my> and B<use> sequences. What
+happened is that the default keyword list includes B<my> and B<use> but not
+B<print> and B<return>. So a continuous sequence of nine B<my> and B<use>
+statements was located. This number exceeds the default threshold of five, so
+blanks were placed before and after the entire group. Then, since there was
+also a subsequence of six B<my> lines, a blank line was introduced to separate
+them.
+
+Finer control over blank placement can be achieved by using the individual
+parameters rather than the B<-kgb> flag. The individual controls are as follows.
+
+B<-kgbl=s> or B<--keyword-group-blanks-list=s>, where B<s> is a quoted string,
+defines the set of keywords which will be formed into groups. The string is a
+space separated list of keywords. The default set is B<s="use require local
+our my">, but any list of keywords may be used. Comment lines may also be included in a keyword group, even though they are not keywords. To include ordinary block comments, include the symbol B<BC>. To include static block comments (which normally begin with '##'), include the symbol B<SBC>.
+
+B<-kgbs=s> or B<--keyword-group-blanks-size=s>, where B<s> is a string
+describing the number of consecutive keyword statements forming a group. If
+B<s> is an integer then it is the minimum number required for a group. A
+maximum value may also be given with the format B<s=min.max>, where B<min> is
+the minimum number and B<max> is the maximum number, and the min and max values
+are separated by one or more dots. No groups will be found if the maximum is
+less than the minimum. The maximum is unlimited if not given. The default is
+B<s=5>. Some examples:
+
+ s min max number for group
+ 3 3 unlimited 3 or more
+ 1.1 1 1 1
+ 1..3 1 3 1 to 3
+ 1.0 1 0 (no match)
+
+
+B<-kgbb=n> or B<--keyword-group-blanks-before=n> specifies whether
+a blank should appear before the first line of the group, as follows:
+
+ n=0 => (delete) an existing blank line will be removed
+ n=1 => (stable) no change to the input file is made [DEFAULT]
+ n=2 => (insert) a blank line is introduced if possible
+
+B<-kgba=n> or B<--keyword-group-blanks-after=n> likewise specifies
+whether a blank should appear after the last line of the group, using the same
+scheme (0=delete, 1=stable, 2=insert).
+
+B<-kgbi> or B<--keyword-group-blanks-inside> controls
+the insertion of blank lines between the first and last statement of the entire
+group. If there is a continuous run of a single statement type with more than
+the minimum threshold number (as specified with B<-kgbs=s>) then this
+switch causes a blank line be inserted between this
+subgroup and the others. In the example above this happened between the
+B<use> and B<my> statements.
+
+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
+insertions are made when the parameter B<-kgbd> is set. The default is not to
+do this, B<-nkgbd>.
+
+B<-kgbr=n> or B<--keyword-group-blanks-repeat-count=n> specifies B<n>, the
+maximum number of times this logic will be applied to any file. The special
+value B<n=0> is the same as n=infinity which means it will be applied to an
+entire script [Default]. A value B<n=1> could be used to make it apply just
+one time for example. This might be useful for adjusting just the B<use>
+statements in the top part of a module for example.
+
+B<-kgb> or B<--keyword-group-blanks> is an abbreviation equivalent to setting
+B<-kgbb=1 -kgba=1 -kgbi>. This turns on keyword group formatting with a set of
+default values.
+
+B<-nkgb> or B<--nokeyword-group-blanks> is equivalent to B<-kgbb=0 -kgba
+nkgbi>. This flag turns off keyword group blank lines and is the default
+setting.
+
+Here are a few notes about the functioning of this technique.
+
+=over 4
+
+=item *
+
+These parameters are probably more useful as part of a major code reformatting
+operation rather than as a routine formatting operation.
+
+In particular, note that deleting old blank lines with B<-kgbd> is an
+irreversible operation so it should be applied with care. Existing blank lines
+may be serving an important role in controlling vertical alignment.
+
+=item *
+
+Conflicts which arise among these B<kgb*> parameters and other blank line
+controls are generally resolved by producing the maximum number of blank lines
+implied by any parameter.
+
+For example, if the flags B<--freeze-blank-lines>, or
+B<--keep-old-blank-lines=2>, are set, then they have priority over any blank
+line deletion implied by the B<-kgb> flags of this section, so no blank lines
+will be deleted.
+
+For another example, if a keyword group ends at a B<sub> and the flag B<kgba=0> requests no blank line there, but we also have B<--blank-lines-before-subs=2>, then two blank lines will still be introduced before the sub.
+
+=item *
+
+The introduction of blank lines does not occur if it would conflict with other
+input controls or code validity. For example, a blank line will not be placed
+within a here-doc or within a section of code marked with format skipping
+comments. And in general, a blank line will only be introduced at the end of a
+group if the next statement is a line of code.
+
+=item *
+
+The count which is used to determine the group size is not the number of lines
+but rather the total number of keywords which are found. Individual statements
+with a certain leading keyword may continue on multiple lines, but if any of
+these lines is nested more than one level deep then that group will be ended.
+
+=item *
+
+The search for groups of lines with similar leading keywords is based on the
+input source, not the final formatted source. Consequently, if the source code
+is badly formatted, it would be best to make a first formatting pass without
+these options.
+
+=back
+
=head2 Styles
A style refers to a convenient collection of existing parameters.
: ' elsewhere in this document'
);
+
+=item One-line blocks
+
+There are a few points to note regarding one-line blocks. A one-line
+block is something like this,
+
+ if ($x > 0) { $y = 1 / $x }
+
+where the contents within the curly braces is short enough to fit
+on a single line.
+
+With few exceptions, perltidy retains existing one-line blocks, if it
+is possible within the line-length constraint, but it does not attempt
+to form new ones. In other words, perltidy will try to follow the
+one-line block style of the input file.
+
+If an existing one-line block is longer than the maximum line length,
+however, it will be broken into multiple lines. When this happens, perltidy
+checks for and adds any optional terminating semicolon (unless the B<-nasc>
+option is used) if the block is a code block.
+
+The main exception is that perltidy will attempt to form new one-line
+blocks following the keywords C<map>, C<eval>, and C<sort>, because
+these code blocks are often small and most clearly displayed in a single
+line.
+
+One-line block rules can conflict with the cuddled-else option. When
+the cuddled-else option is used, perltidy retains existing one-line
+blocks, even if they do not obey cuddled-else formatting.
+
+Occasionally, when one-line blocks get broken because they exceed the
+available line length, the formatting will violate the requested brace style.
+If this happens, reformatting the script a second time should correct
+the problem.
+
+Sometimes it might be desirable to convert a script to have one-line blocks
+whenever possible. Although there is currently no flag for this, a simple
+workaround is to execute perltidy twice, once with the flag B<-noadd-newlines>
+and then once again with normal parameters, like this:
+
+ cat infile | perltidy -nanl | perltidy >outfile
+
+When executed on this snippet
+
+ if ( $? == -1 ) {
+ die "failed to execute: $!\n";
+ }
+ if ( $? == -1 ) {
+ print "Had enough.\n";
+ die "failed to execute: $!\n";
+ }
+
+the result is
+
+ if ( $? == -1 ) { die "failed to execute: $!\n"; }
+ if ( $? == -1 ) {
+ print "Had enough.\n";
+ die "failed to execute: $!\n";
+ }
+
+This shows that blocks with a single statement become one-line blocks.
+
+
+=item B<-olbs=n>, B<--one-line-block-semicolons=n>
+
+This flag controls the placement of semicolons at the end of one-line blocks.
+Semicolons are optional before a closing block brace, and frequently they are
+omitted at the end of a one-line block containing just a single statement.
+By default, perltidy follows the input file regarding these semicolons,
+but this behavior can be controlled by this flag. The values of n are:
+
+ n=0 remove terminal semicolons in one-line blocks having a single statement
+ n=1 stable; keep input file placement of terminal semicolons [DEFAULT ]
+ n=2 add terminal semicolons in all one-line blocks
+
+Note that the B<n=2> option has no effect if adding semicolons is prohibited
+with the B<-nasc> flag. Also not that while B<n=2> adds missing semicolons to
+all one-line blocks, regardless of complexity, the B<n=0> option only removes
+ending semicolons which terminate one-line blocks containing just one
+semicolon. So these two options are not exact inverses.
+
=back
+
=head2 Controlling Vertical Alignment
Vertical alignment refers to lining up certain symbols in list of consecutive
Another use for B<--mangle> is to combine it with B<-dac> to reduce
the file size of a perl script.
-=item One-line blocks
-
-There are a few points to note regarding one-line blocks. A one-line
-block is something like this,
-
- if ($x > 0) { $y = 1 / $x }
-
-where the contents within the curly braces is short enough to fit
-on a single line.
-
-With few exceptions, perltidy retains existing one-line blocks, if it
-is possible within the line-length constraint, but it does not attempt
-to form new ones. In other words, perltidy will try to follow the
-one-line block style of the input file.
-
-If an existing one-line block is longer than the maximum line length,
-however, it will be broken into multiple lines. When this happens, perltidy
-checks for and adds any optional terminating semicolon (unless the B<-nasc>
-option is used) if the block is a code block.
-
-The main exception is that perltidy will attempt to form new one-line
-blocks following the keywords C<map>, C<eval>, and C<sort>, because
-these code blocks are often small and most clearly displayed in a single
-line.
-
-One-line block rules can conflict with the cuddled-else option. When
-the cuddled-else option is used, perltidy retains existing one-line
-blocks, even if they do not obey cuddled-else formatting.
-
-Occasionally, when one-line blocks get broken because they exceed the
-available line length, the formatting will violate the requested brace style.
-If this happens, reformatting the script a second time should correct
-the problem.
-
=item Debugging
The following flags are available for debugging:
=head1 VERSION
-This man page documents perltidy version 20181120
+This man page documents perltidy version 20190601
=head1 BUG REPORTS
<h1>Perltidy Change Log</h1>
+<h2>2019 06 01</h2>
+
+<pre><code>- rt #128477: Prevent inconsistent owner/group and setuid/setgid bits.
+ In the -b (--backup-and-modify-in-place) mode, an attempt is made to set ownership
+ of the output file equal to the input file, if they differ.
+ In all cases, if the final output file ownership differs from input file, any setuid/setgid bits are cleared.
+
+- Added option -bom (--break-at-old-method-breakpoints) by
+ merrillymeredith which preserves breakpoints of method chains. Modified to also handle a cuddled call style.
+
+- Merged patch to fix Windows EOL translation error with UTF-8 written by
+ Ron Ivy. This update prevents automatic conversion to 'DOS' CRLF line
+ endings. Also, Windows system testing at the appveyor site is working again.
+
+- RT #128280, added flag --one-line-block-semicolons=n (-olbs=n)
+ to control semicolons in one-line blocks. The values of n are:
+ n=0 means no semicolons termininating simple one-line blocks
+ n=1 means stable; do not change from input file [DEFAULT and current]
+ n=2 means always add semicolons in one-line blocks
+ The current behavior corresponds to the default n=1.
+
+- RT #128216, Minor update to prevent inserting unwanted blank line at
+ indentation level change. This should not change existing scripts.
+
+- RT #81852: Improved indentation when quoted word (qw) lists are
+ nested within other containers using the --weld-nested (-wn) flag.
+ The example given previously (below) is now closer to what it would
+ be with a simple list instead of qw:
+
+ # perltidy -wn
+ use_all_ok( qw{
+ PPI
+ PPI::Tokenizer
+ PPI::Lexer
+ PPI::Dumper
+ PPI::Find
+ PPI::Normal
+ PPI::Util
+ PPI::Cache
+ } );
+
+- RT#12764, introduced new feature allowing placement of blanks around
+ sequences of selected keywords. This can be activated with the -kgb*
+ series of parameters described in the manual.
+
+- Rewrote vertical algnment module. It is better at finding
+ patterns in complex code. For example,
+
+OLD:
+ /^-std$/ && do { $std = 1; next; };
+ /^--$/ && do { @link_args = @argv; last; };
+ /^-I(.*)/ && do { $path = $1 || shift @argv; next; };
+
+NEW:
+ /^-std$/ && do { $std = 1; next; };
+ /^--$/ && do { @link_args = @argv; last; };
+ /^-I(.*)/ && do { $path = $1 || shift @argv; next; };
+
+- Add repository URLs to META files
+
+- RT #118553, "leave only one newline at end of file". This option was not
+ added because of undesirable side effects, but a new filter script
+ was added which can do this, "examples/delete_ending_blank_lines.pl".
+</code></pre>
+
<h2>2018 11 20</h2>
<pre><code>- fix RT#127736 Perl-Tidy-20181119 has the EXE_FILES entry commented out in
<dt id="dump_options">dump_options</dt>
<dd>
-<p>If the <b>dump_options</b> parameter is given, it must be the reference to a hash. In this case, the parameters contained in any perltidyrc configuration file will be placed in this hash and perltidy will return immediately. This is equivalent to running perltidy with --dump-options, except that the perameters are returned in a hash rather than dumped to standard output. Also, by default only the parameters in the perltidyrc file are returned, but this can be changed (see the next parameter). This parameter provides a convenient method for external programs to read a perltidyrc file. An example program using this feature, <i>perltidyrc_dump.pl</i>, is included in the distribution.</p>
+<p>If the <b>dump_options</b> parameter is given, it must be the reference to a hash. In this case, the parameters contained in any perltidyrc configuration file will be placed in this hash and perltidy will return immediately. This is equivalent to running perltidy with --dump-options, except that the parameters are returned in a hash rather than dumped to standard output. Also, by default only the parameters in the perltidyrc file are returned, but this can be changed (see the next parameter). This parameter provides a convenient method for external programs to read a perltidyrc file. An example program using this feature, <i>perltidyrc_dump.pl</i>, is included in the distribution.</p>
<p>Any combination of the <b>dump_</b> parameters may be used together.</p>
<p>Parameters which control formatting may be passed in several ways: in a <i>.perltidyrc</i> configuration file, in the <b>perltidyrc</b> parameter, and in the <b>argv</b> parameter.</p>
-<p>The <b>-syn</b> (<b>--check-syntax</b>) flag may be used with all source and destination streams except for standard input and output. However data streams which are not associated with a filename will be copied to a temporary file before being be passed to Perl. This use of temporary files can cause somewhat confusing output from Perl.</p>
+<p>The <b>-syn</b> (<b>--check-syntax</b>) flag may be used with all source and destination streams except for standard input and output. However data streams which are not associated with a filename will be copied to a temporary file before being passed to Perl. This use of temporary files can cause somewhat confusing output from Perl.</p>
<p>If the <b>-pbp</b> style is used it will typically be necessary to also specify a <b>-nst</b> flag. This is necessary to turn off the <b>-st</b> flag contained in the <b>-pbp</b> parameter set which otherwise would direct the output stream to the standard output.</p>
<h1 id="VERSION">VERSION</h1>
-<p>This man page documents Perl::Tidy version 20181120</p>
+<p>This man page documents Perl::Tidy version 20190601</p>
<h1 id="LICENSE">LICENSE</h1>
<dt id="o-filename---outfile-filename"><b>-o</b>=filename, <b>--outfile</b>=filename</dt>
<dd>
-<p>Name of the output file (only if a single input file is being processed). If no output file is specified, and output is not redirected to the standard output, the output will go to <i>filename.tdy</i>.</p>
+<p>Name of the output file (only if a single input file is being processed). If no output file is specified, and output is not redirected to the standard output (see <b>-st</b>), the output will go to <i>filename.tdy</i>. [Note: - does not redirect to standard output. Use <b>-st</b> instead.]</p>
</dd>
<dt id="st---standard-output"><b>-st</b>, <b>--standard-output</b></dt>
<p>This format option is quite general but there are some limitations.</p>
-<p>One limitiation is that any line length limit still applies and can cause long welded sections to be broken into multiple lines.</p>
+<p>One limitation is that any line length limit still applies and can cause long welded sections to be broken into multiple lines.</p>
<p>Another limitation is that an opening symbol which delimits quoted text cannot be included in a welded pair. This is because quote delimiters are treated specially in perltidy.</p>
<p>The flag <b>-sot</b> is an abbreviation for <b>-sop -sohb -sosb</b>.</p>
-<p>The flag <b>-sobb</b> is a abbreviation for <b>-bbvt=2 -bbvtl='*'</b>. This will case a cascade of opening block braces to appear on a single line, although this an uncommon occurrence except in test scripts.</p>
+<p>The flag <b>-sobb</b> is an abbreviation for <b>-bbvt=2 -bbvtl='*'</b>. This will case a cascade of opening block braces to appear on a single line, although this an uncommon occurrence except in test scripts.</p>
</dd>
<dt id="sct---stack-closing-tokens-and-related-flags"><b>-sct</b>, <b>--stack-closing-tokens</b> and related flags</dt>
<p>By default, if a logical expression is broken at a <code>&&</code>, <code>||</code>, <code>and</code>, or <code>or</code>, then the container will remain broken. Also, breaks at internal keywords <code>if</code> and <code>unless</code> will normally be retained. To prevent this, and thus form longer lines, use <b>-nbol</b>.</p>
+</dd>
+<dt id="bom---break-at-old-method-breakpoints"><b>-bom</b>, <b>--break-at-old-method-breakpoints</b></dt>
+<dd>
+
+<p>By default, a method call arrow <code>-></code> is considered a candidate for a breakpoint, but method chains will fill to the line width before a break is considered. With <b>-bom</b>, breaks before the arrow are preserved, so if you have preformatted a method chain:</p>
+
+<pre><code> my $q = $rs
+ ->related_resultset('CDs')
+ ->related_resultset('Tracks')
+ ->search({
+ 'track.id' => {-ident => 'none_search.id'},
+ })->as_query;</code></pre>
+
+<p>It will <b>keep</b> these breaks, rather than become this:</p>
+
+<pre><code> my $q = $rs->related_resultset('CDs')->related_resultset('Tracks')->search({
+ 'track.id' => {-ident => 'none_search.id'},
+ })->as_query;</code></pre>
+
+<p>This flag will also look for and keep a 'cuddled' style of calls, in which lines begin with a closing paren followed by a call arrow, as in this example:</p>
+
+<pre><code> my $q = $rs->related_resultset(
+ 'CDs'
+ )->related_resultset(
+ 'Tracks'
+ )->search( {
+ 'track.id' => { -ident => 'none_search.id' },
+ } )->as_query;</code></pre>
+
+<p>You may want to include the <b>-weld-nested-containers</b> flag in this case to keep nested braces and parens together, as in the last line.</p>
+
</dd>
<dt id="bok---break-at-old-keyword-breakpoints"><b>-bok</b>, <b>--break-at-old-keyword-breakpoints</b></dt>
<dd>
</dd>
</dl>
+<p><b>Controls for blank lines around lines of consecutive keywords</b></p>
+
+<p>The parameters in this section provide some control over the placement of blank lines within and around groups of statements beginning with selected keywords. These blank lines are called here <b>keyword group blanks</b>, and all of the parameters begin with <b>--keyword-group-blanks*</b>, or <b>-kgb*</b> for short. The default settings do not employ these controls but they can be enabled with the following parameters:</p>
+
+<p><b>-kgbl=s</b> or <b>--keyword-group-blanks-list=s</b>; <b>s</b> is a quoted string of keywords</p>
+
+<p><b>-kgbs=s</b> or <b>--keyword-group-blanks-size=s</b>; <b>s</b> gives the number of keywords required to form a group.</p>
+
+<p><b>-kgbb=n</b> or <b>--keyword-group-blanks-before=n</b>; <b>n</b> = (0, 1, or 2) controls a leading blank</p>
+
+<p><b>-kgba=n</b> or <b>--keyword-group-blanks-after=n</b>; <b>n</b> = (0, 1, or 2) controls a trailing blank</p>
+
+<p><b>-kgbi</b> or <b>--keyword-group-blanks-inside</b> is a switch for adding blanks between subgroups</p>
+
+<p><b>-kgbd</b> or <b>--keyword-group-blanks-delete</b> is a switch for removing initial blank lines between keywords</p>
+
+<p><b>-kgbr=n</b> or <b>--keyword-group-blanks-repeat-count=n</b> can limit the number of times this logic is applied</p>
+
+<p>In addition, the following abbreviations are available to for simplified usage:</p>
+
+<p><b>-kgb</b> or <b>--keyword-group-blanks</b> is short for <b>-kgbb=2 -kgba=2 kgbi</b></p>
+
+<p><b>-nkgb</b> or <b>--nokeyword-group-blanks</b>, is short for <b>-kgbb=1 -kgba=1 nkgbi</b></p>
+
+<p>Before describing the meaning of the parameters in detail let us look at an example which is formatted with default parameter settings.</p>
+
+<pre><code> print "Entering test 2\n";
+ use Test;
+ use Encode qw(from_to encode decode
+ encode_utf8 decode_utf8
+ find_encoding is_utf8);
+ use charnames qw(greek);
+ my @encodings = grep( /iso-?8859/, Encode::encodings() );
+ my @character_set = ( '0' .. '9', 'A' .. 'Z', 'a' .. 'z' );
+ my @source = qw(ascii iso8859-1 cp1250);
+ my @destiny = qw(cp1047 cp37 posix-bc);
+ my @ebcdic_sets = qw(cp1047 cp37 posix-bc);
+ my $str = join( '', map( chr($_), 0x20 .. 0x7E ) );
+ return unless ($str);</code></pre>
+
+<p>using <b>perltidy -kgb</b> gives:</p>
+
+<pre><code> print "Entering test 2\n";
+ <----------this blank controlled by -kgbb
+ use Test;
+ use Encode qw(from_to encode decode
+ encode_utf8 decode_utf8
+ find_encoding is_utf8);
+ use charnames qw(greek);
+ <---------this blank controlled by -kgbi
+ my @encodings = grep( /iso-?8859/, Encode::encodings() );
+ my @character_set = ( '0' .. '9', 'A' .. 'Z', 'a' .. 'z' );
+ my @source = qw(ascii iso8859-1 cp1250);
+ my @destiny = qw(cp1047 cp37 posix-bc);
+ my @ebcdic_sets = qw(cp1047 cp37 posix-bc);
+ my $str = join( '', map( chr($_), 0x20 .. 0x7E ) );
+ <----------this blank controlled by -kgba
+ return unless ($str);</code></pre>
+
+<p>Blank lines have been introduced around the <b>my</b> and <b>use</b> sequences. What happened is that the default keyword list includes <b>my</b> and <b>use</b> but not <b>print</b> and <b>return</b>. So a continuous sequence of nine <b>my</b> and <b>use</b> statements was located. This number exceeds the default threshold of five, so blanks were placed before and after the entire group. Then, since there was also a subsequence of six <b>my</b> lines, a blank line was introduced to separate them.</p>
+
+<p>Finer control over blank placement can be achieved by using the individual parameters rather than the <b>-kgb</b> flag. The individual controls are as follows.</p>
+
+<p><b>-kgbl=s</b> or <b>--keyword-group-blanks-list=s</b>, where <b>s</b> is a quoted string, defines the set of keywords which will be formed into groups. The string is a space separated list of keywords. The default set is <b>s="use require local our my"</b>, but any list of keywords may be used. Comment lines may also be included in a keyword group, even though they are not keywords. To include ordinary block comments, include the symbol <b>BC</b>. To include static block comments (which normally begin with '##'), include the symbol <b>SBC</b>.</p>
+
+<p><b>-kgbs=s</b> or <b>--keyword-group-blanks-size=s</b>, where <b>s</b> is a string describing the number of consecutive keyword statements forming a group. If <b>s</b> is an integer then it is the minimum number required for a group. A maximum value may also be given with the format <b>s=min.max</b>, where <b>min</b> is the minimum number and <b>max</b> is the maximum number, and the min and max values are separated by one or more dots. No groups will be found if the maximum is less than the minimum. The maximum is unlimited if not given. The default is <b>s=5</b>. Some examples:</p>
+
+<pre><code> s min max number for group
+ 3 3 unlimited 3 or more
+ 1.1 1 1 1
+ 1..3 1 3 1 to 3
+ 1.0 1 0 (no match)
+ </code></pre>
+
+<p><b>-kgbb=n</b> or <b>--keyword-group-blanks-before=n</b> specifies whether a blank should appear before the first line of the group, as follows:</p>
+
+<pre><code> n=0 => (delete) an existing blank line will be removed
+ n=1 => (stable) no change to the input file is made [DEFAULT]
+ n=2 => (insert) a blank line is introduced if possible</code></pre>
+
+<p><b>-kgba=n</b> or <b>--keyword-group-blanks-after=n</b> likewise specifies whether a blank should appear after the last line of the group, using the same scheme (0=delete, 1=stable, 2=insert).</p>
+
+<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>-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>
+
+<p><b>-kgb</b> or <b>--keyword-group-blanks</b> is an abbreviation equivalent to setting <b>-kgbb=1 -kgba=1 -kgbi</b>. This turns on keyword group formatting with a set of default values.</p>
+
+<p><b>-nkgb</b> or <b>--nokeyword-group-blanks</b> is equivalent to <b>-kgbb=0 -kgba nkgbi</b>. This flag turns off keyword group blank lines and is the default setting.</p>
+
+<p>Here are a few notes about the functioning of this technique.</p>
+
+<ul>
+
+<li><p>These parameters are probably more useful as part of a major code reformatting operation rather than as a routine formatting operation.</p>
+
+<p>In particular, note that deleting old blank lines with <b>-kgbd</b> is an irreversible operation so it should be applied with care. Existing blank lines may be serving an important role in controlling vertical alignment.</p>
+
+</li>
+<li><p>Conflicts which arise among these <b>kgb*</b> parameters and other blank line controls are generally resolved by producing the maximum number of blank lines implied by any parameter.</p>
+
+<p>For example, if the flags <b>--freeze-blank-lines</b>, or <b>--keep-old-blank-lines=2</b>, are set, then they have priority over any blank line deletion implied by the <b>-kgb</b> flags of this section, so no blank lines will be deleted.</p>
+
+<p>For another example, if a keyword group ends at a <b>sub</b> and the flag <b>kgba=0</b> requests no blank line there, but we also have <b>--blank-lines-before-subs=2</b>, then two blank lines will still be introduced before the sub.</p>
+
+</li>
+<li><p>The introduction of blank lines does not occur if it would conflict with other input controls or code validity. For example, a blank line will not be placed within a here-doc or within a section of code marked with format skipping comments. And in general, a blank line will only be introduced at the end of a group if the next statement is a line of code.</p>
+
+</li>
+<li><p>The count which is used to determine the group size is not the number of lines but rather the total number of keywords which are found. Individual statements with a certain leading keyword may continue on multiple lines, but if any of these lines is nested more than one level deep then that group will be ended.</p>
+
+</li>
+<li><p>The search for groups of lines with similar leading keywords is based on the input source, not the final formatted source. Consequently, if the source code is badly formatted, it would be best to make a first formatting pass without these options.</p>
+
+</li>
+</ul>
+
<h2 id="Styles">Styles</h2>
<p>A style refers to a convenient collection of existing parameters.</p>
: ' elsewhere in this document'
);</code></pre>
+</dd>
+<dt id="One-line-blocks">One-line blocks</dt>
+<dd>
+
+<p>There are a few points to note regarding one-line blocks. A one-line block is something like this,</p>
+
+<pre><code> if ($x > 0) { $y = 1 / $x } </code></pre>
+
+<p>where the contents within the curly braces is short enough to fit on a single line.</p>
+
+<p>With few exceptions, perltidy retains existing one-line blocks, if it is possible within the line-length constraint, but it does not attempt to form new ones. In other words, perltidy will try to follow the one-line block style of the input file.</p>
+
+<p>If an existing one-line block is longer than the maximum line length, however, it will be broken into multiple lines. When this happens, perltidy checks for and adds any optional terminating semicolon (unless the <b>-nasc</b> option is used) if the block is a code block.</p>
+
+<p>The main exception is that perltidy will attempt to form new one-line blocks following the keywords <code>map</code>, <code>eval</code>, and <code>sort</code>, because these code blocks are often small and most clearly displayed in a single line.</p>
+
+<p>One-line block rules can conflict with the cuddled-else option. When the cuddled-else option is used, perltidy retains existing one-line blocks, even if they do not obey cuddled-else formatting.</p>
+
+<p>Occasionally, when one-line blocks get broken because they exceed the available line length, the formatting will violate the requested brace style. If this happens, reformatting the script a second time should correct the problem.</p>
+
+<p>Sometimes it might be desirable to convert a script to have one-line blocks whenever possible. Although there is currently no flag for this, a simple workaround is to execute perltidy twice, once with the flag <b>-noadd-newlines</b> and then once again with normal parameters, like this:</p>
+
+<pre><code> cat infile | perltidy -nanl | perltidy >outfile</code></pre>
+
+<p>When executed on this snippet</p>
+
+<pre><code> if ( $? == -1 ) {
+ die "failed to execute: $!\n";
+ }
+ if ( $? == -1 ) {
+ print "Had enough.\n";
+ die "failed to execute: $!\n";
+ }</code></pre>
+
+<p>the result is</p>
+
+<pre><code> if ( $? == -1 ) { die "failed to execute: $!\n"; }
+ if ( $? == -1 ) {
+ print "Had enough.\n";
+ die "failed to execute: $!\n";
+ }</code></pre>
+
+<p>This shows that blocks with a single statement become one-line blocks.</p>
+
+</dd>
+<dt id="olbs-n---one-line-block-semicolons-n"><b>-olbs=n</b>, <b>--one-line-block-semicolons=n</b></dt>
+<dd>
+
+<p>This flag controls the placement of semicolons at the end of one-line blocks. Semicolons are optional before a closing block brace, and frequently they are omitted at the end of a one-line block containing just a single statement. By default, perltidy follows the input file regarding these semicolons, but this behavior can be controlled by this flag. The values of n are:</p>
+
+<pre><code> n=0 remove terminal semicolons in one-line blocks having a single statement
+ n=1 stable; keep input file placement of terminal semicolons [DEFAULT ]
+ n=2 add terminal semicolons in all one-line blocks</code></pre>
+
+<p>Note that the <b>n=2</b> option has no effect if adding semicolons is prohibited with the <b>-nasc</b> flag. Also not that while <b>n=2</b> adds missing semicolons to all one-line blocks, regardless of complexity, the <b>n=0</b> option only removes ending semicolons which terminate one-line blocks containing just one semicolon. So these two options are not exact inverses.</p>
+
</dd>
</dl>
<p>Another use for <b>--mangle</b> is to combine it with <b>-dac</b> to reduce the file size of a perl script.</p>
-</dd>
-<dt id="One-line-blocks">One-line blocks</dt>
-<dd>
-
-<p>There are a few points to note regarding one-line blocks. A one-line block is something like this,</p>
-
-<pre><code> if ($x > 0) { $y = 1 / $x } </code></pre>
-
-<p>where the contents within the curly braces is short enough to fit on a single line.</p>
-
-<p>With few exceptions, perltidy retains existing one-line blocks, if it is possible within the line-length constraint, but it does not attempt to form new ones. In other words, perltidy will try to follow the one-line block style of the input file.</p>
-
-<p>If an existing one-line block is longer than the maximum line length, however, it will be broken into multiple lines. When this happens, perltidy checks for and adds any optional terminating semicolon (unless the <b>-nasc</b> option is used) if the block is a code block.</p>
-
-<p>The main exception is that perltidy will attempt to form new one-line blocks following the keywords <code>map</code>, <code>eval</code>, and <code>sort</code>, because these code blocks are often small and most clearly displayed in a single line.</p>
-
-<p>One-line block rules can conflict with the cuddled-else option. When the cuddled-else option is used, perltidy retains existing one-line blocks, even if they do not obey cuddled-else formatting.</p>
-
-<p>Occasionally, when one-line blocks get broken because they exceed the available line length, the formatting will violate the requested brace style. If this happens, reformatting the script a second time should correct the problem.</p>
-
</dd>
<dt id="Debugging">Debugging</dt>
<dd>
<h1 id="VERSION">VERSION</h1>
-<p>This man page documents perltidy version 20181120</p>
+<p>This man page documents perltidy version 20190601</p>
<h1 id="BUG-REPORTS">BUG REPORTS</h1>
--- /dev/null
+#!/usr/bin/perl -w
+use strict;
+
+# Example script for removing trailing blank lines of code from a perl script
+# This is from the examples/ directory of the perltidy distribution and may
+# be modified as needed.
+
+# This was written in response to RT #118553, "leave only one newline at end of file".
+# Adding the requested feature to perltidy itself would have very undesirable
+# side-effects when perltidy is operated from within an editor. So it is best
+# done with a separate filter script on entire files.
+
+# usage:
+# delete_ending_blank_lines.pl myfile.pl >myfile.new
+# delete_ending_blank_lines.pl <myfile.pl >myfile.new
+use Getopt::Std;
+use Perl::Tidy;
+use IO::File;
+$| = 1;
+use vars qw($opt_h);
+my $usage = <<EOM;
+ usage: $0 filename >outfile
+EOM
+getopts('h') or die "$usage";
+if ($opt_h) { die $usage }
+
+# Make the source for perltidy, which will be a filehandle
+# or just '-' if the source is stdin
+my ($file, $fh, $source);
+if ( @ARGV == 0 ) {
+ $source = '-';
+}
+elsif ( @ARGV == 1 ) {
+ $file = $ARGV[0];
+ $fh = IO::File->new( $file, 'r' );
+ unless ($fh) { die "cannot open '$file': $!\n" }
+ $source = $fh;
+}
+else { die $usage }
+
+# make the callback object
+my $formatter = MyFormatter->new();
+
+my $dest;
+
+# start perltidy, which will start calling our write_line()
+my $err=perltidy(
+ 'formatter' => $formatter, # callback object
+ 'source' => $source,
+ 'destination' => \$dest, # (not really needed)
+ 'argv' => "-npro -se", # dont need .perltidyrc
+ # errors to STDOUT
+);
+if ($err) {
+ die "Error calling perltidy\n";
+}
+$fh->close() if $fh;
+
+package MyFormatter;
+
+my @lines;
+
+sub new {
+ my ($class) = @_;
+ bless {}, $class;
+}
+
+sub write_line {
+
+ # This is called from perltidy line-by-line; we just save lines
+ my $self = shift;
+ my $line_of_tokens = shift;
+ push @lines, $line_of_tokens;
+}
+
+# called once after the last line of a file
+sub finish_formatting {
+ my $self = shift;
+
+ # remove all trailing blank lines of code
+ while (my $line_of_tokens = pop(@lines)) {
+ my $line_type = $line_of_tokens->{_line_type};
+ my $input_line = $line_of_tokens->{_line_text};
+ if ( $line_type eq 'CODE' ) {
+ chomp $input_line;
+ next unless ($input_line);
+ }
+ push @lines, $line_of_tokens;
+ last;
+ }
+
+ # write remaining lines
+ foreach my $line_of_tokens (@lines) {
+ my $line_type = $line_of_tokens->{_line_type};
+ my $input_line = $line_of_tokens->{_line_text};
+ print $input_line;
+ }
+ return;
+}
#
# perltidy - a perl script indenter and formatter
#
-# Copyright (c) 2000-2018 by Steve Hancock
+# Copyright (c) 2000-2019 by Steve Hancock
# Distributed under the GPL license agreement; see file COPYING
#
# This program is free software; you can redistribute it and/or modify
# Release version must be bumped, and it is probably past time for a
# release anyway.
- $VERSION = '20181120';
+ $VERSION = '20190601';
}
sub streamhandle {
sub find_input_line_ending {
# Peek at a file and return first line ending character.
- # Quietly return undef in case of any trouble.
+ # Return undefined value in case of any trouble.
my ($input_file) = @_;
my $ending;
my @parts = @_;
- #BEGIN { eval "require File::Spec"; $missing_file_spec = $@; }
BEGIN {
eval { require File::Spec };
$missing_file_spec = $@;
# Perl 5.004 systems may not have File::Spec so we'll make
# a simple try. We assume File::Basename is available.
- # return undef if not successful.
+ # return if not successful.
my $name = pop @parts;
my $path = join '/', @parts;
my $test_file = $path . $name;
while ( my $input_file = shift @ARGV ) {
my $fileroot;
- my $input_file_permissions;
+ my @input_file_stat;
#---------------------------------------------------------------
# prepare this input stream
}
# we should have a valid filename now
- $fileroot = $input_file;
- $input_file_permissions = ( stat $input_file )[2] & oct(7777);
+ $fileroot = $input_file;
+ @input_file_stat = stat($input_file);
if ( $^O eq 'VMS' ) {
( $fileroot, $dot ) = check_vms_filename($fileroot);
}
# do not overwrite input file with -o
- if ( defined($input_file_permissions)
- && ( $output_file eq $input_file ) )
- {
+ if ( @input_file_stat && ( $output_file eq $input_file ) ) {
Die("Use 'perltidy -b $input_file' to modify in-place\n");
}
}
if ( $rOpts->{'character-encoding'}
&& $rOpts->{'character-encoding'} eq 'utf8' )
{
- binmode $fout, ":encoding(UTF-8)";
+ binmode $fout, ":raw:encoding(UTF-8)";
}
else { binmode $fout }
}
# set output file permissions
if ( $output_file && -f $output_file && !-l $output_file ) {
- if ($input_file_permissions) {
+ if (@input_file_stat) {
- # give output script same permissions as input script, but
- # make it user-writable or else we can't run perltidy again.
- # Thus we retain whatever executable flags were set.
+ # Set file ownership and permissions
if ( $rOpts->{'format'} eq 'tidy' ) {
- chmod( $input_file_permissions | oct(600), $output_file );
+ my ( $mode_i, $uid_i, $gid_i ) =
+ @input_file_stat[ 2, 4, 5 ];
+ my ( $uid_o, $gid_o ) = ( stat($output_file) )[ 4, 5 ];
+ my $input_file_permissions = $mode_i & oct(7777);
+ my $output_file_permissions = $input_file_permissions;
+
+ #rt128477: avoid inconsistent owner/group and suid/sgid
+ if ( $uid_i != $uid_o || $gid_i != $gid_o ) {
+
+ # try to change owner and group to match input file if in -b mode
+ # note: chown returns number of files successfully changed
+ if ( $in_place_modify
+ && chown( $uid_i, $gid_i, $output_file ) )
+ {
+ # owner/group successfully changed
+ }
+ else {
+
+ # owner or group differ: do not copy suid and sgid
+ $output_file_permissions = $mode_i & oct(777);
+ if ( $input_file_permissions !=
+ $output_file_permissions )
+ {
+ Warn(
+"Unable to copy setuid and/or setgid bits for output file '$output_file'\n"
+ );
+ }
+ }
+ }
+
+ # Make the output file for rw unless we are in -b mode.
+ # Explanation: perltidy does not unlink existing output
+ # files before writing to them, for safety. If a
+ # designated output file exists and is not writable,
+ # perltidy will halt. This can prevent a data loss if a
+ # user accidentally enters "perltidy infile -o
+ # important_ro_file", or "perltidy infile -st
+ # >important_ro_file". But it also means that perltidy can
+ # get locked out of rerunning unless it marks its own
+ # output files writable. The alternative, of always
+ # unlinking the designated output file, is less safe and
+ # not always possible, except in -b mode, where there is an
+ # assumption that a previous backup can be unlinked even if
+ # not writable.
+ if ( !$in_place_modify ) {
+ $output_file_permissions |= oct(600);
+ }
+
+ if ( !chmod( $output_file_permissions, $output_file ) ) {
+
+ # couldn't change file permissions
+ my $operm = sprintf "%04o", $output_file_permissions;
+ Warn(
+"Unable to set permissions for output file '$output_file' to $operm\n"
+ );
+ }
}
# else use default permissions for html and any other format
$add_option->( 'break-after-all-operators', 'baao', '!' );
$add_option->( 'break-before-all-operators', 'bbao', '!' );
$add_option->( 'keep-interior-semicolons', 'kis', '!' );
+ $add_option->( 'one-line-block-semicolons', 'olbs', '=i' );
########################################
$category = 6; # Controlling list formatting
########################################
$add_option->( 'break-at-old-keyword-breakpoints', 'bok', '!' );
$add_option->( 'break-at-old-logical-breakpoints', 'bol', '!' );
+ $add_option->( 'break-at-old-method-breakpoints', 'bom', '!' );
$add_option->( 'break-at-old-ternary-breakpoints', 'bot', '!' );
$add_option->( 'break-at-old-attribute-breakpoints', 'boa', '!' );
$add_option->( 'ignore-old-breakpoints', 'iob', '!' );
$add_option->( 'maximum-consecutive-blank-lines', 'mbl', '=i' );
$add_option->( 'keep-old-blank-lines', 'kbl', '=i' );
+ $add_option->( 'keyword-group-blanks-list', 'kgbl', '=s' );
+ $add_option->( 'keyword-group-blanks-size', 'kgbs', '=s' );
+ $add_option->( 'keyword-group-blanks-repeat-count', 'kgbr', '=i' );
+ $add_option->( 'keyword-group-blanks-before', 'kgbb', '=i' );
+ $add_option->( 'keyword-group-blanks-after', 'kgba', '=i' );
+ $add_option->( 'keyword-group-blanks-inside', 'kgbi', '!' );
+ $add_option->( 'keyword-group-blanks-delete', 'kgbd', '!' );
+
$add_option->( 'blank-lines-after-opening-block', 'blao', '=i' );
$add_option->( 'blank-lines-before-closing-block', 'blbc', '=i' );
$add_option->( 'blank-lines-after-opening-block-list', 'blaol', '=s' );
'closing-side-comment-else-flag' => [ 0, 2 ],
'comma-arrow-breakpoints' => [ 0, 5 ],
+
+ 'keyword-group-blanks-before' => [ 0, 2 ],
+ 'keyword-group-blanks-after' => [ 0, 2 ],
);
# Note: we could actually allow negative ci if someone really wants it:
blanks-before-comments
blank-lines-before-subs=1
blank-lines-before-packages=1
+
+ keyword-group-blanks-size=5
+ keyword-group-blanks-repeat-count=0
+ keyword-group-blanks-before=1
+ keyword-group-blanks-after=1
+ nokeyword-group-blanks-inside
+ nokeyword-group-blanks-delete
+
block-brace-tightness=0
block-brace-vertical-tightness=0
brace-tightness=1
notabs
nowarning-output
character-encoding=none
+ one-line-block-semicolons=1
outdent-labels
outdent-long-quotes
outdent-long-comments
'noblanks-before-subs' => [qw(blbs=0 blbp=0)],
'nbbs' => [qw(blbs=0 blbp=0)],
+ 'keyword-group-blanks' => [qw(kgbb=2 kgbi kgba=2)],
+ 'kgb' => [qw(kgbb=2 kgbi kgba=2)],
+ 'nokeyword-group-blanks' => [qw(kgbb=1 nkgbi kgba=1)],
+ 'nkgb' => [qw(kgbb=1 nkgbi kgba=1)],
+
'break-at-old-trinary-breakpoints' => [qw(bot)],
'cti=0' => [qw(cpi=0 cbi=0 csbi=0)],
}
}
-# This is the original coding, which worked,
-# but I've rewritten it (above) to keep Perl-Critic from complaining
-# Keep for awhile.
-
-=pod
-sub process_command_line {
-
- my (
- $perltidyrc_stream, $is_Windows, $Windows_type,
- $rpending_complaint, $dump_options_type
- ) = @_;
-
- my $use_cache = !defined($perltidyrc_stream) && !$dump_options_type;
- if ($use_cache) {
- my $cache_key = join( chr(28), @ARGV );
- if ( my $result = $process_command_line_cache{$cache_key} ) {
- my ( $argv, @retvals ) = @{$result};
- @ARGV = @{$argv};
- return @retvals;
- }
- else {
- my @retvals = _process_command_line(@_);
- $process_command_line_cache{$cache_key} = [ \@ARGV, @retvals ]
- if $retvals[0]->{'memoize'};
- return @retvals;
- }
- }
- else {
- return _process_command_line(@_);
- }
-}
-=cut
-
# (note the underscore here)
sub _process_command_line {
$rOpts->{'check-syntax'} = 0;
}
+ ###########################################################################
# Added Dec 2017: Deactivating check-syntax for all systems for safety
# because unexpected results can occur when code in BEGIN blocks is
# executed. This flag was included to help check for perltidy mistakes,
# and may still be useful for debugging. To activate for testing comment
- # out the next three lines.
+ # out the next three lines. Also fix sub 'do_check_syntax' in this file.
+ ###########################################################################
else {
$rOpts->{'check-syntax'} = 0;
}
print STDOUT <<"EOM";
This is perltidy, v$VERSION
-Copyright 2000-2018, Steve Hancock
+Copyright 2000-2019, Steve Hancock
Perltidy is free software and may be copied under the terms of the GNU
General Public License, which is included in the distribution files.
-kis keep interior semicolons. Allows multiple statements per line.
-boc break at old comma breaks: turns off all automatic list formatting
-bol break at old logical breakpoints: or, and, ||, && (default)
+ -bom break at old method call breakpoints: ->
-bok break at old list keyword breakpoints such as map, sort (default)
-bot break at old conditional (ternary ?:) operator breakpoints (default)
-boa break at old attribute breakpoints
# the perl version number will be helpful for diagnosing the problem
$logger_object->write_logfile_entry( $^V . "\n" );
- ##qx/perl -v $error_redirection/ . "\n" );
}
}
else {
If the B<dump_options> parameter is given, it must be the reference to a hash.
In this case, the parameters contained in any perltidyrc configuration file
will be placed in this hash and perltidy will return immediately. This is
-equivalent to running perltidy with --dump-options, except that the perameters
+equivalent to running perltidy with --dump-options, except that the parameters
are returned in a hash rather than dumped to standard output. Also, by default
only the parameters in the perltidyrc file are returned, but this can be
changed (see the next parameter). This parameter provides a convenient method
The B<-syn> (B<--check-syntax>) flag may be used with all source and
destination streams except for standard input and output. However
data streams which are not associated with a filename will
-be copied to a temporary file before being be passed to Perl. This
+be copied to a temporary file before being passed to Perl. This
use of temporary files can cause somewhat confusing output from Perl.
If the B<-pbp> style is used it will typically be necessary to also
=head1 VERSION
-This man page documents Perl::Tidy version 20181120
+This man page documents Perl::Tidy version 20190601
=head1 LICENSE
package Perl::Tidy::Debugger;
use strict;
use warnings;
-our $VERSION = '20181120';
+our $VERSION = '20190601';
sub new {
package Perl::Tidy::DevNull;
use strict;
use warnings;
-our $VERSION = '20181120';
+our $VERSION = '20190601';
sub new { my $self = shift; return bless {}, $self }
sub print { return }
sub close { return }
package Perl::Tidy::Diagnostics;
use strict;
use warnings;
-our $VERSION = '20181120';
+our $VERSION = '20190601';
sub new {
package Perl::Tidy::FileWriter;
use strict;
use warnings;
-our $VERSION = '20181120';
+our $VERSION = '20190601';
# Maximum number of little messages; probably need not be changed.
my $MAX_NAG_MESSAGES = 6;
use strict;
use warnings;
use Carp;
-our $VERSION = '20181120';
+our $VERSION = '20190601';
# The Tokenizer will be loaded with the Formatter
##use Perl::Tidy::Tokenizer; # for is_keyword()
BEGIN {
+ # Codes for insertion and deletion of blanks
+ use constant DELETE => 0;
+ use constant STABLE => 1;
+ use constant INSERT => 2;
+
# Caution: these debug flags produce a lot of output
# They should all be 0 except when debugging small scripts
use constant FORMATTER_DEBUG_FLAG_RECOMBINE => 0;
%stack_closing_token
$block_brace_vertical_tightness_pattern
+ $keyword_group_list_pattern
+ $keyword_group_list_comment_pattern
$rOpts_add_newlines
$rOpts_add_whitespace
$rOpts_break_at_old_keyword_breakpoints
$rOpts_break_at_old_comma_breakpoints
$rOpts_break_at_old_logical_breakpoints
+ $rOpts_break_at_old_method_breakpoints
$rOpts_break_at_old_ternary_breakpoints
$rOpts_break_at_old_attribute_breakpoints
$rOpts_closing_side_comment_else_flag
$rOpts_stack_closing_block_brace
$rOpts_space_backslash_quote
$rOpts_whitespace_cycle
+ $rOpts_one_line_block_semicolons
%is_opening_type
%is_closing_type
sub Fault {
my ($msg) = @_;
- # "I've just picked up a fault in the AE35 unit" - 2001: A Space Odyssey ...
-
# This routine is called for errors that really should not occur
# except if there has been a bug introduced by a recent program change
my ( $package0, $filename0, $line0, $subroutine0 ) = caller(0);
return;
}
+sub keyword_group_scan {
+ my $self = shift;
+
+ # Manipulate blank lines around keyword groups (kgb* flags)
+ # Scan all lines looking for runs of consecutive lines beginning with
+ # selected keywords. Example keywords are 'my', 'our', 'local', ... but
+ # they may be anything. We will set flags requesting that blanks be
+ # inserted around and withing them according to input parameters. Note
+ # that we are scanning the lines as they came in in the input stream, so
+ # they are not necessarily well formatted.
+
+ # The output of this sub is a return hash ref whose keys are the indexes of
+ # lines after which we desire a blank line. For line index i:
+ # $rhash_of_desires->{$i} = 1 means we want a blank line AFTER line $i
+ # $rhash_of_desires->{$i} = 2 means we want blank line $i removed
+ my $rhash_of_desires = {};
+
+ my $Opt_blanks_before = $rOpts->{'keyword-group-blanks-before'}; # '-kgbb'
+ my $Opt_blanks_after = $rOpts->{'keyword-group-blanks-after'}; # '-kgba'
+ my $Opt_blanks_inside = $rOpts->{'keyword-group-blanks-inside'}; # '-kgbi'
+ my $Opt_blanks_delete = $rOpts->{'keyword-group-blanks-delete'}; # '-kgbd'
+ my $Opt_size = $rOpts->{'keyword-group-blanks-size'}; # '-kgbs'
+
+ # A range of sizes can be input with decimal notation like 'min.max' with
+ # any number of dots between the two numbers. Examples:
+ # string => min max matches
+ # 1.1 1 1 exactly 1
+ # 1.3 1 3 1,2, or 3
+ # 1..3 1 3 1,2, or 3
+ # 5 5 - 5 or more
+ # 6. 6 - 6 or more
+ # .2 - 2 up to 2
+ # 1.0 1 0 nothing
+ my ( $Opt_size_min, $Opt_size_max ) = split /\.+/, $Opt_size;
+ if ( $Opt_size_min && $Opt_size_min !~ /^\d+$/
+ || $Opt_size_max && $Opt_size_max !~ /^\d+$/ )
+ {
+ Warn(<<EOM);
+Unexpected value for -kgbs: '$Opt_size'; expecting 'min' or 'min.max';
+ignoring all -kgb flags
+EOM
+ return $rhash_of_desires;
+ }
+ $Opt_size_min = 1 unless ($Opt_size_min);
+
+ if ( $Opt_size_max && $Opt_size_max < $Opt_size_min ) {
+ return $rhash_of_desires;
+ }
+
+ # codes for $Opt_blanks_before and $Opt_blanks_after:
+ # 0 = never (delete if exist)
+ # 1 = stable (keep unchanged)
+ # 2 = always (insert if missing)
+
+ return $rhash_of_desires
+ unless $Opt_size_min > 0
+ && ( $Opt_blanks_before != 1
+ || $Opt_blanks_after != 1
+ || $Opt_blanks_inside
+ || $Opt_blanks_delete );
+
+ my $Opt_pattern = $keyword_group_list_pattern;
+ my $Opt_comment_pattern = $keyword_group_list_comment_pattern;
+ my $Opt_repeat_count =
+ $rOpts->{'keyword-group-blanks-repeat-count'}; # '-kgbr'
+
+ my $rlines = $self->{rlines};
+ my $rLL = $self->{rLL};
+ my $K_closing_container = $self->{K_closing_container};
+
+ # variables for the current group and subgroups:
+ my ( $ibeg, $iend, $count, $level_beg, $K_closing, @iblanks, @group,
+ @subgroup );
+
+ # Definitions:
+ # ($ibeg, $iend) = starting and ending line indexes of this entire group
+ # $count = total number of keywords seen in this entire group
+ # $level_beg = indententation level of this group
+ # @group = [ $i, $token, $count ] =list of all keywords & blanks
+ # @subgroup = $j, index of group where token changes
+ # @iblanks = line indexes of blank lines in input stream in this group
+ # where i=starting line index
+ # token (the keyword)
+ # count = number of this token in this subgroup
+ # j = index in group where token changes
+ #
+ # These vars will contain values for the most recently seen line:
+ my ( $line_type, $CODE_type, $K_first, $K_last );
+
+ my $number_of_groups_seen = 0;
+
+ ####################
+ # helper subroutines
+ ####################
+
+ my $insert_blank_after = sub {
+ my ($i) = @_;
+ $rhash_of_desires->{$i} = 1;
+ my $ip = $i + 1;
+ if ( defined( $rhash_of_desires->{$ip} )
+ && $rhash_of_desires->{$ip} == 2 )
+ {
+ $rhash_of_desires->{$ip} = 0;
+ }
+ return;
+ };
+
+ my $split_into_sub_groups = sub {
+
+ # place blanks around long sub-groups of keywords
+ # ...if requested
+ return unless ($Opt_blanks_inside);
+
+ # loop over sub-groups, index k
+ push @subgroup, scalar @group;
+ my $kbeg = 1;
+ my $kend = @subgroup - 1;
+ for ( my $k = $kbeg ; $k <= $kend ; $k++ ) {
+
+ # index j runs through all keywords found
+ my $j_b = $subgroup[ $k - 1 ];
+ my $j_e = $subgroup[$k] - 1;
+
+ # index i is the actual line number of a keyword
+ my ( $i_b, $tok_b, $count_b ) = @{ $group[$j_b] };
+ my ( $i_e, $tok_e, $count_e ) = @{ $group[$j_e] };
+ my $num = $count_e - $count_b + 1;
+
+ # This subgroup runs from line $ib to line $ie-1, but may contain
+ # blank lines
+ if ( $num >= $Opt_size_min ) {
+
+ # if there are blank lines, we require that at least $num lines
+ # be non-blank up to the boundary with the next subgroup.
+ my $nog_b = my $nog_e = 1;
+ if ( @iblanks && !$Opt_blanks_delete ) {
+ my $j_bb = $j_b + $num - 1;
+ my ( $i_bb, $tok_bb, $count_bb ) = @{ $group[$j_bb] };
+ $nog_b = $count_bb - $count_b + 1 == $num;
+
+ my $j_ee = $j_e - ( $num - 1 );
+ my ( $i_ee, $tok_ee, $count_ee ) = @{ $group[$j_ee] };
+ $nog_e = $count_e - $count_ee + 1 == $num;
+ }
+ if ( $nog_b && $k > $kbeg ) {
+ $insert_blank_after->( $i_b - 1 );
+ }
+ if ( $nog_e && $k < $kend ) {
+ my ( $i_ep, $tok_ep, $count_ep ) = @{ $group[ $j_e + 1 ] };
+ $insert_blank_after->( $i_ep - 1 );
+ }
+ }
+ }
+ };
+
+ my $delete_if_blank = sub {
+ my ($i) = @_;
+
+ # delete line $i if it is blank
+ return unless ( $i >= 0 && $i < @{$rlines} );
+ my $line_type = $rlines->[$i]->{_line_type};
+ return if ( $line_type ne 'CODE' );
+ my $code_type = $rlines->[$i]->{_code_type};
+ if ( $code_type eq 'BL' ) { $rhash_of_desires->{$i} = 2; }
+ return;
+ };
+
+ my $delete_inner_blank_lines = sub {
+
+ # always remove unwanted trailing blank lines from our list
+ return unless (@iblanks);
+ while ( my $ibl = pop(@iblanks) ) {
+ if ( $ibl < $iend ) { push @iblanks, $ibl; last }
+ $iend = $ibl;
+ }
+
+ # now mark mark interior blank lines for deletion if requested
+ return unless ($Opt_blanks_delete);
+
+ while ( my $ibl = pop(@iblanks) ) { $rhash_of_desires->{$ibl} = 2 }
+
+ };
+
+ my $end_group = sub {
+
+ # end a group of keywords
+ my ($bad_ending) = @_;
+ if ( defined($ibeg) && $ibeg >= 0 ) {
+
+ # then handle sufficiently large groups
+ if ( $count >= $Opt_size_min ) {
+
+ $number_of_groups_seen++;
+
+ # do any blank deletions regardless of the count
+ $delete_inner_blank_lines->();
+
+ if ( $ibeg > 0 ) {
+ my $code_type = $rlines->[ $ibeg - 1 ]->{_code_type};
+
+ # patch for hash bang line which is not currently marked as
+ # a comment; mark it as a comment
+ if ( $ibeg == 1 && !$code_type ) {
+ my $line_text = $rlines->[ $ibeg - 1 ]->{_line_text};
+ $code_type = 'BC'
+ if ( $line_text && $line_text =~ /^#/ );
+ }
+
+ # Do not insert a blank after a comment
+ # (this could be subject to a flag in the future)
+ if ( $code_type !~ /(BC|SBC|SBCX)/ ) {
+ if ( $Opt_blanks_before == INSERT ) {
+ $insert_blank_after->( $ibeg - 1 );
+
+ }
+ elsif ( $Opt_blanks_before == DELETE ) {
+ $delete_if_blank->( $ibeg - 1 );
+ }
+ }
+ }
+
+ # We will only put blanks before code lines. We could loosen
+ # this rule a little, but we have to be very careful because
+ # for example we certainly don't want to drop a blank line
+ # after a line like this:
+ # my $var = <<EOM;
+ if ( $line_type eq 'CODE' && defined($K_first) ) {
+
+ # - Do not put a blank before a line of different level
+ # - Do not put a blank line if we ended the search badly
+ # - Do not put a blank at the end of the file
+ # - Do not put a blank line before a hanging side comment
+ my $level = $rLL->[$K_first]->[_LEVEL_];
+ my $ci_level = $rLL->[$K_first]->[_CI_LEVEL_];
+
+ if ( $level == $level_beg
+ && $ci_level == 0
+ && !$bad_ending
+ && $iend < @{$rlines}
+ && $CODE_type ne 'HSC' )
+ {
+ if ( $Opt_blanks_after == INSERT ) {
+ $insert_blank_after->($iend);
+ }
+ elsif ( $Opt_blanks_after == DELETE ) {
+ $delete_if_blank->( $iend + 1 );
+ }
+ }
+ }
+ }
+ $split_into_sub_groups->();
+ }
+
+ # reset for another group
+ $ibeg = -1;
+ $iend = undef;
+ $level_beg = -1;
+ $K_closing = undef;
+ @group = ();
+ @subgroup = ();
+ @iblanks = ();
+ };
+
+ my $find_container_end = sub {
+
+ # If the keyword lines ends with an open token, find the closing token
+ # '$K_closing' so that we can easily skip past the contents of the
+ # container.
+ return if ( $K_last <= $K_first );
+ my $KK = $K_last;
+ my $type_last = $rLL->[$KK]->[_TYPE_];
+ my $tok_last = $rLL->[$KK]->[_TOKEN_];
+ if ( $type_last eq '#' ) {
+ $KK = $self->K_previous_nonblank($KK);
+ $tok_last = $rLL->[$KK]->[_TOKEN_];
+ }
+ if ( $KK > $K_first && $tok_last =~ /^[\(\{\[]$/ ) {
+
+ my $type_sequence = $rLL->[$KK]->[_TYPE_SEQUENCE_];
+ my $lev = $rLL->[$KK]->[_LEVEL_];
+ if ( $lev == $level_beg ) {
+ $K_closing = $K_closing_container->{$type_sequence};
+ }
+ }
+ };
+
+ my $add_to_group = sub {
+ my ( $i, $token, $level ) = @_;
+
+ # End the previous group if we have reached the maximum
+ # group size
+ if ( $Opt_size_max && @group >= $Opt_size_max ) {
+ $end_group->();
+ }
+
+ if ( @group == 0 ) {
+ $ibeg = $i;
+ $level_beg = $level;
+ $count = 0;
+ }
+
+ $count++;
+ $iend = $i;
+
+ # New sub-group?
+ if ( !@group || $token ne $group[-1]->[1] ) {
+ push @subgroup, scalar(@group);
+ }
+ push @group, [ $i, $token, $count ];
+
+ # remember if this line ends in an open container
+ $find_container_end->();
+
+ return;
+ };
+
+ ###################################
+ # loop over all lines of the source
+ ###################################
+ $end_group->();
+ my $i = -1;
+ foreach my $line_of_tokens ( @{$rlines} ) {
+
+ $i++;
+ last
+ if ( $Opt_repeat_count > 0
+ && $number_of_groups_seen >= $Opt_repeat_count );
+
+ $CODE_type = "";
+ $K_first = undef;
+ $K_last = undef;
+ $line_type = $line_of_tokens->{_line_type};
+
+ # always end a group at non-CODE
+ if ( $line_type ne 'CODE' ) { $end_group->(); next }
+
+ $CODE_type = $line_of_tokens->{_code_type};
+
+ # end any group at a format skipping line
+ if ( $CODE_type && $CODE_type eq 'FS' ) {
+ $end_group->();
+ next;
+ }
+
+ # continue in a verbatim (VB) type; it may be quoted text
+ if ( $CODE_type eq 'VB' ) {
+ if ( $ibeg >= 0 ) { $iend = $i; }
+ next;
+ }
+
+ # and continue in blank (BL) types
+ if ( $CODE_type eq 'BL' ) {
+ if ( $ibeg >= 0 ) {
+ $iend = $i;
+ push @{iblanks}, $i;
+
+ # propagate current subgroup token
+ my $tok = $group[-1]->[1];
+ push @group, [ $i, $tok, $count ];
+ }
+ next;
+ }
+
+ # examine the first token of this line
+ my $rK_range = $line_of_tokens->{_rK_range};
+ ( $K_first, $K_last ) = @{$rK_range};
+ if ( !defined($K_first) ) {
+
+ # Unexpected blank line..shouldn't happen
+ # $rK_range should be defined for line type CODE
+ Warn(
+"Programming Error: Unexpected Blank Line in sub 'keyword_group_scan'. Ignoring"
+ );
+ return $rhash_of_desires;
+ }
+
+ my $level = $rLL->[$K_first]->[_LEVEL_];
+ my $type = $rLL->[$K_first]->[_TYPE_];
+ my $token = $rLL->[$K_first]->[_TOKEN_];
+ my $ci_level = $rLL->[$K_first]->[_CI_LEVEL_];
+
+ # see if this is a code type we seek (i.e. comment)
+ if ( $CODE_type
+ && $Opt_comment_pattern
+ && $CODE_type =~ /$Opt_comment_pattern/o )
+ {
+
+ my $tok = $CODE_type;
+
+ # Continuing a group
+ if ( $ibeg >= 0 && $level == $level_beg ) {
+ $add_to_group->( $i, $tok, $level );
+ }
+
+ # Start new group
+ else {
+
+ # first end old group if any; we might be starting new
+ # keywords at different level
+ if ( $ibeg > 0 ) { $end_group->(); }
+ $add_to_group->( $i, $tok, $level );
+ }
+ next;
+ }
+
+ # See if it is a keyword we seek, but never start a group in a
+ # continuation line; the code may be badly formatted.
+ if ( $ci_level == 0
+ && $type eq 'k'
+ && $token =~ /$Opt_pattern/o )
+ {
+
+ # Continuing a keyword group
+ if ( $ibeg >= 0 && $level == $level_beg ) {
+ $add_to_group->( $i, $token, $level );
+ }
+
+ # Start new keyword group
+ else {
+
+ # first end old group if any; we might be starting new
+ # keywords at different level
+ if ( $ibeg > 0 ) { $end_group->(); }
+ $add_to_group->( $i, $token, $level );
+ }
+ next;
+ }
+
+ # This is not one of our keywords, but we are in a keyword group
+ # so see if we should continue or quit
+ elsif ( $ibeg >= 0 ) {
+
+ # - bail out on a large level change; we may have walked into a
+ # data structure or anoymous sub code.
+ if ( $level > $level_beg + 1 || $level < $level_beg ) {
+ $end_group->();
+ next;
+ }
+
+ # - keep going on a continuation line of the same level, since
+ # it is probably a continuation of our previous keyword,
+ # - and keep going past hanging side comments because we never
+ # want to interrupt them.
+ if ( ( ( $level == $level_beg ) && $ci_level > 0 )
+ || $CODE_type eq 'HSC' )
+ {
+ $iend = $i;
+ next;
+ }
+
+ # - continue if if we are within in a container which started with
+ # the line of the previous keyword.
+ if ( defined($K_closing) && $K_first <= $K_closing ) {
+
+ # continue if entire line is within container
+ if ( $K_last <= $K_closing ) { $iend = $i; next }
+
+ # continue at ); or }; or ];
+ my $KK = $K_closing + 1;
+ if ( $rLL->[$KK]->[_TYPE_] eq ';' ) {
+ if ( $KK < $K_last ) {
+ if ( $rLL->[ ++$KK ]->[_TYPE_] eq 'b' ) { ++$KK }
+ if ( $KK > $K_last || $rLL->[$KK]->[_TYPE_] ne '#' ) {
+ $end_group->(1);
+ next;
+ }
+ }
+ $iend = $i;
+ next;
+ }
+
+ $end_group->(1);
+ next;
+ }
+
+ # - end the group if none of the above
+ $end_group->();
+ next;
+ }
+
+ # not in a keyword group; continue
+ else { next }
+ }
+
+ # end of loop over all lines
+ $end_group->();
+ return $rhash_of_desires;
+}
+
sub break_lines {
# Loop over old lines to set new line break points
my $self = shift;
my $rlines = $self->{rlines};
+ # Note for RT#118553, leave only one newline at the end of a file.
+ # Example code to do this is in comments below:
+ # my $Opt_trim_ending_blank_lines = 0;
+ # if ($Opt_trim_ending_blank_lines) {
+ # while ( my $line_of_tokens = pop @{$rlines} ) {
+ # my $line_type = $line_of_tokens->{_line_type};
+ # if ( $line_type eq 'CODE' ) {
+ # my $CODE_type = $line_of_tokens->{_code_type};
+ # next if ( $CODE_type eq 'BL' );
+ # }
+ # push @{$rlines}, $line_of_tokens;
+ # last;
+ # }
+ # }
+
+ # But while this would be a trivial update, it would have very undesirable
+ # side effects when perltidy is run from within an editor on a small snippet.
+ # So this is best done with a separate filter, such
+ # as 'delete_ending_blank_lines.pl' in the examples folder.
+
# Flag to prevent blank lines when POD occurs in a format skipping sect.
my $in_format_skipping_section;
+ # set locations for blanks around long runs of keywords
+ my $rwant_blank_line_after = $self->keyword_group_scan();
+
my $line_type = "";
+ my $i = -1;
foreach my $line_of_tokens ( @{$rlines} ) {
+ $i++;
+
+ # insert blank lines requested for keyword sequences
+ if ( $i > 0
+ && defined( $rwant_blank_line_after->{ $i - 1 } )
+ && $rwant_blank_line_after->{ $i - 1 } == 1 )
+ {
+ $self->want_blank_line();
+ }
my $last_line_type = $line_type;
$line_type = $line_of_tokens->{_line_type};
# If keep-old-blank-lines is zero, we delete all
# old blank lines and let the blank line rules generate any
# needed blanks.
- if ($rOpts_keep_old_blank_lines) {
+
+ # We also delete lines requested by the keyword-group logic
+ my $kgb_keep = !( defined( $rwant_blank_line_after->{$i} )
+ && $rwant_blank_line_after->{$i} == 2 );
+
+ # But the keep-old-blank-lines flag has priority over kgb flags
+ $kgb_keep = 1 if ( $rOpts_keep_old_blank_lines == 2 );
+
+ if ( $rOpts_keep_old_blank_lines && $kgb_keep ) {
$self->flush();
$file_writer_object->write_blank_code_line(
$rOpts_keep_old_blank_lines == 2 );
# let logger see all non-blank lines of code
my $output_line_number = get_output_line_number();
- ##$vertical_aligner_object->get_output_line_number();
black_box( $line_of_tokens, $output_line_number );
}
# These are not yet used but could be useful
else {
if ( $token eq '?' ) {
- $K_opening_ternary->{$type_sequence} = $KK;
+ $K_opening_ternary->{$type_sequence} = $KK_new;
}
elsif ( $token eq ':' ) {
- $K_closing_ternary->{$type_sequence} = $KK;
+ $K_closing_ternary->{$type_sequence} = $KK_new;
}
else {
# shouldn't happen
- print STDERR "Ugh: shouldn't happen\n";
+ Fault("Ugh: shouldn't happen");
}
}
}
# on a token which has been stored.
my $rcopy = copy_token_as_type( $rLL_new->[$Ktop], 'b', ' ' );
- # Convert the existing blank to a semicolon
- $rLL_new->[$Ktop]->[_TOKEN_] = ''; # zero length
+ # 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 = $rOpts_one_line_block_semicolons == 2 ? ';' : '';
+
+ $rLL_new->[$Ktop]->[_TOKEN_] = $tok; # zero length if phantom
$rLL_new->[$Ktop]->[_TYPE_] = ';';
$rLL_new->[$Ktop]->[_SLEVEL_] =
$rLL->[$KK]->[_SLEVEL_];
print STDERR "ntokens=$nvars\n";
print STDERR "K\t_TOKEN_\t_TYPE_\n";
my $K = 0;
+
foreach my $item ( @{$rLL} ) {
print STDERR "$K\t$item->[_TOKEN_]\t$item->[_TYPE_]\n";
$K++;
my $length_to_opening_seqno = sub {
my ($seqno) = @_;
- my $KK = $K_opening_container->{$seqno};
- my $lentot = $KK <= 0 ? 0 : $rLL->[ $KK - 1 ]->[_CUMULATIVE_LENGTH_];
+ my $KK = $K_opening_container->{$seqno};
+ my $lentot = $KK <= 0 ? 0 : $rLL->[ $KK - 1 ]->[_CUMULATIVE_LENGTH_];
return $lentot;
};
my $length_to_closing_seqno = sub {
my ($seqno) = @_;
- my $KK = $K_closing_container->{$seqno};
- my $lentot = $KK <= 0 ? 0 : $rLL->[ $KK - 1 ]->[_CUMULATIVE_LENGTH_];
+ my $KK = $K_closing_container->{$seqno};
+ my $lentot = $KK <= 0 ? 0 : $rLL->[ $KK - 1 ]->[_CUMULATIVE_LENGTH_];
return $lentot;
};
my $length_to_opening_seqno = sub {
my ($seqno) = @_;
- my $KK = $K_opening_container->{$seqno};
- my $lentot = $KK <= 0 ? 0 : $rLL->[ $KK - 1 ]->[_CUMULATIVE_LENGTH_];
+ my $KK = $K_opening_container->{$seqno};
+ my $lentot = $KK <= 0 ? 0 : $rLL->[ $KK - 1 ]->[_CUMULATIVE_LENGTH_];
return $lentot;
};
my $length_to_closing_seqno = sub {
my ($seqno) = @_;
- my $KK = $K_closing_container->{$seqno};
- my $lentot = $KK <= 0 ? 0 : $rLL->[ $KK - 1 ]->[_CUMULATIVE_LENGTH_];
- ##my $lentot = $rLL->[$KK]->[_CUMULATIVE_LENGTH_];
+ my $KK = $K_closing_container->{$seqno};
+ my $lentot = $KK <= 0 ? 0 : $rLL->[ $KK - 1 ]->[_CUMULATIVE_LENGTH_];
return $lentot;
};
# FIXME: Are these always correct?
$weld_len_left_closing{$outer_seqno} = 1;
$weld_len_right_opening{$outer_seqno} = 2;
+
+ # QW PATCH 1 (Testing)
+ # undo CI for welded quotes
+ foreach my $K ( $Kn .. $Kt_end ) {
+ $rLL->[$K]->[_CI_LEVEL_] = 0;
+ }
+
+ # Change the level of a closing qw token to be that of the outer
+ # containing token. This will allow -lp indentation to function
+ # correctly in the vertical aligner.
+ $rLL->[$Kt_end]->[_LEVEL_] = $rLL->[$K_closing]->[_LEVEL_];
}
}
return;
make_bli_pattern();
make_block_brace_vertical_tightness_pattern();
make_blank_line_pattern();
+ make_keyword_group_list_pattern();
prepare_cuddled_block_types();
if ( $rOpts->{'dump-cuddled-block-list'} ) {
$rOpts->{'break-at-old-keyword-breakpoints'};
$rOpts_break_at_old_logical_breakpoints =
$rOpts->{'break-at-old-logical-breakpoints'};
+ $rOpts_break_at_old_method_breakpoints =
+ $rOpts->{'break-at-old-method-breakpoints'};
$rOpts_closing_side_comment_else_flag =
$rOpts->{'closing-side-comment-else-flag'};
$rOpts_closing_side_comment_maximum_text =
$rOpts->{'closing-side-comment-maximum-text'};
- $rOpts_continuation_indentation = $rOpts->{'continuation-indentation'};
- $rOpts_delete_old_whitespace = $rOpts->{'delete-old-whitespace'};
- $rOpts_fuzzy_line_length = $rOpts->{'fuzzy-line-length'};
- $rOpts_indent_columns = $rOpts->{'indent-columns'};
- $rOpts_line_up_parentheses = $rOpts->{'line-up-parentheses'};
- $rOpts_maximum_fields_per_table = $rOpts->{'maximum-fields-per-table'};
- $rOpts_maximum_line_length = $rOpts->{'maximum-line-length'};
- $rOpts_whitespace_cycle = $rOpts->{'whitespace-cycle'};
+ $rOpts_continuation_indentation = $rOpts->{'continuation-indentation'};
+ $rOpts_delete_old_whitespace = $rOpts->{'delete-old-whitespace'};
+ $rOpts_fuzzy_line_length = $rOpts->{'fuzzy-line-length'};
+ $rOpts_indent_columns = $rOpts->{'indent-columns'};
+ $rOpts_line_up_parentheses = $rOpts->{'line-up-parentheses'};
+ $rOpts_maximum_fields_per_table = $rOpts->{'maximum-fields-per-table'};
+ $rOpts_maximum_line_length = $rOpts->{'maximum-line-length'};
+ $rOpts_whitespace_cycle = $rOpts->{'whitespace-cycle'};
+ $rOpts_one_line_block_semicolons = $rOpts->{'one-line-block-semicolons'};
$rOpts_variable_maximum_line_length =
$rOpts->{'variable-maximum-line-length'};
return;
}
+sub make_keyword_group_list_pattern {
+
+ # turn any input list into a regex for recognizing selected block types.
+ # Here are the defaults:
+ $keyword_group_list_pattern = '^(our|local|my|use|require|)$';
+ $keyword_group_list_comment_pattern = '';
+ if ( defined( $rOpts->{'keyword-group-blanks-list'} )
+ && $rOpts->{'keyword-group-blanks-list'} )
+ {
+ my @words = split /\s+/, $rOpts->{'keyword-group-blanks-list'};
+ my @keyword_list;
+ my @comment_list;
+ foreach my $word (@words) {
+ if ( $word =~ /^(BC|SBC)$/ ) {
+ push @comment_list, $word;
+ if ( $word eq 'SBC' ) { push @comment_list, 'SBCX' }
+ }
+ else {
+ push @keyword_list, $word;
+ }
+ }
+ $keyword_group_list_pattern =
+ make_block_pattern( '-kgbl', $rOpts->{'keyword-group-blanks-list'} );
+ $keyword_group_list_comment_pattern =
+ make_block_pattern( '-kgbl', join( ' ', @comment_list ) );
+ }
+ return;
+}
+
sub make_block_brace_vertical_tightness_pattern {
# turn any input list into a regex for recognizing selected block types
# No longer doing this: also write a line which is entirely a 'qw' list
# to allow stacking of opening and closing tokens. Note that interior
# qw lines will still go out at the end of this routine.
- ##if ( $rOpts->{'indent-only'} ) {
if ( $CODE_type eq 'IO' ) {
$self->flush();
my $line = $input_line;
} ## end sub print_line_of_tokens
} ## end block print_line_of_tokens
+sub consecutive_nonblank_lines {
+ return $file_writer_object->get_consecutive_nonblank_lines() +
+ $vertical_aligner_object->get_cached_line_count();
+}
+
# sub output_line_to_go sends one logical line of tokens on down the
# pipeline to the VerticalAligner package, breaking the line into continuation
# lines as necessary. The line of tokens is ready to go in the "to_go"
my $lc = $nonblank_lines_at_depth[$last_line_leading_level];
if ( !defined($lc) ) { $lc = 0 }
+ # patch for RT #128216: no blank line inserted at a level change
+ if ( $levels_to_go[$imin] != $last_line_leading_level ) {
+ $lc = 0;
+ }
+
$want_blank =
$rOpts->{'blanks-before-blocks'}
&& $lc >= $rOpts->{'long-block-line-count'}
- && $file_writer_object->get_consecutive_nonblank_lines() >=
+ && consecutive_nonblank_lines() >=
$rOpts->{'long-block-line-count'}
&& (
terminal_type( \@types_to_go, \@block_type_to_go, $imin,
$do_not_pad = correct_lp_indentation( $ri_first, $ri_last );
}
$self->unmask_phantom_semicolons( $ri_first, $ri_last );
+ if ( $rOpts_one_line_block_semicolons == 0 ) {
+ $self->delete_one_line_semicolons( $ri_first, $ri_last );
+ }
$self->send_lines_to_vertical_aligner( $ri_first, $ri_last,
$do_not_pad );
my $jmax_check = @{$rtoken_array};
if ( $jmax_check < $jmax ) {
- print STDERR "jmax=$jmax > $jmax_check\n";
+ Fault("jmax=$jmax > $jmax_check");
}
# kill any current block - we can only go 1 deep
# store_token_to_go to put the opening brace in the output stream
if ( $max_index_to_go < 0 ) {
Fault("program bug: store_token_to_go called incorrectly\n");
-
- #warning("program bug: store_token_to_go called incorrectly\n");
- ##report_definite_bug();
}
# return if block should be broken
# an editor. In that case either the user will see and
# fix the problem or it will be corrected next time the
# entire file is processed with perltidy.
- ##next if ( $ipad == 0 && $levels_to_go[$ipad] == 0 );
next if ( $ipad == 0 && $peak_batch_size <= 1 );
## THIS PATCH REMOVES THE FOLLOWING POOR PADDING (math.t) with -pbp, BUT
if ( $accumulating_text_for_block !~ /^els/ ) {
$rleading_block_if_elsif_text = [];
}
- $leading_block_text = "";
- $leading_block_text_level = $levels_to_go[$i];
- $leading_block_text_line_number = get_output_line_number();
- ##$vertical_aligner_object->get_output_line_number();
+ $leading_block_text = "";
+ $leading_block_text_level = $levels_to_go[$i];
+ $leading_block_text_line_number = get_output_line_number();
$leading_block_text_length_exceeded = 0;
# this will contain the column number of the last character
if ( defined( $block_opening_line_number{$type_sequence} ) )
{
my $output_line_number = get_output_line_number();
- ##$vertical_aligner_object->get_output_line_number();
$block_line_count =
$output_line_number -
$block_opening_line_number{$type_sequence} + 1;
elsif ( $token eq '{' ) {
my $line_number = get_output_line_number();
- ##$vertical_aligner_object->get_output_line_number();
$block_opening_line_number{$type_sequence} = $line_number;
# set a label for this block, except for
#---------------------------------------------------------------
# Step 2: make the closing side comment if this ends a block
#---------------------------------------------------------------
- ##my $have_side_comment = $i_terminal != $max_index_to_go;
my $have_side_comment = $types_to_go[$max_index_to_go] eq '#';
# if this line might end in a block closure..
# These are used below to prevent unwanted cross-line alignments.
# Unbalanced containers already avoid aligning across
# container boundaries.
- if ( $tokens_to_go[$i] eq '(' ) {
+ my $tok = $tokens_to_go[$i];
+ if ( $tok =~ /^[\(\{\[]/ ) { #'(' ) {
# if container is balanced on this line...
my $i_mate = $mate_index_to_go[$i];
# more unique. This name will also be given to any commas
# within this container, and it helps avoid undesirable
# alignments of different types of containers.
- my $name = previous_nonblank_token($i);
- $name =~ s/^->//;
+
+ # Containers beginning with { and [ are given those names
+ # for uniqueness. That way commas in different containers
+ # will not match. Here is an example of what this prevents:
+ # a => [ 1, 2, 3 ],
+ # b => { b1 => 4, b2 => 5 },
+ # Here is another example of what we avoid by labeling the
+ # commas properly:
+ # is_d( [ $a, $a ], [ $b, $c ] );
+ # is_d( { foo => $a, bar => $a }, { foo => $b, bar => $c } );
+ # is_d( [ \$a, \$a ], [ \$b, \$c ] );
+
+ my $name = $tok;
+ if ( $tok eq '(' ) {
+ $name = previous_nonblank_token($i);
+ $name =~ s/^->//;
+ }
$container_name[$depth] = "+" . $name;
# Make the container name even more unique if necessary.
}
}
}
- elsif ( $tokens_to_go[$i] eq ')' ) {
+ elsif ( $tokens_to_go[$i] =~ /^[\)\}\]]/ ) {
$depth-- if $depth > 0;
}
$is_leading, $opening_exists
);
+ my $type_beg = $types_to_go[$ibeg];
+ my $token_beg = $tokens_to_go[$ibeg];
+ my $K_beg = $K_to_go[$ibeg];
+ my $ibeg_weld_fix = $ibeg;
+
+ # QW PATCH 2 (Testing)
+ # At an isolated closing token of a qw quote which is welded to
+ # a following closing token, we will locally change its type to
+ # be the same as its token. This will allow formatting to be the
+ # same as for an ordinary closing token.
+
+ # For -lp formatting se use $ibeg_weld_fix to get around the problem
+ # that with -lp type formatting the opening and closing tokens to not
+ # have sequence numbers.
+ if ( $type_beg eq 'q' && $token_beg =~ /^[\)\}\]\>]/ ) {
+ my $K_next_nonblank = $self->K_next_code($K_beg);
+ if ( defined($K_next_nonblank) ) {
+ my $type_sequence = $rLL->[$K_next_nonblank]->[_TYPE_SEQUENCE_];
+ my $token = $rLL->[$K_next_nonblank]->[_TOKEN_];
+ my $welded = weld_len_left( $type_sequence, $token );
+ if ($welded) {
+ $ibeg_weld_fix = $ibeg + ( $K_next_nonblank - $K_beg );
+ $type_beg = ')'; ##$token_beg;
+ }
+ }
+ }
+
# if we are at a closing token of some type..
- if ( $types_to_go[$ibeg] =~ /^[\)\}\]R]$/ ) {
+ if ( $type_beg =~ /^[\)\}\]R]$/ ) {
# get the indentation of the line containing the corresponding
# opening token
$opening_indentation, $opening_offset,
$is_leading, $opening_exists
)
- = get_opening_indentation( $ibeg, $ri_first, $ri_last,
+ = get_opening_indentation( $ibeg_weld_fix, $ri_first, $ri_last,
$rindentation_list );
# First set the default behavior:
# incorrectly '(' and ')'. Corrected to be '{' and '}'
|| (
$terminal_type eq '{'
- && $types_to_go[$ibeg] eq '}'
+ && $type_beg eq '}'
&& ( $nesting_depth_to_go[$iend] + 1 ==
$nesting_depth_to_go[$ibeg] )
)
# or without ending '{' and unbalanced, such as
# such as '}->{$operator}'
|| (
- $types_to_go[$ibeg] eq '}'
+ $type_beg eq '}'
&& ( $types_to_go[$iend] eq '{'
|| $levels_to_go[$iend] < $levels_to_go[$ibeg] )
# it is the last token before a level decrease. This will allow
# a closing token to line up with its opening counterpart, and
# avoids a indentation jump larger than 1 level.
- my $K_beg = $K_to_go[$ibeg];
if ( $types_to_go[$i_terminal] =~ /^[\}\]\)R]$/
&& $i_terminal == $ibeg
&& defined($K_beg) )
#--------------------------------------------------------
# patch for =~ operator. We only align this if it
# is the first operator in a line, and the line is a simple
- # statement. Aligning them within a statement causes
- # interferes with other good alignments.
+ # statement. Aligning them within a statement
+ # interferes could interfere with other good alignments.
#--------------------------------------------------------
if ( $alignment_type eq '=~' ) {
my $terminal_type = $types_to_go[$i_terminal];
set_forced_breakpoint( $i - 1 );
} ## end if ( $type eq 'k' && $i...)
+ # remember locations of -> if this is a pre-broken method chain
+ if ( $type eq '->' ) {
+ if ($rOpts_break_at_old_method_breakpoints) {
+
+ # Case 1: look for lines with leading pointers
+ if ( $i == $i_line_start ) {
+ set_forced_breakpoint( $i - 1 );
+ }
+
+ # Case 2: look for cuddled pointer calls
+ else {
+
+ # look for old lines with leading ')->' or ') ->'
+ # and, when found, force a break before the
+ # opening paren and after the previous closing paren.
+ if (
+ $types_to_go[$i_line_start] eq '}'
+ && ( $i == $i_line_start + 1
+ || $i == $i_line_start + 2
+ && $types_to_go[ $i - 1 ] eq 'b' )
+ )
+ {
+ set_forced_breakpoint( $i_line_start - 1 );
+ set_forced_breakpoint(
+ $mate_index_to_go[$i_line_start] );
+ }
+ }
+ }
+ } ## end if ( $type eq '->' )
+
# remember locations of '||' and '&&' for possible breaks if we
# decide this is a long logical expression.
- if ( $type eq '||' ) {
+ elsif ( $type eq '||' ) {
push @{ $rand_or_list[$depth][2] }, $i;
++$has_old_logical_breakpoints[$depth]
if ( ( $i == $i_line_start || $i == $i_line_end )
&& $rOpts_break_at_old_logical_breakpoints );
- } ## end if ( $type eq '||' )
+ } ## end elsif ( $type eq '||' )
elsif ( $type eq '&&' ) {
push @{ $rand_or_list[$depth][3] }, $i;
++$has_old_logical_breakpoints[$depth]
if ( $next_nonblank_type =~ /^[\)\}\]R]$/ ) {
if ($rOpts_comma_arrow_breakpoints) {
$want_comma_break[$depth] = 0;
- ##$index_before_arrow[$depth] = -1;
next;
}
}
my $im3 = $i_opening_paren - 3;
my $typem1 = $types_to_go[$im1];
my $typem2 = $im2 >= 0 ? $types_to_go[$im2] : 'b';
+
if ( $typem1 eq ',' || ( $typem1 eq 'b' && $typem2 eq ',' ) ) {
$i_opening_minus = $i_opening_paren;
}
my $total_variation_1 = 0;
my $total_variation_2 = 0;
my @total_variation_2 = ( 0, 0 );
+
foreach my $j ( 0 .. $item_count - 1 ) {
$is_odd = 1 - $is_odd;
return;
}
+ sub delete_one_line_semicolons {
+
+ my ( $self, $ri_beg, $ri_end ) = @_;
+ my $rLL = $self->{rLL};
+ my $K_opening_container = $self->{K_opening_container};
+
+ # Walk down the lines of this batch and delete any semicolons
+ # terminating one-line blocks;
+ my $nmax = @{$ri_end} - 1;
+
+ foreach my $n ( 0 .. $nmax ) {
+ my $i_beg = $ri_beg->[$n];
+ my $i_e = $ri_end->[$n];
+ my $K_beg = $K_to_go[$i_beg];
+ my $K_e = $K_to_go[$i_e];
+ my $K_end = $K_e;
+ my $type_end = $rLL->[$K_end]->[_TYPE_];
+ if ( $type_end eq '#' ) {
+ $K_end = $self->K_previous_nonblank($K_end);
+ if ( defined($K_end) ) { $type_end = $rLL->[$K_end]->[_TYPE_]; }
+ }
+
+ # we are looking for a line ending in closing brace
+ next
+ unless ( $type_end eq '}' && $rLL->[$K_end]->[_TOKEN_] eq '}' );
+
+ # ...and preceded by a semicolon on the same line
+ my $K_semicolon = $self->K_previous_nonblank($K_end);
+ my $i_semicolon = $i_beg + ( $K_semicolon - $K_beg );
+ next if ( $i_semicolon <= $i_beg );
+ next unless ( $rLL->[$K_semicolon]->[_TYPE_] eq ';' );
+
+ # safety check - shouldn't happen
+ if ( $types_to_go[$i_semicolon] ne ';' ) {
+ Fault("unexpected type looking for semicolon, ignoring");
+ next;
+ }
+
+ # ... with the corresponding opening brace on the same line
+ my $type_sequence = $rLL->[$K_end]->[_TYPE_SEQUENCE_];
+ my $K_opening = $K_opening_container->{$type_sequence};
+ my $i_opening = $i_beg + ( $K_opening - $K_beg );
+ next if ( $i_opening < $i_beg );
+
+ # ... and only one semicolon between these braces
+ my $semicolon_count = 0;
+ foreach my $K ( $K_opening + 1 .. $K_semicolon - 1 ) {
+ if ( $rLL->[$K]->[_TYPE_] eq ';' ) {
+ $semicolon_count++;
+ last;
+ }
+ }
+ next if ($semicolon_count);
+
+ # ...ok, then make the semicolon invisible
+ $tokens_to_go[$i_semicolon] = "";
+ }
+ return;
+ }
+
sub unmask_phantom_semicolons {
my ( $self, $ri_beg, $ri_end ) = @_;
package Perl::Tidy::HtmlWriter;
use strict;
use warnings;
-our $VERSION = '20181120';
+our $VERSION = '20190601';
use File::Basename;
set_default_color( "html-color-$short_to_long_names{$short_name}", $color );
my $key;
- $key = "html-bold-$short_to_long_names{$short_name}";
+ $key = "html-bold-$short_to_long_names{$short_name}";
$rOpts->{$key} = ( defined $rOpts->{$key} ) ? $rOpts->{$key} : $bold;
- $key = "html-italic-$short_to_long_names{$short_name}";
+ $key = "html-italic-$short_to_long_names{$short_name}";
$rOpts->{$key} = ( defined $rOpts->{$key} ) ? $rOpts->{$key} : $italic;
return;
}
use strict;
use warnings;
use Carp;
-our $VERSION = '20181120';
+our $VERSION = '20190601';
sub new {
my ( $package, $rscalar, $mode ) = @_;
use strict;
use warnings;
use Carp;
-our $VERSION = '20181120';
+our $VERSION = '20190601';
sub new {
my ( $package, $rarray, $mode ) = @_;
package Perl::Tidy::IndentationItem;
use strict;
use warnings;
-our $VERSION = '20181120';
+our $VERSION = '20190601';
sub new {
package Perl::Tidy::LineBuffer;
use strict;
use warnings;
-our $VERSION = '20181120';
+our $VERSION = '20190601';
sub new {
package Perl::Tidy::LineSink;
use strict;
use warnings;
-our $VERSION = '20181120';
+our $VERSION = '20190601';
sub new {
&& $rOpts->{'character-encoding'} eq 'utf8' )
{
if ( ref($fh) eq 'IO::File' ) {
- $fh->binmode(":encoding(UTF-8)");
+ $fh->binmode(":raw:encoding(UTF-8)");
}
elsif ( $output_file eq '-' ) {
- binmode STDOUT, ":encoding(UTF-8)";
+ binmode STDOUT, ":raw:encoding(UTF-8)";
}
}
package Perl::Tidy::LineSource;
use strict;
use warnings;
-our $VERSION = '20181120';
+our $VERSION = '20190601';
sub new {
package Perl::Tidy::Logger;
use strict;
use warnings;
-our $VERSION = '20181120';
+our $VERSION = '20190601';
sub new {
package Perl::Tidy::Tokenizer;
use strict;
use warnings;
-our $VERSION = '20181120';
+our $VERSION = '20190601';
use Perl::Tidy::LineBuffer;
# variables used to track depths of various containers
# and report nesting errors
- $paren_depth = 0;
- $brace_depth = 0;
- $square_bracket_depth = 0;
- @current_depth[ 0 .. $#closing_brace_names ] =
- (0) x scalar @closing_brace_names;
- $total_depth = 0;
- @total_depth = ();
- @nesting_sequence_number[ 0 .. $#closing_brace_names ] =
- ( 0 .. $#closing_brace_names );
+ $paren_depth = 0;
+ $brace_depth = 0;
+ $square_bracket_depth = 0;
+ @current_depth = (0) x scalar @closing_brace_names;
+ $total_depth = 0;
+ @total_depth = ();
+ @nesting_sequence_number = ( 0 .. @closing_brace_names - 1 );
@current_sequence_number = ();
$paren_type[$paren_depth] = '';
$paren_semicolon_count[$paren_depth] = 0;
# find the closing quote; don't worry about escapes
my $quote_mark = $pre_types[$j];
- foreach my $k ( $j + 1 .. $#pre_types - 1 ) {
+ foreach my $k ( $j + 1 .. @pre_types - 2 ) {
if ( $pre_types[$k] eq $quote_mark ) {
$j = $k + 1;
my $next = $pre_types[$j];
$starting_line_of_current_depth[$aa][ $current_depth[$aa] ] =
[ $input_line_number, $input_line, $pos ];
- for my $bb ( 0 .. $#closing_brace_names ) {
+ for my $bb ( 0 .. @closing_brace_names - 1 ) {
next if ( $bb == $aa );
$depth_array[$aa][$bb][ $current_depth[$aa] ] = $current_depth[$bb];
}
$statement_type = $nested_statement_type[$aa][ $current_depth[$aa] ];
# check that any brace types $bb contained within are balanced
- for my $bb ( 0 .. $#closing_brace_names ) {
+ for my $bb ( 0 .. @closing_brace_names - 1 ) {
next if ( $bb == $aa );
unless ( $depth_array[$aa][$bb][ $current_depth[$aa] ] ==
# USES GLOBAL VARIABLES: @current_depth, @starting_line_of_current_depth
- for my $aa ( 0 .. $#closing_brace_names ) {
+ for my $aa ( 0 .. @closing_brace_names - 1 ) {
if ( $current_depth[$aa] ) {
my $rsl =
# <$LATEX2HTMLVERSIONS${dd}html[1-9].[0-9].pl>
#
# Here are some examples of lines which do not have angle operators:
- # return undef unless $self->[2]++ < $#{$self->[1]};
+ # return unless $self->[2]++ < $#{$self->[1]};
# < 2 || @$t >
#
# the following line from dlister.pl caused trouble:
}
}
else { # found ending quote
- ##my $j;
$found_target = 1;
my $tokj;
package Perl::Tidy::VerticalAligner;
use strict;
use warnings;
-our $VERSION = '20181120';
+our $VERSION = '20190601';
use Perl::Tidy::VerticalAligner::Alignment;
use Perl::Tidy::VerticalAligner::Line;
use vars qw(
$vertical_aligner_self
- $current_line
$maximum_alignment_index
$ralignment_list
$maximum_jmax_seen
$minimum_jmax_seen
$previous_minimum_jmax_seen
$previous_maximum_jmax_seen
- $maximum_line_index
+ @group_lines
$group_level
$group_type
$group_maximum_gap
$last_leading_space_count
$extra_indent_ok
$zero_count
- @group_lines
$last_comment_column
$last_side_comment_line_number
$last_side_comment_length
}
sub initialize_for_new_group {
- $maximum_line_index = -1; # lines in the current group
- $maximum_alignment_index = -1; # alignments in current group
- $zero_count = 0; # count consecutive lines without tokens
- $current_line = undef; # line being matched for alignment
- $group_maximum_gap = 0; # largest gap introduced
- $group_type = "";
- $marginal_match = 0;
+ @group_lines = ();
+ $maximum_alignment_index = -1; # alignments in current group
+ $zero_count = 0; # count consecutive lines without tokens
+ $group_maximum_gap = 0; # largest gap introduced
+ $group_type = "";
+ $marginal_match = 0;
$comment_leading_space_count = 0;
$last_leading_space_count = 0;
return;
return;
}
+sub get_cached_line_count {
+ my $self = shift;
+ return @group_lines + ( $cached_line_type ? 1 : 0 );
+}
+
sub get_spaces {
# return the number of leading spaces associated with an indentation
++$maximum_alignment_index;
#my $alignment = new Perl::Tidy::VerticalAligner::Alignment(
+ my $nlines = @group_lines;
my $alignment = Perl::Tidy::VerticalAligner::Alignment->new(
column => $col,
starting_column => $col,
matching_token => $token,
- starting_line => $maximum_line_index,
- ending_line => $maximum_line_index,
+ starting_line => $nlines - 1,
+ ending_line => $nlines - 1,
serial_number => $maximum_alignment_index,
);
$ralignment_list->[$maximum_alignment_index] = $alignment;
return $maximum_line_length;
}
+sub push_group_line {
+
+ my ($new_line) = @_;
+ push @group_lines, $new_line;
+ return;
+}
+
sub valign_input {
# Place one line in the current vertical group.
# number of fields is $jmax
# number of tokens between fields is $jmax-1
- my $jmax = $#{$rfields};
+ my $jmax = @{$rfields} - 1;
my $leading_space_count = get_spaces($indentation);
}
VALIGN_DEBUG_FLAG_APPEND0 && do {
+ my $nlines = @group_lines;
print STDOUT
-"APPEND0: entering lines=$maximum_line_index new #fields= $jmax, leading_count=$leading_space_count last_cmt=$last_comment_column force=$is_forced_break\n";
+"APPEND0: entering lines=$nlines new #fields= $jmax, leading_count=$leading_space_count last_cmt=$last_comment_column force=$is_forced_break, level_jump=$level_jump, level=$level, group_level=$group_level, level_jump=$level_jump\n";
};
# Validate cached line if necessary: If we can produce a container
# token with the closing token to follow, then we will mark both
# cached flags as valid.
if ($rvertical_tightness_flags) {
- if ( $maximum_line_index <= 0
+ if ( @group_lines <= 1
&& $cached_line_type
&& $cached_seqno
&& $rvertical_tightness_flags->[2]
# do not join an opening block brace with an unbalanced line
# unless requested with a flag value of 2
if ( $cached_line_type == 3
- && $maximum_line_index < 0
+ && !@group_lines
&& $cached_line_flag < 2
&& $level_jump != 0 )
{
}
# --------------------------------------------------------------------
- # Patch to collect outdentable block COMMENTS
+ # Collect outdentable block COMMENTS
# --------------------------------------------------------------------
my $is_blank_line = "";
if ( $group_type eq 'COMMENT' ) {
|| $is_blank_line
)
{
- $group_lines[ ++$maximum_line_index ] = $rfields->[0];
+ push_group_line( $rfields->[0] );
return;
}
else {
# add dummy fields for terminal ternary
# --------------------------------------------------------------------
my $j_terminal_match;
- if ( $is_terminal_ternary && $current_line ) {
+
+ if ( $is_terminal_ternary && @group_lines ) {
$j_terminal_match =
- fix_terminal_ternary( $rfields, $rtokens, $rpatterns );
+ fix_terminal_ternary( $group_lines[-1], $rfields, $rtokens,
+ $rpatterns );
$jmax = @{$rfields} - 1;
}
# --------------------------------------------------------------------
# add dummy fields for else statement
# --------------------------------------------------------------------
+
if ( $rfields->[0] =~ /^else\s*$/
- && $current_line
+ && @group_lines
&& $level_jump == 0 )
{
- $j_terminal_match = fix_terminal_else( $rfields, $rtokens, $rpatterns );
- $jmax = @{$rfields} - 1;
+
+ $j_terminal_match =
+ fix_terminal_else( $group_lines[-1], $rfields, $rtokens, $rpatterns );
+ $jmax = @{$rfields} - 1;
}
# --------------------------------------------------------------------
- # Step 1. Handle simple line of code with no fields to match.
+ # Handle simple line of code with no fields to match.
# --------------------------------------------------------------------
if ( $jmax <= 0 ) {
$zero_count++;
- if ( $maximum_line_index >= 0
+ if ( @group_lines
&& !get_recoverable_spaces( $group_lines[0]->get_indentation() ) )
{
}
}
- # patch to start new COMMENT group if this comment may be outdented
+ # start new COMMENT group if this comment may be outdented
if ( $is_block_comment
&& $outdent_long_lines
- && $maximum_line_index < 0 )
+ && !@group_lines )
{
- $group_type = 'COMMENT';
- $comment_leading_space_count = $leading_space_count;
- $group_lines[ ++$maximum_line_index ] = $rfields->[0];
+ $group_type = 'COMMENT';
+ $comment_leading_space_count = $leading_space_count;
+ push_group_line( $rfields->[0] );
return;
}
# just write this line directly if no current group, no side comment,
# and no space recovery is needed.
- if ( $maximum_line_index < 0 && !get_recoverable_spaces($indentation) )
- {
+ if ( !@group_lines && !get_recoverable_spaces($indentation) ) {
valign_output_step_B( $leading_space_count, $rfields->[0], 0,
$outdent_long_lines, $rvertical_tightness_flags, $level );
return;
# programming check: (shouldn't happen)
# an error here implies an incorrect call was made
- if ( $jmax > 0 && ( $#{$rtokens} != ( $jmax - 1 ) ) ) {
+ if ( @{$rfields} && ( @{$rtokens} != ( @{$rfields} - 1 ) ) ) {
+ my $nt = @{$rtokens};
+ my $nf = @{$rfields};
warning(
-"Program bug in Perl::Tidy::VerticalAligner - number of tokens = $#{$rtokens} should be one less than number of fields: $#{$rfields})\n"
+"Program bug in Perl::Tidy::VerticalAligner - number of tokens = $nt should be one less than number of fields: $nf)\n"
);
report_definite_bug();
}
+ my $maximum_line_length_for_level = maximum_line_length_for_level($level);
# --------------------------------------------------------------------
# create an object to hold this line
# --------------------------------------------------------------------
- ##my $new_line = new Perl::Tidy::VerticalAligner::Line(
my $new_line = Perl::Tidy::VerticalAligner::Line->new(
jmax => $jmax,
jmax_original_line => $jmax,
outdent_long_lines => $outdent_long_lines,
list_type => "",
is_hanging_side_comment => $is_hanging_side_comment,
- maximum_line_length => maximum_line_length_for_level($level),
+ maximum_line_length => $maximum_line_length_for_level,
rvertical_tightness_flags => $rvertical_tightness_flags,
+ is_terminal_ternary => $is_terminal_ternary,
+ j_terminal_match => $j_terminal_match,
);
- # Initialize a global flag saying if the last line of the group should
- # match end of group and also terminate the group. There should be no
- # returns between here and where the flag is handled at the bottom.
- my $col_matching_terminal = 0;
- if ( defined($j_terminal_match) ) {
-
- # remember the column of the terminal ? or { to match with
- $col_matching_terminal = $current_line->get_column($j_terminal_match);
-
- # set global flag for sub decide_if_aligned
- $is_matching_terminal_line = 1;
- }
-
# --------------------------------------------------------------------
# It simplifies things to create a zero length side comment
# if none exists.
decide_if_list($new_line);
}
- if ($current_line) {
-
- # --------------------------------------------------------------------
- # Allow hanging side comment to join current group, if any
- # This will help keep side comments aligned, because otherwise we
- # will have to start a new group, making alignment less likely.
- # --------------------------------------------------------------------
- join_hanging_comment( $new_line, $current_line )
- if $is_hanging_side_comment;
-
- # --------------------------------------------------------------------
- # If there is just one previous line, and it has more fields
- # than the new line, try to join fields together to get a match with
- # the new line. At the present time, only a single leading '=' is
- # allowed to be compressed out. This is useful in rare cases where
- # a table is forced to use old breakpoints because of side comments,
- # and the table starts out something like this:
- # my %MonthChars = ('0', 'Jan', # side comment
- # '1', 'Feb',
- # '2', 'Mar',
- # Eliminating the '=' field will allow the remaining fields to line up.
- # This situation does not occur if there are no side comments
- # because scan_list would put a break after the opening '('.
- # --------------------------------------------------------------------
- eliminate_old_fields( $new_line, $current_line );
-
- # --------------------------------------------------------------------
- # If the new line has more fields than the current group,
- # see if we can match the first fields and combine the remaining
- # fields of the new line.
- # --------------------------------------------------------------------
- eliminate_new_fields( $new_line, $current_line );
-
- # --------------------------------------------------------------------
- # Flush previous group unless all common tokens and patterns match..
- # --------------------------------------------------------------------
- check_match( $new_line, $current_line );
-
- # --------------------------------------------------------------------
- # See if there is space for this line in the current group (if any)
- # --------------------------------------------------------------------
- if ($current_line) {
- check_fit( $new_line, $current_line );
- }
- }
-
# --------------------------------------------------------------------
# Append this line to the current group (or start new group)
# --------------------------------------------------------------------
- add_to_group($new_line);
-
- # Future update to allow this to vary:
- $current_line = $new_line if ( $maximum_line_index == 0 );
+ if ( !@group_lines ) {
+ add_to_group($new_line);
+ }
+ else {
+ push_group_line($new_line);
+ }
# output this group if it ends in a terminal else or ternary line
if ( defined($j_terminal_match) ) {
+ my_flush();
+ }
- # if there is only one line in the group (maybe due to failure to match
- # perfectly with previous lines), then align the ? or { of this
- # terminal line with the previous one unless that would make the line
- # too long
- if ( $maximum_line_index == 0 ) {
- my $col_now = $current_line->get_column($j_terminal_match);
- my $pad = $col_matching_terminal - $col_now;
- my $padding_available =
- $current_line->get_available_space_on_right();
- if ( $pad > 0 && $pad <= $padding_available ) {
- $current_line->increase_field_width( $j_terminal_match, $pad );
- }
- }
+ # Force break after jump to lower level
+ if ( $level_jump < 0 ) {
my_flush();
- $is_matching_terminal_line = 0;
}
# --------------------------------------------------------------------
- # Step 8. Some old debugging stuff
+ # Some old debugging stuff
# --------------------------------------------------------------------
VALIGN_DEBUG_FLAG_APPEND && do {
print STDOUT "APPEND fields:";
if ( $jmax < $minimum_jmax_seen ) { $minimum_jmax_seen = $jmax }
# there must be one previous line
- return unless ( $maximum_line_index == 0 );
+ return unless ( @group_lines == 1 );
my $old_line = shift;
my $maximum_field_index = $old_line->get_jmax();
# $xyz => 5,
# }
-# We would like to get alignment regardless of the order of the two lines.
-# If the lines come in in this order, then we will simplify the patterns of the first line
-# in sub eliminate_new_fields.
-# If the lines come in reverse order, then we achieve this with eliminate_new_fields.
+ # We would like to get alignment regardless of the order of the two lines.
+ # If the lines come in in this order, then we will simplify the patterns of
+ # the first line in sub eliminate_new_fields. If the lines come in reverse
+ # order, then we achieve this with eliminate_new_fields.
# This update is currently restricted to leading '=>' matches. Although we
# could do this for both '=' and '=>', overall the results for '=' come out
initialize_for_new_group();
add_to_group($old_line);
- $current_line = $old_line;
}
return;
}
sub eliminate_new_fields {
my ( $new_line, $old_line ) = @_;
- return unless ( $maximum_line_index >= 0 );
+ return unless (@group_lines);
my $jmax = $new_line->get_jmax();
my $old_rtokens = $old_line->get_rtokens();
# first tokens agree, so combine extra new tokens
if ($match) {
- ##for my $k ( $maximum_field_index .. $jmax - 1 ) {
foreach my $k ( $maximum_field_index .. $jmax - 1 ) {
$rfields->[ $maximum_field_index - 1 ] .= $rfields->[$k];
#
# returns 1 if the terminal item should be indented
- my ( $rfields, $rtokens, $rpatterns ) = @_;
+ my ( $old_line, $rfields, $rtokens, $rpatterns ) = @_;
+ return unless ($old_line);
+
+## FUTURE CODING
+## my ( $old_line, $end_line ) = @_;
+## return unless ( $old_line && $end_line );
+##
+## my $rfields = $end_line->get_rfields();
+## my $rpatterns = $end_line->get_rpatterns();
+## my $rtokens = $end_line->get_rtokens();
my $jmax = @{$rfields} - 1;
- my $old_line = $group_lines[$maximum_line_index];
my $rfields_old = $old_line->get_rfields();
my $rpatterns_old = $old_line->get_rpatterns();
@{$rfields} = @fields;
@{$rtokens} = @tokens;
@{$rpatterns} = @patterns;
+## FUTURE CODING
+## $end_line->set_rfields( \@fields );
+## $end_line->set_rtokens( \@tokens );
+## $end_line->set_rpatterns( \@patterns );
# force a flush after this line
return $jquestion;
# if ( 1 || $x ) { print "ok 13\n"; }
# else { print "not ok 13\n"; }
#
- # returns 1 if the else block should be indented
+ # returns a positive value if the else block should be indented
#
- my ( $rfields, $rtokens, $rpatterns ) = @_;
+ my ( $old_line, $rfields, $rtokens, $rpatterns ) = @_;
+ return unless ($old_line);
my $jmax = @{$rfields} - 1;
return unless ( $jmax > 0 );
+ #my $old_line = $group_lines[-1];
+
# check for balanced else block following if/elsif/unless
- my $rfields_old = $current_line->get_rfields();
+ my $rfields_old = $old_line->get_rfields();
# TBD: add handling for 'case'
return unless ( $rfields_old->[0] =~ /^(if|elsif|unless)\s*$/ );
# probably: "else # side_comment"
else { return }
- my $rpatterns_old = $current_line->get_rpatterns();
- my $rtokens_old = $current_line->get_rtokens();
- my $maximum_field_index = $current_line->get_jmax();
+ my $rpatterns_old = $old_line->get_rpatterns();
+ my $rtokens_old = $old_line->get_rtokens();
+ my $maximum_field_index = $old_line->get_jmax();
# be sure the previous if/elsif is followed by an opening paren
my $jparen = 0;
# uses global variables:
# $previous_minimum_jmax_seen
# $maximum_jmax_seen
- # $maximum_line_index
# $marginal_match
my $jmax = $new_line->get_jmax();
my $maximum_field_index = $old_line->get_jmax();
{
$marginal_match = 1
if ( $marginal_match == 0
- && $maximum_line_index == 0 );
+ && @group_lines == 1 );
last;
}
# flag this as a marginal match since patterns differ
$marginal_match = 1
- if ( $marginal_match == 0 && $maximum_line_index == 0 );
+ if ( $marginal_match == 0 && @group_lines == 1 );
# We have to be very careful about aligning commas
# when the pattern's don't match, because it can be
# We'll let this be a tentative match and undo
# it later if we don't find more than 2 lines
# in the group.
- elsif ( $maximum_line_index == 0 ) {
+ elsif ( @group_lines == 1 ) {
$marginal_match =
2; # =2 prevents being undone below
}
# variable $GoToLoc is for debugging
#print "no match from $GoToLoc\n";
- ##print "no match jmax=$jmax max=$maximum_field_index $group_list_type lines=$maximum_line_index token=$old_rtokens->[0]\n";
# Make one last effort to retain a match of certain statements
my $match = salvage_equality_matches( $new_line, $old_line );
- my_flush() unless ($match);
+ my_flush_code() unless ($match);
return;
}
}
# $xpownm1 = $class->_pow( $class->_copy($x), $nm1 ); # x(i)^(n-1)
# We will only do this if there is one old line (and one new line)
- return unless ( $maximum_line_index == 0 );
+ return unless ( @group_lines == 1 );
return if ($is_matching_terminal_line);
# We are only looking for equality type statements
# start over with a new group
initialize_for_new_group();
add_to_group($old_line);
- $current_line = $old_line;
return 1;
}
sub check_fit {
my ( $new_line, $old_line ) = @_;
- return unless ( $maximum_line_index >= 0 );
+ return unless (@group_lines);
my $jmax = $new_line->get_jmax();
my $leading_space_count = $new_line->get_leading_space_count();
$pad > $padding_available
&& $jmax == 2 # matching one thing (plus #)
&& $j == $jmax - 1 # at last field
- && $maximum_line_index > 0 # more than 1 line in group now
+ && @group_lines > 1 # more than 1 line in group now
&& $jmax < $maximum_field_index # other lines have more fields
&& length( $rfields->[$jmax] ) == 0 # no side comment
# revert to starting state then flush; things didn't work out
restore_alignment_columns();
- my_flush();
+ my_flush_code();
last;
}
# The current line either starts a new alignment group or is
# accepted into the current alignment group.
- my $new_line = shift;
- $group_lines[ ++$maximum_line_index ] = $new_line;
+ my ($new_line) = @_;
+ push_group_line($new_line);
# initialize field lengths if starting new group
- if ( $maximum_line_index == 0 ) {
+ if ( @group_lines == 1 ) {
my $jmax = $new_line->get_jmax();
my $rfields = $new_line->get_rfields();
# use previous alignments otherwise
else {
- my @new_alignments =
- $group_lines[ $maximum_line_index - 1 ]->get_alignments();
+ my @new_alignments = $group_lines[-2]->get_alignments();
$new_line->set_alignments(@new_alignments);
}
# the buffer must be emptied first, then any cached text
dump_valign_buffer();
- if ( $maximum_line_index < 0 ) {
+ if (@group_lines) {
+ my_flush();
+ }
+ else {
if ($cached_line_type) {
$seqno_string = $cached_seqno_string;
valign_output_step_C( $cached_line_text,
$cached_seqno_string = "";
}
}
- else {
- my_flush();
- }
return;
}
return;
}
-# This is the internal flush, which leaves the cache intact
+sub my_flush_comment {
+
+ # Output a group of COMMENT lines
+
+ return unless (@group_lines);
+ my $leading_space_count = $comment_leading_space_count;
+ my $leading_string = get_leading_string($leading_space_count);
+
+ # look for excessively long lines
+ my $max_excess = 0;
+ foreach my $str (@group_lines) {
+ my $excess =
+ length($str) +
+ $leading_space_count -
+ maximum_line_length_for_level($group_level);
+ if ( $excess > $max_excess ) {
+ $max_excess = $excess;
+ }
+ }
+
+ # zero leading space count if any lines are too long
+ if ( $max_excess > 0 ) {
+ $leading_space_count -= $max_excess;
+ if ( $leading_space_count < 0 ) { $leading_space_count = 0 }
+ $last_outdented_line_at = $file_writer_object->get_output_line_number();
+ unless ($outdented_line_count) {
+ $first_outdented_line_at = $last_outdented_line_at;
+ }
+ my $nlines = @group_lines;
+ $outdented_line_count += $nlines;
+ }
+
+ # write the lines
+ my $outdent_long_lines = 0;
+ foreach my $line (@group_lines) {
+ valign_output_step_B( $leading_space_count, $line, 0,
+ $outdent_long_lines, "", $group_level );
+ }
+
+ initialize_for_new_group();
+ return;
+}
+
+sub my_flush_code {
+
+ # Output a group of CODE lines
+
+ return unless (@group_lines);
+
+ VALIGN_DEBUG_FLAG_APPEND0
+ && do {
+ my $group_list_type = $group_lines[0]->get_list_type();
+ my ( $a, $b, $c ) = caller();
+ my $nlines = @group_lines;
+ my $maximum_field_index = $group_lines[0]->get_jmax();
+ my $rfields_old = $group_lines[0]->get_rfields();
+ my $tok = $rfields_old->[0];
+ print STDOUT
+"APPEND0: my_flush_code called from $a $b $c fields=$maximum_field_index list=$group_list_type lines=$nlines extra=$extra_indent_ok first tok=$tok;\n";
+
+ };
+
+ # some small groups are best left unaligned
+ my $do_not_align = decide_if_aligned_pair();
+
+ # optimize side comment location
+ $do_not_align = adjust_side_comment($do_not_align);
+
+ # recover spaces for -lp option if possible
+ my $extra_leading_spaces = get_extra_leading_spaces();
+
+ # all lines of this group have the same basic leading spacing
+ my $group_leader_length = $group_lines[0]->get_leading_space_count();
+
+ # add extra leading spaces if helpful
+ # NOTE: Use zero; this did not work well
+ my $min_ci_gap = 0;
+
+ # output the lines
+ foreach my $line (@group_lines) {
+ valign_output_step_A( $line, $min_ci_gap, $do_not_align,
+ $group_leader_length, $extra_leading_spaces );
+ }
+
+ initialize_for_new_group();
+ return;
+}
+
sub my_flush {
- return if ( $maximum_line_index < 0 );
+ # This is the vertical aligner internal flush, which leaves the cache
+ # intact
+ return unless (@group_lines);
- # handle a group of comment lines
- if ( $group_type eq 'COMMENT' ) {
+ VALIGN_DEBUG_FLAG_APPEND0 && do {
+ my ( $a, $b, $c ) = caller();
+ my $nlines = @group_lines;
+ print STDOUT
+"APPEND0: my_flush called from $a $b $c lines=$nlines, type=$group_type \n";
+ };
+
+ # handle a group of COMMENT lines
+ if ( $group_type eq 'COMMENT' ) { my_flush_comment() }
+
+ # handle a single line of CODE
+ elsif ( @group_lines == 1 ) { my_flush_code() }
+
+ # handle group(s) of CODE lines
+ else {
+
+ # LP FIX PART 1
+ # If we are trying to add extra indentation for -lp formatting,
+ # then we need to try to keep the group intact. But we have
+ # to set the $extra_indent_ok flag to zero in case some lines
+ # are output separately. We fix things up at the bottom.
+ # NOTE: this is a workaround but is tentative; we should really look to
+ # see if if extra indentation is possible.
+ my $rOpt_lp = $rOpts->{'line-up-parentheses'};
+ my $keep_group_intact = $rOpt_lp && $extra_indent_ok;
+ my $extra_indent_ok_save = $extra_indent_ok;
+ $extra_indent_ok = 0;
+
+ # we will rebuild alignment line group(s);
+ my @new_lines = @group_lines;
+ initialize_for_new_group();
+
+ ##my $has_terminal_ternary = $new_lines[-1]->{_is_terminal_ternary};
+
+ # remove unmatched tokens in all lines
+ delete_unmatched_tokens( \@new_lines );
- VALIGN_DEBUG_FLAG_APPEND0 && do {
- my ( $a, $b, $c ) = caller();
- print STDOUT
-"APPEND0: Flush called from $a $b $c for COMMENT group: lines=$maximum_line_index \n";
-
- };
- my $leading_space_count = $comment_leading_space_count;
- my $leading_string = get_leading_string($leading_space_count);
-
- # zero leading space count if any lines are too long
- my $max_excess = 0;
- for my $i ( 0 .. $maximum_line_index ) {
- my $str = $group_lines[$i];
- my $excess =
- length($str) +
- $leading_space_count -
- maximum_line_length_for_level($group_level);
- if ( $excess > $max_excess ) {
- $max_excess = $excess;
+ foreach my $new_line (@new_lines) {
+
+ # Start a new group if necessary
+ if ( !@group_lines ) {
+ add_to_group($new_line);
+
+ next;
}
- }
- if ( $max_excess > 0 ) {
- $leading_space_count -= $max_excess;
- if ( $leading_space_count < 0 ) { $leading_space_count = 0 }
- $last_outdented_line_at =
- $file_writer_object->get_output_line_number();
- unless ($outdented_line_count) {
- $first_outdented_line_at = $last_outdented_line_at;
+ my $j_terminal_match = $new_line->get_j_terminal_match();
+ my $base_line = $group_lines[0];
+
+ # Initialize a global flag saying if the last line of the group
+ # should match end of group and also terminate the group. There
+ # should be no returns between here and where the flag is handled
+ # at the bottom.
+ my $col_matching_terminal = 0;
+ if ( defined($j_terminal_match) ) {
+
+ # remember the column of the terminal ? or { to match with
+ $col_matching_terminal =
+ $base_line->get_column($j_terminal_match);
+
+ # set global flag for sub decide_if_aligned_pair
+ $is_matching_terminal_line = 1;
+ }
+
+ # -------------------------------------------------------------
+ # Allow hanging side comment to join current group, if any. This
+ # will help keep side comments aligned, because otherwise we
+ # will have to start a new group, making alignment less likely.
+ # -------------------------------------------------------------
+
+ if ( $new_line->get_is_hanging_side_comment() ) {
+ join_hanging_comment( $new_line, $base_line );
+ }
+
+ # If this line has no matching tokens, then flush out the lines
+ # BEFORE this line unless both it and the previous line have side
+ # comments. This prevents this line from pushing side coments out
+ # to the right.
+ ##elsif ( $new_line->get_jmax() == 1 ) {
+ elsif ( $new_line->get_jmax() == 1 && !$keep_group_intact ) {
+
+ # There are no matching tokens, so now check side comments:
+ my $prev_comment = $group_lines[-1]->get_rfields()->[-1];
+ my $side_comment = $new_line->get_rfields()->[-1];
+ my_flush_code() unless ( $side_comment && $prev_comment );
+
+ }
+
+ # -------------------------------------------------------------
+ # If there is just one previous line, and it has more fields
+ # than the new line, try to join fields together to get a match
+ # with the new line. At the present time, only a single
+ # leading '=' is allowed to be compressed out. This is useful
+ # in rare cases where a table is forced to use old breakpoints
+ # because of side comments,
+ # and the table starts out something like this:
+ # my %MonthChars = ('0', 'Jan', # side comment
+ # '1', 'Feb',
+ # '2', 'Mar',
+ # Eliminating the '=' field will allow the remaining fields to
+ # line up. This situation does not occur if there are no side
+ # comments because scan_list would put a break after the
+ # opening '('.
+ # -------------------------------------------------------------
+
+ eliminate_old_fields( $new_line, $base_line );
+
+ # -------------------------------------------------------------
+ # If the new line has more fields than the current group,
+ # see if we can match the first fields and combine the remaining
+ # fields of the new line.
+ # -------------------------------------------------------------
+
+ eliminate_new_fields( $new_line, $base_line );
+
+ # -------------------------------------------------------------
+ # Flush previous group unless all common tokens and patterns
+ # match..
+
+ check_match( $new_line, $base_line );
+
+ # -------------------------------------------------------------
+ # See if there is space for this line in the current group (if
+ # any)
+ # -------------------------------------------------------------
+ if (@group_lines) {
+ check_fit( $new_line, $base_line );
+ }
+
+ add_to_group($new_line);
+
+ if ( defined($j_terminal_match) ) {
+
+ # if there is only one line in the group (maybe due to failure
+ # to match perfectly with previous lines), then align the ? or
+ # { of this terminal line with the previous one unless that
+ # would make the line too long
+ if ( @group_lines == 1 ) {
+ $base_line = $group_lines[0];
+ my $col_now = $base_line->get_column($j_terminal_match);
+ my $pad = $col_matching_terminal - $col_now;
+ my $padding_available =
+ $base_line->get_available_space_on_right();
+ if ( $pad > 0 && $pad <= $padding_available ) {
+ $base_line->increase_field_width( $j_terminal_match,
+ $pad );
+ }
+ }
+ my_flush_code();
+ $is_matching_terminal_line = 0;
+ }
+
+ # Optional optimization; end the group if we know we cannot match
+ # next line.
+ elsif ( $new_line->{_end_group} ) {
+ my_flush_code();
}
- $outdented_line_count += ( $maximum_line_index + 1 );
}
- # write the group of lines
- my $outdent_long_lines = 0;
- for my $i ( 0 .. $maximum_line_index ) {
- valign_output_step_B( $leading_space_count, $group_lines[$i], 0,
- $outdent_long_lines, "", $group_level );
+ # LP FIX PART 2
+ # if we managed to keep the group intact for -lp formatting,
+ # restore the flag which allows extra indentation
+ if ( $keep_group_intact && @group_lines == @new_lines ) {
+ $extra_indent_ok = $extra_indent_ok_save;
}
+ my_flush_code();
}
+ return;
+}
- # handle a group of code lines
- else {
+sub delete_selected_tokens {
+
+ my ( $line_obj, $ridel ) = @_;
+
+ # remove an unused alignment token(s) to improve alignment chances
+ return unless ( defined($line_obj) && defined($ridel) && @{$ridel} );
+
+ my $jmax_old = $line_obj->get_jmax();
+ my $rfields_old = $line_obj->get_rfields();
+ my $rpatterns_old = $line_obj->get_rpatterns();
+ my $rtokens_old = $line_obj->get_rtokens();
+
+ local $" = '> <';
+ 0 && print <<EOM;
+delete indexes: <@{$ridel}>
+old jmax: $jmax_old
+old tokens: <@{$rtokens_old}>
+old patterns: <@{$rpatterns_old}>
+old fields: <@{$rfields_old}>
+EOM
+
+ my $rfields_new = [];
+ my $rpatterns_new = [];
+ my $rtokens_new = [];
+
+ my $kmax = @{$ridel} - 1;
+ my $k = 0;
+ my $jdel_next = $ridel->[$k];
+
+ # FIXME:
+ if ( $jdel_next < 0 ) { print STDERR "bad jdel_next=$jdel_next\n"; return }
+ my $pattern = $rpatterns_old->[0];
+ my $field = $rfields_old->[0];
+ push @{$rfields_new}, $field;
+ push @{$rpatterns_new}, $pattern;
+ for ( my $j = 0 ; $j < $jmax_old ; $j++ ) {
+ my $token = $rtokens_old->[$j];
+ my $field = $rfields_old->[ $j + 1 ];
+ my $pattern = $rpatterns_old->[ $j + 1 ];
+ if ( $k > $kmax || $j < $jdel_next ) {
+ push @{$rtokens_new}, $token;
+ push @{$rfields_new}, $field;
+ push @{$rpatterns_new}, $pattern;
+ }
+ elsif ( $j == $jdel_next ) {
+ $rfields_new->[-1] .= $field;
+ $rpatterns_new->[-1] .= $pattern;
+ if ( ++$k <= $kmax ) {
+ my $jdel_last = $jdel_next;
+ $jdel_next = $ridel->[$k];
+ if ( $jdel_next < $jdel_last ) {
+
+ # FIXME:
+ print STDERR "bad jdel_next=$jdel_next\n";
+ return;
+ }
+ }
+ }
+ }
- VALIGN_DEBUG_FLAG_APPEND0 && do {
- my $group_list_type = $group_lines[0]->get_list_type();
- my ( $a, $b, $c ) = caller();
- my $maximum_field_index = $group_lines[0]->get_jmax();
- print STDOUT
-"APPEND0: Flush called from $a $b $c fields=$maximum_field_index list=$group_list_type lines=$maximum_line_index extra=$extra_indent_ok\n";
+ # ----- x ------ x ------ x ------
+ #t 0 1 2 <- token indexing
+ #f 0 1 2 3 <- field and pattern
- };
+ my $jmax_new = @{$rfields_new} - 1;
+ $line_obj->set_rtokens($rtokens_new);
+ $line_obj->set_rpatterns($rpatterns_new);
+ $line_obj->set_rfields($rfields_new);
+ $line_obj->set_jmax($jmax_new);
- # some small groups are best left unaligned
- my $do_not_align = decide_if_aligned();
+ 0 && print <<EOM;
+
+new jmax: $jmax_new
+new tokens: <@{$rtokens_new}>
+new patterns: <@{$rpatterns_new}>
+new fields: <@{$rfields_new}>
+EOM
+ return;
+}
- # optimize side comment location
- $do_not_align = adjust_side_comment($do_not_align);
+{ # sub is_deletable_token
- # recover spaces for -lp option if possible
- my $extra_leading_spaces = get_extra_leading_spaces();
+ my %is_deletable_equals;
- # all lines of this group have the same basic leading spacing
- my $group_leader_length = $group_lines[0]->get_leading_space_count();
+ BEGIN {
+ my @q;
+
+ # These tokens with = may be deleted for vertical aligmnemt
+ @q = qw(
+ <= >= == =~ != <=>
+ );
+ @is_deletable_equals{@q} = (1) x scalar(@q);
+
+ }
- # add extra leading spaces if helpful
- # NOTE: Use zero; this did not work well
- my $min_ci_gap = 0;
+ sub is_deletable_token {
- # loop to output all lines
- for my $i ( 0 .. $maximum_line_index ) {
- my $line = $group_lines[$i];
- valign_output_step_A( $line, $min_ci_gap, $do_not_align,
- $group_leader_length, $extra_leading_spaces );
+ # Determine if an token with no match possibility can be removed to
+ # improve chances of making an alignment.
+ my ( $token, $i, $imax, $jline, $i_eq ) = @_;
+
+ # Strip off the level and other stuff appended to the token.
+ # Tokens have a trailing decimal level and optional tag (for commas):
+ # For example, the first comma in the following line
+ # sub banner { crlf; report( shift, '/', shift ); crlf }
+ # is decorated as follows:
+ # ,2+report-6 => (tok,lev,tag) =qw( , 2 +report-6)
+ my ( $tok, $lev, $tag ) = ( $token, 0, "" );
+ if ( $tok =~ /^(\D+)(\d+)(.*)$/ ) { $tok = $1; $lev = $2; $tag = $3 }
+ ##print "$token >> $tok $lev $tag\n";
+
+ # only remove lower level commas
+ ##if ( $tok eq ',' ) { return unless $lev > $group_level; }
+ if ( $tok eq ',' ) {
+
+ #print "tok=$tok, lev=$lev, gl=$group_level, i=$i, ieq=$i_eq\n";
+ return if ( defined($i_eq) && $i < $i_eq );
+ return if ( $lev >= $group_level );
+ }
+
+ # most operators with an equals sign should be retained if at
+ # same level as this statement
+ elsif ( $tok =~ /=/ ) {
+ return unless ( $lev > $group_level || $is_deletable_equals{$tok} );
}
+
+ # otherwise, ok to delete the token
+ return 1;
}
- initialize_for_new_group();
+}
+
+sub delete_unmatched_tokens {
+ my ($rlines) = @_;
+
+ # We will look at each line of a collection and compare its alignment
+ # tokens with its neighbors. If it has alignment tokens which do not match
+ # either neighbor, then we will usually remove them. This will
+ # simplify later work and improve chances of aligning.
+
+ return unless @{$rlines};
+ my $has_terminal_match = $rlines->[-1]->get_j_terminal_match();
+
+ # ignore hanging side comments
+ my @filtered = grep { !$_->{_is_hanging_side_comment} } @{$rlines};
+ my $rnew_lines = \@filtered;
+ my @i_equals;
+
+ # Step 1: create a hash of tokens for each line
+ my $rline_hashes = [];
+ foreach my $line ( @{$rnew_lines} ) {
+ my $rhash = {};
+ my $rtokens = $line->get_rtokens();
+ my $i = 0;
+ my $i_eq;
+ foreach my $tok ( @{$rtokens} ) {
+ $rhash->{$tok} = [ $i, undef, undef ];
+
+ # remember the first equals at line level
+ if ( !defined($i_eq) && $tok =~ /^=(\d+)/ ) {
+ my $lev = $1;
+ if ( $lev eq $group_level ) { $i_eq = $i }
+ }
+ $i++;
+ }
+ push @{$rline_hashes}, $rhash;
+ push @i_equals, $i_eq;
+ }
+
+ # Step 2: compare each line pair and record matches
+ for ( my $jl = 0 ; $jl < @{$rline_hashes} - 1 ; $jl++ ) {
+ my $jr = $jl + 1;
+ my $rhash_l = $rline_hashes->[$jl];
+ my $rhash_r = $rline_hashes->[$jr];
+ my $count = 0;
+ my $ntoks = 0;
+ foreach my $tok ( keys %{$rhash_l} ) {
+ $ntoks++;
+ if ( defined( $rhash_r->{$tok} ) ) {
+ if ( $tok ne '#' ) { $count++; }
+ my $il = $rhash_l->{$tok}->[0];
+ my $ir = $rhash_r->{$tok}->[0];
+ $rhash_l->{$tok}->[2] = $ir;
+ $rhash_r->{$tok}->[1] = $il;
+ }
+ }
+ }
+
+ # Step 3: remove unmatched tokens
+ my $jj = 0;
+ my $jmax = @{$rnew_lines} - 1;
+ foreach my $line ( @{$rnew_lines} ) {
+ my $rtokens = $line->get_rtokens();
+ my $rhash = $rline_hashes->[$jj];
+ my $i = 0;
+ my $nl = 0;
+ my $nr = 0;
+ my $i_eq = $i_equals[$jj];
+ my @idel;
+ my $imax = @{$rtokens} - 2;
+
+ for ( my $i = 0 ; $i <= $imax ; $i++ ) {
+ my $tok = $rtokens->[$i];
+ next if ( $tok eq '#' ); # shouldn't happen
+ my ( $il, $ir ) = @{ $rhash->{$tok} }[ 1, 2 ];
+ $nl++ if defined($il);
+ $nr++ if defined($ir);
+ if (
+ !defined($il)
+ && !defined($ir)
+ && is_deletable_token( $tok, $i, $imax, $jj, $i_eq )
+
+ # Patch: do not touch the first line of a terminal match,
+ # such as below, because j_terminal has already been set.
+ # if ($tag) { $tago = "<$tag>"; $tagc = "</$tag>"; }
+ # else { $tago = $tagc = ''; }
+ # But see snippets 'else1.t' and 'else2.t'
+ && !( $jj == 0 && $has_terminal_match && $jmax == 1 )
+
+ )
+ {
+ push @idel, $i;
+ }
+ }
+
+ if (@idel) { delete_selected_tokens( $line, \@idel ) }
+
+ # set a break if this is an interior line with possible left matches
+ # but no matches to the right. We do not do this for the last line
+ # because it could be followed by hanging side comments filtered out
+ # above.
+ if ( $nr == 0 && $nl > 0 && $jj < @{$rnew_lines} - 1 ) {
+ $rnew_lines->[$jj]->{_end_group} = 1;
+ }
+ $jj++;
+ }
+
+ #use Data::Dumper;
+ #print Data::Dumper->Dump( [$rline_hashes] );
return;
}
-sub decide_if_aligned {
+sub decide_if_aligned_pair {
# Do not try to align two lines which are not really similar
- return unless $maximum_line_index == 1;
+ return unless ( @group_lines == 2 );
return if ($is_matching_terminal_line);
my $group_list_type = $group_lines[0]->get_list_type();
# a has side comment
my $rfields = $group_lines[0]->get_rfields();
my $maximum_field_index = $group_lines[0]->get_jmax();
- if ( $do_not_align
- && ( $maximum_line_index > 0 )
+ if ( $do_not_align
&& ( length( $rfields->[$maximum_field_index] ) > 0 ) )
{
combine_fields();
my $have_side_comment = 0;
my $first_side_comment_line = -1;
my $maximum_field_index = $group_lines[0]->get_jmax();
- for my $i ( 0 .. $maximum_line_index ) {
- my $line = $group_lines[$i];
-
+ my $i = 0;
+ foreach my $line (@group_lines) {
if ( length( $line->get_rfields()->[$maximum_field_index] ) ) {
$have_side_comment = 1;
$first_side_comment_line = $i;
last;
}
+ $i++;
}
my $kmax = $maximum_field_index + 1;
###############################################################
# This is Step A in writing vertically aligned lines.
# The line is prepared according to the alignments which have
- # been found and shipped to the next step.
+ # been found. Then it is shipped to the next step.
###############################################################
my ( $line, $min_ci_gap, $do_not_align, $group_leader_length,
get_recoverable_spaces($object);
# all indentation objects must be the same
- for my $i ( 1 .. $maximum_line_index ) {
+ for my $i ( 1 .. @group_lines - 1 ) {
if ( $object != $group_lines[$i]->get_indentation() ) {
$extra_indentation_spaces_wanted = 0;
last;
# combine all fields except for the comment field ( sidecmt.t )
# Uses global variables:
# @group_lines
- # $maximum_line_index
my $maximum_field_index = $group_lines[0]->get_jmax();
- foreach my $j ( 0 .. $maximum_line_index ) {
- my $line = $group_lines[$j];
+ foreach my $line (@group_lines) {
my $rfields = $line->get_rfields();
foreach ( 1 .. $maximum_field_index - 1 ) {
$rfields->[0] .= $rfields->[$_];
}
$maximum_field_index = 1;
- for my $j ( 0 .. $maximum_line_index ) {
- my $line = $group_lines[$j];
+ foreach my $line (@group_lines) {
my $rfields = $line->get_rfields();
for my $k ( 0 .. $maximum_field_index ) {
my $pad = length( $rfields->[$k] ) - $line->current_field_width($k);
if ( $k == 0 ) {
- $pad += $group_lines[$j]->get_leading_space_count();
+ $pad += $line->get_leading_space_count();
}
if ( $pad > 0 ) { $line->increase_field_width( $k, $pad ) }
# the output line number reported to a caller is the number of items
# written plus the number of items in the buffer
- my $self = shift;
- return 1 + $maximum_line_index +
- $file_writer_object->get_output_line_number();
+ my $self = shift;
+ my $nlines = @group_lines;
+ return $nlines + $file_writer_object->get_output_line_number();
}
sub valign_output_step_B {
return;
}
1;
-
package Perl::Tidy::VerticalAligner::Alignment;
use strict;
use warnings;
-our $VERSION = '20181120';
+our $VERSION = '20190601';
{
package Perl::Tidy::VerticalAligner::Line;
use strict;
use warnings;
-our $VERSION = '20181120';
+our $VERSION = '20190601';
{
is_hanging_side_comment => undef,
ralignments => [],
maximum_line_length => undef,
- rvertical_tightness_flags => undef
+ rvertical_tightness_flags => undef,
+ is_terminal_ternary => undef,
+ is_terminal_else => undef,
+ j_terminal_match => undef,
);
{
sub get_rpatterns { my $self = shift; return $self->{_rpatterns} }
sub get_indentation { my $self = shift; return $self->{_indentation} }
+ sub get_j_terminal_match {
+ my $self = shift;
+ return $self->{_j_terminal_match};
+ }
+
+ sub get_is_terminal_else {
+ my $self = shift;
+ return $self->{_is_terminal_else};
+ }
+
+ sub get_is_terminal_ternary {
+ my $self = shift;
+ return $self->{_is_terminal_ternary};
+ }
+
sub get_leading_space_count {
my $self = shift;
return $self->{_leading_space_count};
[ keys %main:: ] ~~ \%::;
\%:: ~~ [];
[] ~~ \%::;
-{ "" => 1 } ~~ [undef];
-[undef] ~~ { "" => 1 };
-{ foo => 1 } ~~ qr/^(fo[ox])$/;
-qr/^(fo[ox])$/ ~~ { foo => 1 };
-+{ 0 .. 100 } ~~ qr/[13579]$/;
-qr/[13579]$/ ~~ +{ 0 .. 100 };
+{ "" => 1 } ~~ [undef];
+[undef] ~~ { "" => 1 };
+{ foo => 1 } ~~ qr/^(fo[ox])$/;
+qr/^(fo[ox])$/ ~~ { foo => 1 };
++{ 0 .. 100 } ~~ qr/[13579]$/;
+qr/[13579]$/ ~~ +{ 0 .. 100 };
+{ foo => 1, bar => 2 } ~~ "foo";
"foo" ~~ +{ foo => 1, bar => 2 };
+{ foo => 1, bar => 2 } ~~ "baz";
"baz" ~~ +{ foo => 1, bar => 2 };
-[] ~~ [];
-[] ~~ [];
-[] ~~ [1];
-[1] ~~ [];
+[] ~~ [];
+[] ~~ [];
+[] ~~ [1];
+[1] ~~ [];
[ ["foo"], ["bar"] ] ~~ [ qr/o/, qr/a/ ];
[ qr/o/, qr/a/ ] ~~ [ ["foo"], ["bar"] ];
[ "foo", "bar" ] ~~ [ qr/o/, qr/a/ ];
expect => <<'#12...........',
if ( $PLATFORM eq 'aix' ) {
skip_symbols( [ qw(
- Perl_dump_fds
- Perl_ErrorNo
- Perl_GetVars
- PL_sys_intern
- ) ] );
+ Perl_dump_fds
+ Perl_ErrorNo
+ Perl_GetVars
+ PL_sys_intern
+ ) ] );
}
#12...........
},
expect => <<'#18...........',
# qw weld with -wn
use_all_ok( qw{
- PPI
- PPI::Tokenizer
- PPI::Lexer
- PPI::Dumper
- PPI::Find
- PPI::Normal
- PPI::Util
- PPI::Cache
- } );
+ PPI
+ PPI::Tokenizer
+ PPI::Lexer
+ PPI::Dumper
+ PPI::Find
+ PPI::Normal
+ PPI::Util
+ PPI::Cache
+} );
#18...........
},
#13 align21.def
#14 align22.def
#15 align23.def
+#16 align24.def
+#17 align25.def
+#18 align26.def
+#19 align27.def
# To locate test #13 you can search for its name or the string '#13'
# two equality lines with same pattern on left of equals will align
my $orig = my $format = "^<<<<< ~~\n";
my $abc = "abc";
+----------
+
+ 'align24' => <<'----------',
+# Do not align interior fat commas here; differnt container types
+my $p = TAP::Parser::SubclassTest->new(
+ {
+ exec => [ $cat => $file ],
+ sources => { MySourceHandler => { accept_all => 1 } },
+ }
+);
+----------
+
+ 'align25' => <<'----------',
+# do not align commas here; different container types
+is_deeply( [ $a, $a ], [ $b, $c ] );
+is_deeply( { foo => $a, bar => $a }, { foo => $b, bar => $c } );
+is_deeply( [ \$a, \$a ], [ \$b, \$c ] );
+
+----------
+
+ 'align26' => <<'----------',
+# align first of multiple equals
+$SIG{PIPE}=sub{die"writingtoaclosedpipe"};#1=
+$SIG{HUP}=$SIG{BREAK}=$SIG{INT}=$SIG{TERM};#3=
+----------
+
+ 'align27' => <<'----------',
+# do not align first equals here (unmatched commas on left side of =)
+my ( $self, $name, $type ) = @_;
+my $html_toc_fh = $self->{_html_toc_fh};
+my $html_prelim_fh = $self->{_html_prelim_fh};
----------
'break5' => <<'----------',
source => "align12",
params => "def",
expect => <<'#3...........',
- my $type = shift || "o";
- my $fname = ( $type eq 'oo' ? 'orte_city' : 'orte' );
+ my $type = shift || "o";
+ my $fname = ( $type eq 'oo' ? 'orte_city' : 'orte' );
my $suffix = ( $coord_system eq 'standard' ? '' : '-orig' );
#3...........
},
my $abc = "abc";
#15...........
},
+
+ 'align24.def' => {
+ source => "align24",
+ params => "def",
+ expect => <<'#16...........',
+# Do not align interior fat commas here; differnt container types
+my $p = TAP::Parser::SubclassTest->new(
+ {
+ exec => [ $cat => $file ],
+ sources => { MySourceHandler => { accept_all => 1 } },
+ }
+);
+#16...........
+ },
+
+ 'align25.def' => {
+ source => "align25",
+ params => "def",
+ expect => <<'#17...........',
+# do not align commas here; different container types
+is_deeply( [ $a, $a ], [ $b, $c ] );
+is_deeply( { foo => $a, bar => $a }, { foo => $b, bar => $c } );
+is_deeply( [ \$a, \$a ], [ \$b, \$c ] );
+
+#17...........
+ },
+
+ 'align26.def' => {
+ source => "align26",
+ params => "def",
+ expect => <<'#18...........',
+# align first of multiple equals
+$SIG{PIPE} = sub { die "writingtoaclosedpipe" }; #1=
+$SIG{HUP} = $SIG{BREAK} = $SIG{INT} = $SIG{TERM}; #3=
+#18...........
+ },
+
+ 'align27.def' => {
+ source => "align27",
+ params => "def",
+ expect => <<'#19...........',
+# do not align first equals here (unmatched commas on left side of =)
+my ( $self, $name, $type ) = @_;
+my $html_toc_fh = $self->{_html_toc_fh};
+my $html_prelim_fh = $self->{_html_prelim_fh};
+#19...........
+ },
};
my $ntests = 0 + keys %{$rtests};
--- /dev/null
+# Created with: ./make_t.pl
+
+# Contents:
+#1 else1.def
+#2 else2.def
+#3 ternary3.def
+#4 align17.def
+#5 align18.def
+#6 kgb1.def
+#7 kgb1.kgb
+#8 kgb2.def
+#9 kgb2.kgb
+#10 kgb3.def
+#11 kgb3.kgb
+#12 kgb4.def
+#13 kgb4.kgb
+#14 kgb5.def
+#15 kgb5.kgb
+#16 kgbd.def
+#17 kgbd.kgbd
+#18 kgb_tight.def
+#19 gnu5.def
+
+# To locate test #13 you can search for its name or the string '#13'
+
+use strict;
+use Test;
+use Carp;
+use Perl::Tidy;
+my $rparams;
+my $rsources;
+my $rtests;
+
+BEGIN {
+
+ ###########################################
+ # BEGIN SECTION 1: Parameter combinations #
+ ###########################################
+ $rparams = {
+ 'def' => "",
+ 'kgb' => "-kgb",
+ 'kgbd' => "-kgbd -kgb",
+ };
+
+ ############################
+ # BEGIN SECTION 2: Sources #
+ ############################
+ $rsources = {
+
+ 'align17' => <<'----------',
+# align => even at broken sub block
+my%opt=(
+'cc'=>sub{$param::cachecom=1;},
+'cd'=>sub{$param::cachedisable=1;},
+'p'=>sub{
+$param::pflag=1;
+$param::build=0;
+}
+);
+----------
+
+ 'align18' => <<'----------',
+#align '&&'
+for($ENV{HTTP_USER_AGENT}){
+$page=
+/Mac/&&'m/Macintrash.html'
+||/Win(dows)?NT/&&'e/evilandrude.html'
+||/Win|MSIE|WebTV/&&'m/MicroslothWindows.html'
+||/Linux/&&'l/Linux.html'
+||/HP-UX/&&'h/HP-SUX.html'
+||/SunOS/&&'s/ScumOS.html'
+||'a/AppendixB.html';
+}
+----------
+
+ 'else1' => <<'----------',
+# pad after 'if' when followed by 'elsif'
+if ( not defined $dir or not length $dir ) { $rslt = ''; }
+elsif ( $dir =~ /^\$\([^\)]+\)\Z(?!\n)/s ) { $rslt = $dir; }
+else { $rslt = vmspath($dir); }
+----------
+
+ 'else2' => <<'----------',
+ # no pad after 'if' when followed by 'else'
+ if ( $m = $g[$x][$y] ) { print $$m{v}; $$m{i}->() }
+ else { print " " }
+----------
+
+ 'gnu5' => <<'----------',
+ # side comments limit gnu type formatting with l=80; note extra comma
+ push @tests, [
+ "Lowest code point requiring 13 bytes to represent", # 2**36
+ "\xff\x80\x80\x80\x80\x80\x81\x80\x80\x80\x80\x80\x80",
+ ($::is64bit) ? 0x1000000000 : -1, # overflows on 32bit
+ ],
+ ;
+----------
+
+ 'kgb1' => <<'----------',
+# a variety of line types for testing -kgb
+use strict;
+use Test;
+use Encode qw(from_to encode decode
+ encode_utf8 decode_utf8
+ find_encoding is_utf8);
+use charnames qw(greek);
+our $targetdir = "/usr/local/doc/HTML/Perl";
+local (
+ $tocfile, $loffile, $lotfile, $footfile,
+ $citefile, $idxfile, $figure_captions, $table_captions,
+ $footnotes, $citations, %font_size, %index,
+ %done, $t_title, $t_author, $t_date,
+ $t_address, $t_affil, $changed
+);
+my @UNITCHECKs =
+ B::unitcheck_av->isa("B::AV")
+ ? B::unitcheck_av->ARRAY
+ : ();
+my @CHECKs = B::check_av->isa("B::AV") ? B::check_av->ARRAY : ();
+my $dna = Bio::LiveSeq::DNA->new( -seq => $dnasequence );
+my $min = 1;
+my $max = length($dnasequence);
+my $T = $G->_strongly_connected;
+my %R = $T->vertex_roots;
+my @C; # We're not calling the strongly_connected_components()
+ # Do not separate this hanging side comment from previous
+my $G = shift;
+my $exon = Bio::LiveSeq::Exon->new(
+ -seq => $dna,
+ -start => $min,
+ -end => $max,
+ -strand => 1
+);
+my $octal_mode;
+my @inputs = (
+ 0777, 0700, 0470, 0407, 0433, 0400, 0430, 0403, 0111, 0100,
+ 0110, 0101, 0731, 0713, 0317, 0371, 0173, 0137
+);
+my $impulse =
+ ( 1 - $factor ) * ( 170 - $u ) +
+ ( 350 / $u**0.65 + 500 / $u**5 ) * $factor;
+my $r = q{
+pm_to_blib: $(TO_INST_PM)
+};
+my $regcomp_re =
+ "(?<routine>ckWARN(?:\\d+)?reg\\w*|vWARN\\d+|$regcomp_fail_re)";
+my $position = List::MoreUtils::firstidx {
+ refaddr $_ == $key
+}
+my @exons = ($exon);
+my $fastafile2 = "/tmp/tmpfastafile2";
+my $grepcut = 'egrep -v "[[:digit:]]|^ *$|sequences" | cut -c8-'; # grep/cut
+my $alignprogram =
+"/usr/local/etc/bioinfo/fasta2/align -s /usr/local/etc/bioinfo/fasta2/idnaa.mat $fastafile1 $fastafile2 2>/dev/null | $grepcut"
+ ; # ALIGN
+my $xml = new Mioga::XML::Simple( forcearray => 1 );
+my $xml_tree = $xml->XMLin($skel_file);
+my $skel_name =
+ ( exists( $xml_tree->{'name'} ) ) ? $xml_tree->{'name'} : "";
+my $grp = GroupGetValues( $conf->{dbh}, $group_id );
+my $adm_profile =
+ ProfileGetUser( $conf->{dbh}, $grp->{id_admin}, $group_id );
+my $harness = TAP::Harness->new(
+ { verbosity => 1, formatter_class => "TAP::Formatter::Console" } );
+require File::Temp;
+require Time::HiRes;
+my ( $fh, $filename ) = File::Temp::tempfile("Time-HiRes-utime-XXXXXXXXX");
+use File::Basename qw[dirname];
+my $dirname = dirname($filename);
+my $CUT = qr/\n=cut.*$EOP/;
+my $pod_or_DATA = qr/
+ ^=(?:head[1-4]|item) .*? $CUT
+ | ^=pod .*? $CUT
+ | ^=for .*? $CUT
+ | ^=begin .*? $CUT
+ | ^__(DATA|END)__\r?\n.*
+ /smx;
+require Cwd;
+( my $boot = $self->{NAME} ) =~ s/:/_/g;
+doit(
+sub { @E::ISA = qw/F/ },
+sub { @E::ISA = qw/D/; @C::ISA = qw/F/ },
+sub { @C::ISA = qw//; @A::ISA = qw/K/ },
+sub { @A::ISA = qw//; @J::ISA = qw/F K/ },
+sub { @J::ISA = qw/F/; @H::ISA = qw/K G/ },
+sub { @H::ISA = qw/G/; @B::ISA = qw/B/ },
+sub { @B::ISA = qw//; @K::ISA = qw/K J I/ },
+sub { @K::ISA = qw/J I/; @D::ISA = qw/A H B C/ },
+return;
+);
+my %extractor_for = (
+ quotelike => [ $ws, $variable, $id, { MATCH => \&extract_quotelike } ],
+ regex => [ $ws, $pod_or_DATA, $id, $exql ],
+ string => [ $ws, $pod_or_DATA, $id, $exql ],
+ code => [
+ $ws, { DONT_MATCH => $pod_or_DATA },
+ $variable, $id, { DONT_MATCH => \&extract_quotelike }
+ ],
+ code_no_comments => [
+ { DONT_MATCH => $comment },
+ $ncws, { DONT_MATCH => $pod_or_DATA },
+ $variable, $id, { DONT_MATCH => \&extract_quotelike }
+ ],
+ executable => [ $ws, { DONT_MATCH => $pod_or_DATA } ],
+ executable_no_comments =>
+ [ { DONT_MATCH => $comment }, $ncws, { DONT_MATCH => $pod_or_DATA } ],
+ all => [ { MATCH => qr/(?s:.*)/ } ],
+);
+exit 1;
+----------
+
+ 'kgb2' => <<'----------',
+# with -kgb, do no break after last my
+sub next_sibling {
+ my $self = shift;
+ my $parent = $_PARENT{refaddr $self} or return '';
+ my $key = refaddr $self;
+ my $elements = $parent->{children};
+ my $position = List::MoreUtils::firstidx {
+ refaddr $_ == $key
+ } @$elements;
+ $elements->[$position + 1] || '';
+}
+
+----------
+
+ 'kgb3' => <<'----------',
+#!/usr/bin/perl -w
+use strict; # with -kgb, no break after hash bang
+our ( @Changed, $TAP ); # break after isolated 'our'
+use File::Compare;
+use Symbol;
+use Text::Wrap();
+use Text::Warp();
+use Blast::IPS::MathUtils qw(
+ set_interpolation_points
+ table_row_interpolation
+ two_point_interpolation
+); # with -kgb, break around isolated 'local' below
+use Text::Warp();
+local($delta2print) =
+ (defined $size) ? int($size/50) : $defaultdelta2print;
+print "break before this line\n";
+----------
+
+ 'kgb4' => <<'----------',
+print "hello"; # with -kgb, break after this line
+use strict;
+use warnings;
+use Test::More tests => 1;
+use Pod::Simple::XHTML;
+my $c = <<EOF;
+=head1 Documentation
+The keyword group dies here
+Do not put a blank line in this here-doc
+EOF
+my $d = $c ."=cut\n";
+exit 1;
+_END_
+----------
+
+ 'kgb5' => <<'----------',
+# with -kgb, do not put blank in ternary
+print "Starting\n"; # with -kgb, break after this line
+my $A = "1";
+my $B = "0";
+my $C = "1";
+my $D = "1";
+my $result =
+ $A
+ ? $B
+ ? $C
+ ? "+A +B +C"
+ : "+A +B -C"
+ : "+A -B"
+ : "-A";
+my $F = "0";
+print "with -kgb, put blank above this line; result=$result\n";
+----------
+
+ 'kgb_tight' => <<'----------',
+# a variety of line types for testing -kgb
+use strict;
+use Test;
+use Encode qw(from_to encode decode
+ encode_utf8 decode_utf8
+ find_encoding is_utf8);
+
+use charnames qw(greek);
+our $targetdir = "/usr/local/doc/HTML/Perl";
+
+local (
+ $tocfile, $loffile, $lotfile, $footfile,
+ $citefile, $idxfile, $figure_captions, $table_captions,
+ $footnotes, $citations, %font_size, %index,
+ %done, $t_title, $t_author, $t_date,
+ $t_address, $t_affil, $changed
+);
+my @UNITCHECKs =
+ B::unitcheck_av->isa("B::AV")
+ ? B::unitcheck_av->ARRAY
+ : ();
+
+my @CHECKs = B::check_av->isa("B::AV") ? B::check_av->ARRAY : ();
+my $dna = Bio::LiveSeq::DNA->new( -seq => $dnasequence );
+my $min = 1;
+my $max = length($dnasequence);
+my $T = $G->_strongly_connected;
+
+my %R = $T->vertex_roots;
+my @C; # We're not calling the strongly_connected_components()
+ # Do not separate this hanging side comment from previous
+
+my $G = shift;
+
+my $exon = Bio::LiveSeq::Exon->new(
+ -seq => $dna,
+ -start => $min,
+ -end => $max,
+ -strand => 1
+);
+my @inputs = (
+ 0777, 0700, 0470, 0407, 0433, 0400, 0430, 0403, 0111, 0100,
+ 0110, 0101, 0731, 0713, 0317, 0371, 0173, 0137
+);
+my $impulse =
+ ( 1 - $factor ) * ( 170 - $u ) +
+ ( 350 / $u**0.65 + 500 / $u**5 ) * $factor;
+my $r = q{
+pm_to_blib: $(TO_INST_PM)
+};
+my $regcomp_re =
+ "(?<routine>ckWARN(?:\\d+)?reg\\w*|vWARN\\d+|$regcomp_fail_re)";
+my $position = List::MoreUtils::firstidx {
+ refaddr $_ == $key
+}
+
+my $alignprogram =
+"/usr/local/etc/bioinfo/fasta2/align -s /usr/local/etc/bioinfo/fasta2/idnaa.mat $fastafile1 $fastafile2 2>/dev/null | $grepcut"
+ ; # ALIGN
+my $skel_name =
+ ( exists( $xml_tree->{'name'} ) ) ? $xml_tree->{'name'} : "";
+my $grp = GroupGetValues( $conf->{dbh}, $group_id );
+
+my $adm_profile =
+ ProfileGetUser( $conf->{dbh}, $grp->{id_admin}, $group_id );
+my $harness = TAP::Harness->new(
+ { verbosity => 1, formatter_class => "TAP::Formatter::Console" } );
+require File::Temp;
+
+require Time::HiRes;
+
+my ( $fh, $filename ) = File::Temp::tempfile("Time-HiRes-utime-XXXXXXXXX");
+use File::Basename qw[dirname];
+my $dirname = dirname($filename);
+my $CUT = qr/\n=cut.*$EOP/;
+
+my $pod_or_DATA = qr/
+ ^=(?:head[1-4]|item) .*? $CUT
+ | ^=pod .*? $CUT
+ | ^=for .*? $CUT
+ | ^=begin .*? $CUT
+ | ^__(DATA|END)__\r?\n.*
+ /smx;
+
+require Cwd;
+print "continuing\n";
+exit 1;
+----------
+
+ 'kgbd' => <<'----------',
+package A1::B2;
+
+use strict;
+
+require Exporter;
+use A1::Context;
+
+use A1::Database;
+use A1::Bibliotek;
+use A1::Author;
+use A1::Title;
+
+use vars qw($VERSION @ISA @EXPORT);
+$VERSION = 0.01;
+----------
+
+ 'ternary3' => <<'----------',
+# this previously caused trouble because of the = and =~
+push( @aligns,
+ ( ( $a = shift @a ) =~ /[^n]/ ) ? $a
+ : (@isnum) ? 'n'
+ : 'l' )
+ unless $opt_a;
+----------
+ };
+
+ ####################################
+ # BEGIN SECTION 3: Expected output #
+ ####################################
+ $rtests = {
+
+ 'else1.def' => {
+ source => "else1",
+ params => "def",
+ expect => <<'#1...........',
+# pad after 'if' when followed by 'elsif'
+if ( not defined $dir or not length $dir ) { $rslt = ''; }
+elsif ( $dir =~ /^\$\([^\)]+\)\Z(?!\n)/s ) { $rslt = $dir; }
+else { $rslt = vmspath($dir); }
+#1...........
+ },
+
+ 'else2.def' => {
+ source => "else2",
+ params => "def",
+ expect => <<'#2...........',
+ # no pad after 'if' when followed by 'else'
+ if ( $m = $g[$x][$y] ) { print $$m{v}; $$m{i}->() }
+ else { print " " }
+#2...........
+ },
+
+ 'ternary3.def' => {
+ source => "ternary3",
+ params => "def",
+ expect => <<'#3...........',
+# this previously caused trouble because of the = and =~
+push(
+ @aligns,
+ ( ( $a = shift @a ) =~ /[^n]/ ) ? $a
+ : (@isnum) ? 'n'
+ : 'l'
+) unless $opt_a;
+#3...........
+ },
+
+ 'align17.def' => {
+ source => "align17",
+ params => "def",
+ expect => <<'#4...........',
+# align => even at broken sub block
+my %opt = (
+ 'cc' => sub { $param::cachecom = 1; },
+ 'cd' => sub { $param::cachedisable = 1; },
+ 'p' => sub {
+ $param::pflag = 1;
+ $param::build = 0;
+ }
+);
+#4...........
+ },
+
+ 'align18.def' => {
+ source => "align18",
+ params => "def",
+ expect => <<'#5...........',
+#align '&&'
+for ( $ENV{HTTP_USER_AGENT} ) {
+ $page =
+ /Mac/ && 'm/Macintrash.html'
+ || /Win(dows)?NT/ && 'e/evilandrude.html'
+ || /Win|MSIE|WebTV/ && 'm/MicroslothWindows.html'
+ || /Linux/ && 'l/Linux.html'
+ || /HP-UX/ && 'h/HP-SUX.html'
+ || /SunOS/ && 's/ScumOS.html'
+ || 'a/AppendixB.html';
+}
+#5...........
+ },
+
+ 'kgb1.def' => {
+ source => "kgb1",
+ params => "def",
+ expect => <<'#6...........',
+# a variety of line types for testing -kgb
+use strict;
+use Test;
+use Encode qw(from_to encode decode
+ encode_utf8 decode_utf8
+ find_encoding is_utf8);
+use charnames qw(greek);
+our $targetdir = "/usr/local/doc/HTML/Perl";
+local (
+ $tocfile, $loffile, $lotfile, $footfile,
+ $citefile, $idxfile, $figure_captions, $table_captions,
+ $footnotes, $citations, %font_size, %index,
+ %done, $t_title, $t_author, $t_date,
+ $t_address, $t_affil, $changed
+);
+my @UNITCHECKs =
+ B::unitcheck_av->isa("B::AV")
+ ? B::unitcheck_av->ARRAY
+ : ();
+my @CHECKs = B::check_av->isa("B::AV") ? B::check_av->ARRAY : ();
+my $dna = Bio::LiveSeq::DNA->new( -seq => $dnasequence );
+my $min = 1;
+my $max = length($dnasequence);
+my $T = $G->_strongly_connected;
+my %R = $T->vertex_roots;
+my @C; # We're not calling the strongly_connected_components()
+ # Do not separate this hanging side comment from previous
+my $G = shift;
+my $exon = Bio::LiveSeq::Exon->new(
+ -seq => $dna,
+ -start => $min,
+ -end => $max,
+ -strand => 1
+);
+my $octal_mode;
+my @inputs = (
+ 0777, 0700, 0470, 0407, 0433, 0400, 0430, 0403, 0111, 0100,
+ 0110, 0101, 0731, 0713, 0317, 0371, 0173, 0137
+);
+my $impulse =
+ ( 1 - $factor ) * ( 170 - $u ) + ( 350 / $u**0.65 + 500 / $u**5 ) * $factor;
+my $r = q{
+pm_to_blib: $(TO_INST_PM)
+};
+my $regcomp_re =
+ "(?<routine>ckWARN(?:\\d+)?reg\\w*|vWARN\\d+|$regcomp_fail_re)";
+my $position = List::MoreUtils::firstidx {
+ refaddr $_ == $key
+}
+my @exons = ($exon);
+my $fastafile2 = "/tmp/tmpfastafile2";
+my $grepcut = 'egrep -v "[[:digit:]]|^ *$|sequences" | cut -c8-'; # grep/cut
+my $alignprogram =
+"/usr/local/etc/bioinfo/fasta2/align -s /usr/local/etc/bioinfo/fasta2/idnaa.mat $fastafile1 $fastafile2 2>/dev/null | $grepcut"
+ ; # ALIGN
+my $xml = new Mioga::XML::Simple( forcearray => 1 );
+my $xml_tree = $xml->XMLin($skel_file);
+my $skel_name =
+ ( exists( $xml_tree->{'name'} ) ) ? $xml_tree->{'name'} : "";
+my $grp = GroupGetValues( $conf->{dbh}, $group_id );
+my $adm_profile =
+ ProfileGetUser( $conf->{dbh}, $grp->{id_admin}, $group_id );
+my $harness = TAP::Harness->new(
+ { verbosity => 1, formatter_class => "TAP::Formatter::Console" } );
+require File::Temp;
+require Time::HiRes;
+my ( $fh, $filename ) = File::Temp::tempfile("Time-HiRes-utime-XXXXXXXXX");
+use File::Basename qw[dirname];
+my $dirname = dirname($filename);
+my $CUT = qr/\n=cut.*$EOP/;
+my $pod_or_DATA = qr/
+ ^=(?:head[1-4]|item) .*? $CUT
+ | ^=pod .*? $CUT
+ | ^=for .*? $CUT
+ | ^=begin .*? $CUT
+ | ^__(DATA|END)__\r?\n.*
+ /smx;
+require Cwd;
+( my $boot = $self->{NAME} ) =~ s/:/_/g;
+doit(
+ sub { @E::ISA = qw/F/ },
+ sub { @E::ISA = qw/D/; @C::ISA = qw/F/ },
+ sub { @C::ISA = qw//; @A::ISA = qw/K/ },
+ sub { @A::ISA = qw//; @J::ISA = qw/F K/ },
+ sub { @J::ISA = qw/F/; @H::ISA = qw/K G/ },
+ sub { @H::ISA = qw/G/; @B::ISA = qw/B/ },
+ sub { @B::ISA = qw//; @K::ISA = qw/K J I/ },
+ sub { @K::ISA = qw/J I/; @D::ISA = qw/A H B C/ },
+ return;
+);
+my %extractor_for = (
+ quotelike => [ $ws, $variable, $id, { MATCH => \&extract_quotelike } ],
+ regex => [ $ws, $pod_or_DATA, $id, $exql ],
+ string => [ $ws, $pod_or_DATA, $id, $exql ],
+ code => [
+ $ws, { DONT_MATCH => $pod_or_DATA },
+ $variable, $id, { DONT_MATCH => \&extract_quotelike }
+ ],
+ code_no_comments => [
+ { DONT_MATCH => $comment },
+ $ncws, { DONT_MATCH => $pod_or_DATA },
+ $variable, $id, { DONT_MATCH => \&extract_quotelike }
+ ],
+ executable => [ $ws, { DONT_MATCH => $pod_or_DATA } ],
+ executable_no_comments =>
+ [ { DONT_MATCH => $comment }, $ncws, { DONT_MATCH => $pod_or_DATA } ],
+ all => [ { MATCH => qr/(?s:.*)/ } ],
+);
+exit 1;
+#6...........
+ },
+
+ 'kgb1.kgb' => {
+ source => "kgb1",
+ params => "kgb",
+ expect => <<'#7...........',
+# a variety of line types for testing -kgb
+use strict;
+use Test;
+use Encode qw(from_to encode decode
+ encode_utf8 decode_utf8
+ find_encoding is_utf8);
+use charnames qw(greek);
+our $targetdir = "/usr/local/doc/HTML/Perl";
+local (
+ $tocfile, $loffile, $lotfile, $footfile,
+ $citefile, $idxfile, $figure_captions, $table_captions,
+ $footnotes, $citations, %font_size, %index,
+ %done, $t_title, $t_author, $t_date,
+ $t_address, $t_affil, $changed
+);
+
+my @UNITCHECKs =
+ B::unitcheck_av->isa("B::AV")
+ ? B::unitcheck_av->ARRAY
+ : ();
+my @CHECKs = B::check_av->isa("B::AV") ? B::check_av->ARRAY : ();
+my $dna = Bio::LiveSeq::DNA->new( -seq => $dnasequence );
+my $min = 1;
+my $max = length($dnasequence);
+my $T = $G->_strongly_connected;
+my %R = $T->vertex_roots;
+my @C; # We're not calling the strongly_connected_components()
+ # Do not separate this hanging side comment from previous
+my $G = shift;
+my $exon = Bio::LiveSeq::Exon->new(
+ -seq => $dna,
+ -start => $min,
+ -end => $max,
+ -strand => 1
+);
+my $octal_mode;
+my @inputs = (
+ 0777, 0700, 0470, 0407, 0433, 0400, 0430, 0403, 0111, 0100,
+ 0110, 0101, 0731, 0713, 0317, 0371, 0173, 0137
+);
+my $impulse =
+ ( 1 - $factor ) * ( 170 - $u ) + ( 350 / $u**0.65 + 500 / $u**5 ) * $factor;
+my $r = q{
+pm_to_blib: $(TO_INST_PM)
+};
+my $regcomp_re =
+ "(?<routine>ckWARN(?:\\d+)?reg\\w*|vWARN\\d+|$regcomp_fail_re)";
+my $position = List::MoreUtils::firstidx {
+ refaddr $_ == $key
+}
+my @exons = ($exon);
+my $fastafile2 = "/tmp/tmpfastafile2";
+my $grepcut = 'egrep -v "[[:digit:]]|^ *$|sequences" | cut -c8-'; # grep/cut
+my $alignprogram =
+"/usr/local/etc/bioinfo/fasta2/align -s /usr/local/etc/bioinfo/fasta2/idnaa.mat $fastafile1 $fastafile2 2>/dev/null | $grepcut"
+ ; # ALIGN
+my $xml = new Mioga::XML::Simple( forcearray => 1 );
+my $xml_tree = $xml->XMLin($skel_file);
+my $skel_name =
+ ( exists( $xml_tree->{'name'} ) ) ? $xml_tree->{'name'} : "";
+my $grp = GroupGetValues( $conf->{dbh}, $group_id );
+my $adm_profile =
+ ProfileGetUser( $conf->{dbh}, $grp->{id_admin}, $group_id );
+my $harness = TAP::Harness->new(
+ { verbosity => 1, formatter_class => "TAP::Formatter::Console" } );
+
+require File::Temp;
+require Time::HiRes;
+my ( $fh, $filename ) = File::Temp::tempfile("Time-HiRes-utime-XXXXXXXXX");
+use File::Basename qw[dirname];
+my $dirname = dirname($filename);
+my $CUT = qr/\n=cut.*$EOP/;
+my $pod_or_DATA = qr/
+ ^=(?:head[1-4]|item) .*? $CUT
+ | ^=pod .*? $CUT
+ | ^=for .*? $CUT
+ | ^=begin .*? $CUT
+ | ^__(DATA|END)__\r?\n.*
+ /smx;
+require Cwd;
+
+( my $boot = $self->{NAME} ) =~ s/:/_/g;
+doit(
+ sub { @E::ISA = qw/F/ },
+ sub { @E::ISA = qw/D/; @C::ISA = qw/F/ },
+ sub { @C::ISA = qw//; @A::ISA = qw/K/ },
+ sub { @A::ISA = qw//; @J::ISA = qw/F K/ },
+ sub { @J::ISA = qw/F/; @H::ISA = qw/K G/ },
+ sub { @H::ISA = qw/G/; @B::ISA = qw/B/ },
+ sub { @B::ISA = qw//; @K::ISA = qw/K J I/ },
+ sub { @K::ISA = qw/J I/; @D::ISA = qw/A H B C/ },
+ return;
+);
+my %extractor_for = (
+ quotelike => [ $ws, $variable, $id, { MATCH => \&extract_quotelike } ],
+ regex => [ $ws, $pod_or_DATA, $id, $exql ],
+ string => [ $ws, $pod_or_DATA, $id, $exql ],
+ code => [
+ $ws, { DONT_MATCH => $pod_or_DATA },
+ $variable, $id, { DONT_MATCH => \&extract_quotelike }
+ ],
+ code_no_comments => [
+ { DONT_MATCH => $comment },
+ $ncws, { DONT_MATCH => $pod_or_DATA },
+ $variable, $id, { DONT_MATCH => \&extract_quotelike }
+ ],
+ executable => [ $ws, { DONT_MATCH => $pod_or_DATA } ],
+ executable_no_comments =>
+ [ { DONT_MATCH => $comment }, $ncws, { DONT_MATCH => $pod_or_DATA } ],
+ all => [ { MATCH => qr/(?s:.*)/ } ],
+);
+exit 1;
+#7...........
+ },
+
+ 'kgb2.def' => {
+ source => "kgb2",
+ params => "def",
+ expect => <<'#8...........',
+# with -kgb, do no break after last my
+sub next_sibling {
+ my $self = shift;
+ my $parent = $_PARENT{ refaddr $self} or return '';
+ my $key = refaddr $self;
+ my $elements = $parent->{children};
+ my $position = List::MoreUtils::firstidx {
+ refaddr $_ == $key
+ }
+ @$elements;
+ $elements->[ $position + 1 ] || '';
+}
+
+#8...........
+ },
+
+ 'kgb2.kgb' => {
+ source => "kgb2",
+ params => "kgb",
+ expect => <<'#9...........',
+# with -kgb, do no break after last my
+sub next_sibling {
+
+ my $self = shift;
+ my $parent = $_PARENT{ refaddr $self} or return '';
+ my $key = refaddr $self;
+ my $elements = $parent->{children};
+ my $position = List::MoreUtils::firstidx {
+ refaddr $_ == $key
+ }
+ @$elements;
+ $elements->[ $position + 1 ] || '';
+}
+
+#9...........
+ },
+
+ 'kgb3.def' => {
+ source => "kgb3",
+ params => "def",
+ expect => <<'#10...........',
+#!/usr/bin/perl -w
+use strict; # with -kgb, no break after hash bang
+our ( @Changed, $TAP ); # break after isolated 'our'
+use File::Compare;
+use Symbol;
+use Text::Wrap();
+use Text::Warp();
+use Blast::IPS::MathUtils qw(
+ set_interpolation_points
+ table_row_interpolation
+ two_point_interpolation
+ ); # with -kgb, break around isolated 'local' below
+use Text::Warp();
+local ($delta2print) =
+ ( defined $size ) ? int( $size / 50 ) : $defaultdelta2print;
+print "break before this line\n";
+#10...........
+ },
+
+ 'kgb3.kgb' => {
+ source => "kgb3",
+ params => "kgb",
+ expect => <<'#11...........',
+#!/usr/bin/perl -w
+use strict; # with -kgb, no break after hash bang
+our ( @Changed, $TAP ); # break after isolated 'our'
+
+use File::Compare;
+use Symbol;
+use Text::Wrap();
+use Text::Warp();
+use Blast::IPS::MathUtils qw(
+ set_interpolation_points
+ table_row_interpolation
+ two_point_interpolation
+ ); # with -kgb, break around isolated 'local' below
+use Text::Warp();
+
+local ($delta2print) =
+ ( defined $size ) ? int( $size / 50 ) : $defaultdelta2print;
+
+print "break before this line\n";
+#11...........
+ },
+
+ 'kgb4.def' => {
+ source => "kgb4",
+ params => "def",
+ expect => <<'#12...........',
+print "hello"; # with -kgb, break after this line
+use strict;
+use warnings;
+use Test::More tests => 1;
+use Pod::Simple::XHTML;
+my $c = <<EOF;
+=head1 Documentation
+The keyword group dies here
+Do not put a blank line in this here-doc
+EOF
+my $d = $c . "=cut\n";
+exit 1;
+_END_
+#12...........
+ },
+
+ 'kgb4.kgb' => {
+ source => "kgb4",
+ params => "kgb",
+ expect => <<'#13...........',
+print "hello"; # with -kgb, break after this line
+
+use strict;
+use warnings;
+use Test::More tests => 1;
+use Pod::Simple::XHTML;
+my $c = <<EOF;
+=head1 Documentation
+The keyword group dies here
+Do not put a blank line in this here-doc
+EOF
+my $d = $c . "=cut\n";
+exit 1;
+_END_
+#13...........
+ },
+
+ 'kgb5.def' => {
+ source => "kgb5",
+ params => "def",
+ expect => <<'#14...........',
+# with -kgb, do not put blank in ternary
+print "Starting\n"; # with -kgb, break after this line
+my $A = "1";
+my $B = "0";
+my $C = "1";
+my $D = "1";
+my $result =
+ $A
+ ? $B
+ ? $C
+ ? "+A +B +C"
+ : "+A +B -C"
+ : "+A -B"
+ : "-A";
+my $F = "0";
+print "with -kgb, put blank above this line; result=$result\n";
+#14...........
+ },
+
+ 'kgb5.kgb' => {
+ source => "kgb5",
+ params => "kgb",
+ expect => <<'#15...........',
+# with -kgb, do not put blank in ternary
+print "Starting\n"; # with -kgb, break after this line
+
+my $A = "1";
+my $B = "0";
+my $C = "1";
+my $D = "1";
+my $result =
+ $A
+ ? $B
+ ? $C
+ ? "+A +B +C"
+ : "+A +B -C"
+ : "+A -B"
+ : "-A";
+my $F = "0";
+print "with -kgb, put blank above this line; result=$result\n";
+#15...........
+ },
+
+ 'kgbd.def' => {
+ source => "kgbd",
+ params => "def",
+ expect => <<'#16...........',
+package A1::B2;
+
+use strict;
+
+require Exporter;
+use A1::Context;
+
+use A1::Database;
+use A1::Bibliotek;
+use A1::Author;
+use A1::Title;
+
+use vars qw($VERSION @ISA @EXPORT);
+$VERSION = 0.01;
+#16...........
+ },
+
+ 'kgbd.kgbd' => {
+ source => "kgbd",
+ params => "kgbd",
+ expect => <<'#17...........',
+package A1::B2;
+
+use strict;
+require Exporter;
+
+use A1::Context;
+use A1::Database;
+use A1::Bibliotek;
+use A1::Author;
+use A1::Title;
+use vars qw($VERSION @ISA @EXPORT);
+
+$VERSION = 0.01;
+#17...........
+ },
+
+ 'kgb_tight.def' => {
+ source => "kgb_tight",
+ params => "def",
+ expect => <<'#18...........',
+# a variety of line types for testing -kgb
+use strict;
+use Test;
+use Encode qw(from_to encode decode
+ encode_utf8 decode_utf8
+ find_encoding is_utf8);
+
+use charnames qw(greek);
+our $targetdir = "/usr/local/doc/HTML/Perl";
+
+local (
+ $tocfile, $loffile, $lotfile, $footfile,
+ $citefile, $idxfile, $figure_captions, $table_captions,
+ $footnotes, $citations, %font_size, %index,
+ %done, $t_title, $t_author, $t_date,
+ $t_address, $t_affil, $changed
+);
+my @UNITCHECKs =
+ B::unitcheck_av->isa("B::AV")
+ ? B::unitcheck_av->ARRAY
+ : ();
+
+my @CHECKs = B::check_av->isa("B::AV") ? B::check_av->ARRAY : ();
+my $dna = Bio::LiveSeq::DNA->new( -seq => $dnasequence );
+my $min = 1;
+my $max = length($dnasequence);
+my $T = $G->_strongly_connected;
+
+my %R = $T->vertex_roots;
+my @C; # We're not calling the strongly_connected_components()
+ # Do not separate this hanging side comment from previous
+
+my $G = shift;
+
+my $exon = Bio::LiveSeq::Exon->new(
+ -seq => $dna,
+ -start => $min,
+ -end => $max,
+ -strand => 1
+);
+my @inputs = (
+ 0777, 0700, 0470, 0407, 0433, 0400, 0430, 0403, 0111, 0100,
+ 0110, 0101, 0731, 0713, 0317, 0371, 0173, 0137
+);
+my $impulse =
+ ( 1 - $factor ) * ( 170 - $u ) + ( 350 / $u**0.65 + 500 / $u**5 ) * $factor;
+my $r = q{
+pm_to_blib: $(TO_INST_PM)
+};
+my $regcomp_re =
+ "(?<routine>ckWARN(?:\\d+)?reg\\w*|vWARN\\d+|$regcomp_fail_re)";
+my $position = List::MoreUtils::firstidx {
+ refaddr $_ == $key
+}
+
+my $alignprogram =
+"/usr/local/etc/bioinfo/fasta2/align -s /usr/local/etc/bioinfo/fasta2/idnaa.mat $fastafile1 $fastafile2 2>/dev/null | $grepcut"
+ ; # ALIGN
+my $skel_name =
+ ( exists( $xml_tree->{'name'} ) ) ? $xml_tree->{'name'} : "";
+my $grp = GroupGetValues( $conf->{dbh}, $group_id );
+
+my $adm_profile =
+ ProfileGetUser( $conf->{dbh}, $grp->{id_admin}, $group_id );
+my $harness = TAP::Harness->new(
+ { verbosity => 1, formatter_class => "TAP::Formatter::Console" } );
+require File::Temp;
+
+require Time::HiRes;
+
+my ( $fh, $filename ) = File::Temp::tempfile("Time-HiRes-utime-XXXXXXXXX");
+use File::Basename qw[dirname];
+my $dirname = dirname($filename);
+my $CUT = qr/\n=cut.*$EOP/;
+
+my $pod_or_DATA = qr/
+ ^=(?:head[1-4]|item) .*? $CUT
+ | ^=pod .*? $CUT
+ | ^=for .*? $CUT
+ | ^=begin .*? $CUT
+ | ^__(DATA|END)__\r?\n.*
+ /smx;
+
+require Cwd;
+print "continuing\n";
+exit 1;
+#18...........
+ },
+
+ 'gnu5.def' => {
+ source => "gnu5",
+ params => "def",
+ expect => <<'#19...........',
+ # side comments limit gnu type formatting with l=80; note extra comma
+ push @tests, [
+ "Lowest code point requiring 13 bytes to represent", # 2**36
+ "\xff\x80\x80\x80\x80\x80\x81\x80\x80\x80\x80\x80\x80",
+ ($::is64bit) ? 0x1000000000 : -1, # overflows on 32bit
+ ],
+ ;
+#19...........
+ },
+ };
+
+ my $ntests = 0 + keys %{$rtests};
+ plan tests => $ntests;
+}
+
+###############
+# EXECUTE TESTS
+###############
+
+foreach my $key ( sort keys %{$rtests} ) {
+ my $output;
+ my $sname = $rtests->{$key}->{source};
+ my $expect = $rtests->{$key}->{expect};
+ my $pname = $rtests->{$key}->{params};
+ my $source = $rsources->{$sname};
+ my $params = defined($pname) ? $rparams->{$pname} : "";
+ my $stderr_string;
+ my $errorfile_string;
+ my $err = Perl::Tidy::perltidy(
+ source => \$source,
+ destination => \$output,
+ perltidyrc => \$params,
+ argv => '', # for safety; hide any ARGV from perltidy
+ stderr => \$stderr_string,
+ errorfile => \$errorfile_string, # not used when -se flag is set
+ );
+ if ( $err || $stderr_string || $errorfile_string ) {
+ if ($err) {
+ print STDERR
+"This error received calling Perl::Tidy with '$sname' + '$pname'\n";
+ ok( !$err );
+ }
+ if ($stderr_string) {
+ print STDERR "---------------------\n";
+ print STDERR "<<STDERR>>\n$stderr_string\n";
+ print STDERR "---------------------\n";
+ print STDERR
+"This error received calling Perl::Tidy with '$sname' + '$pname'\n";
+ ok( !$stderr_string );
+ }
+ if ($errorfile_string) {
+ print STDERR "---------------------\n";
+ print STDERR "<<.ERR file>>\n$errorfile_string\n";
+ print STDERR "---------------------\n";
+ print STDERR
+"This error received calling Perl::Tidy with '$sname' + '$pname'\n";
+ ok( !$errorfile_string );
+ }
+ }
+ else {
+ ok( $output, $expect );
+ }
+}
--- /dev/null
+# Created with: ./make_t.pl
+
+# Contents:
+#1 gnu5.gnu
+#2 wngnu1.def
+#3 olbs.def
+#4 olbs.olbs0
+#5 olbs.olbs2
+#6 break_old_methods.break_old_methods
+#7 break_old_methods.def
+#8 bom1.bom
+#9 bom1.def
+
+# To locate test #13 you can search for its name or the string '#13'
+
+use strict;
+use Test;
+use Carp;
+use Perl::Tidy;
+my $rparams;
+my $rsources;
+my $rtests;
+
+BEGIN {
+
+ ###########################################
+ # BEGIN SECTION 1: Parameter combinations #
+ ###########################################
+ $rparams = {
+ 'bom' => "-bom -wn",
+ 'break_old_methods' => "--break-at-old-method-breakpoints",
+ 'def' => "",
+ 'gnu' => "-gnu",
+ 'olbs0' => "-olbs=0",
+ 'olbs2' => "-olbs=2",
+ };
+
+ ############################
+ # BEGIN SECTION 2: Sources #
+ ############################
+ $rsources = {
+
+ 'bom1' => <<'----------',
+# keep cuddled call chain with -bom
+return Mojo::Promise->resolve(
+ $query_params
+)->then(
+ &_reveal_event
+)->then(sub ($code) {
+ return $c->render(text => '', status => $code);
+})->catch(sub {
+ # 1. return error
+ return $c->render(json => {}, status => 400);
+});
+----------
+
+ 'break_old_methods' => <<'----------',
+my $q = $rs
+ ->related_resultset('CDs')
+ ->related_resultset('Tracks')
+ ->search({
+ 'track.id' => { -ident => 'none_search.id' },
+ })
+ ->as_query;
+----------
+
+ 'gnu5' => <<'----------',
+ # side comments limit gnu type formatting with l=80; note extra comma
+ push @tests, [
+ "Lowest code point requiring 13 bytes to represent", # 2**36
+ "\xff\x80\x80\x80\x80\x80\x81\x80\x80\x80\x80\x80\x80",
+ ($::is64bit) ? 0x1000000000 : -1, # overflows on 32bit
+ ],
+ ;
+----------
+
+ 'olbs' => <<'----------',
+for $x ( 1, 2 ) { s/(.*)/+$1/ }
+for $x ( 1, 2 ) { s/(.*)/+$1/ } # side comment
+if ( $editlblk eq 1 ) { $editlblk = "on"; $editlblkchecked = "checked" }
+for $x ( 1, 2 ) { s/(.*)/+$1/; }
+for $x ( 1, 2 ) { s/(.*)/+$1/; } # side comment
+if ( $editlblk eq 1 ) { $editlblk = "on"; $editlblkchecked = "checked"; }
+----------
+
+ 'wngnu1' => <<'----------',
+ # test with -wn -gnu
+ foreach my $parameter (
+ qw(
+ set_themes
+ add_themes
+ severity
+ maximum_violations_per_document
+ _non_public_data
+ )
+ )
+ {
+ is(
+ $config->get($parameter),
+ undef,
+ qq<"$parameter" is not defined via get() for $policy_short_name.>,
+ );
+ }
+----------
+ };
+
+ ####################################
+ # BEGIN SECTION 3: Expected output #
+ ####################################
+ $rtests = {
+
+ 'gnu5.gnu' => {
+ source => "gnu5",
+ params => "gnu",
+ expect => <<'#1...........',
+ # side comments limit gnu type formatting with l=80; note extra comma
+ push @tests, [
+ "Lowest code point requiring 13 bytes to represent", # 2**36
+ "\xff\x80\x80\x80\x80\x80\x81\x80\x80\x80\x80\x80\x80",
+ ($::is64bit) ? 0x1000000000 : -1, # overflows on 32bit
+ ],
+ ;
+#1...........
+ },
+
+ 'wngnu1.def' => {
+ source => "wngnu1",
+ params => "def",
+ expect => <<'#2...........',
+ # test with -wn -gnu
+ foreach my $parameter (
+ qw(
+ set_themes
+ add_themes
+ severity
+ maximum_violations_per_document
+ _non_public_data
+ )
+ )
+ {
+ is(
+ $config->get($parameter),
+ undef,
+ qq<"$parameter" is not defined via get() for $policy_short_name.>,
+ );
+ }
+#2...........
+ },
+
+ 'olbs.def' => {
+ source => "olbs",
+ params => "def",
+ expect => <<'#3...........',
+for $x ( 1, 2 ) { s/(.*)/+$1/ }
+for $x ( 1, 2 ) { s/(.*)/+$1/ } # side comment
+if ( $editlblk eq 1 ) { $editlblk = "on"; $editlblkchecked = "checked" }
+for $x ( 1, 2 ) { s/(.*)/+$1/; }
+for $x ( 1, 2 ) { s/(.*)/+$1/; } # side comment
+if ( $editlblk eq 1 ) { $editlblk = "on"; $editlblkchecked = "checked"; }
+#3...........
+ },
+
+ 'olbs.olbs0' => {
+ source => "olbs",
+ params => "olbs0",
+ expect => <<'#4...........',
+for $x ( 1, 2 ) { s/(.*)/+$1/ }
+for $x ( 1, 2 ) { s/(.*)/+$1/ } # side comment
+if ( $editlblk eq 1 ) { $editlblk = "on"; $editlblkchecked = "checked" }
+for $x ( 1, 2 ) { s/(.*)/+$1/ }
+for $x ( 1, 2 ) { s/(.*)/+$1/ } # side comment
+if ( $editlblk eq 1 ) { $editlblk = "on"; $editlblkchecked = "checked"; }
+#4...........
+ },
+
+ 'olbs.olbs2' => {
+ source => "olbs",
+ params => "olbs2",
+ expect => <<'#5...........',
+for $x ( 1, 2 ) { s/(.*)/+$1/; }
+for $x ( 1, 2 ) { s/(.*)/+$1/; } # side comment
+if ( $editlblk eq 1 ) { $editlblk = "on"; $editlblkchecked = "checked"; }
+for $x ( 1, 2 ) { s/(.*)/+$1/; }
+for $x ( 1, 2 ) { s/(.*)/+$1/; } # side comment
+if ( $editlblk eq 1 ) { $editlblk = "on"; $editlblkchecked = "checked"; }
+#5...........
+ },
+
+ 'break_old_methods.break_old_methods' => {
+ source => "break_old_methods",
+ params => "break_old_methods",
+ expect => <<'#6...........',
+my $q = $rs
+ ->related_resultset('CDs')
+ ->related_resultset('Tracks')
+ ->search(
+ {
+ 'track.id' => { -ident => 'none_search.id' },
+ }
+)->as_query;
+#6...........
+ },
+
+ 'break_old_methods.def' => {
+ source => "break_old_methods",
+ params => "def",
+ expect => <<'#7...........',
+my $q = $rs->related_resultset('CDs')->related_resultset('Tracks')->search(
+ {
+ 'track.id' => { -ident => 'none_search.id' },
+ }
+)->as_query;
+#7...........
+ },
+
+ 'bom1.bom' => {
+ source => "bom1",
+ params => "bom",
+ expect => <<'#8...........',
+# keep cuddled call chain with -bom
+return Mojo::Promise->resolve(
+ $query_params
+)->then(
+ &_reveal_event
+)->then( sub ($code) {
+ return $c->render( text => '', status => $code );
+} )->catch( sub {
+
+ # 1. return error
+ return $c->render( json => {}, status => 400 );
+} );
+#8...........
+ },
+
+ 'bom1.def' => {
+ source => "bom1",
+ params => "def",
+ expect => <<'#9...........',
+# keep cuddled call chain with -bom
+return Mojo::Promise->resolve($query_params)->then(&_reveal_event)->then(
+ sub ($code) {
+ return $c->render( text => '', status => $code );
+ }
+)->catch(
+ sub {
+ # 1. return error
+ return $c->render( json => {}, status => 400 );
+ }
+);
+#9...........
+ },
+ };
+
+ my $ntests = 0 + keys %{$rtests};
+ plan tests => $ntests;
+}
+
+###############
+# EXECUTE TESTS
+###############
+
+foreach my $key ( sort keys %{$rtests} ) {
+ my $output;
+ my $sname = $rtests->{$key}->{source};
+ my $expect = $rtests->{$key}->{expect};
+ my $pname = $rtests->{$key}->{params};
+ my $source = $rsources->{$sname};
+ my $params = defined($pname) ? $rparams->{$pname} : "";
+ my $stderr_string;
+ my $errorfile_string;
+ my $err = Perl::Tidy::perltidy(
+ source => \$source,
+ destination => \$output,
+ perltidyrc => \$params,
+ argv => '', # for safety; hide any ARGV from perltidy
+ stderr => \$stderr_string,
+ errorfile => \$errorfile_string, # not used when -se flag is set
+ );
+ if ( $err || $stderr_string || $errorfile_string ) {
+ if ($err) {
+ print STDERR
+"This error received calling Perl::Tidy with '$sname' + '$pname'\n";
+ ok( !$err );
+ }
+ if ($stderr_string) {
+ print STDERR "---------------------\n";
+ print STDERR "<<STDERR>>\n$stderr_string\n";
+ print STDERR "---------------------\n";
+ print STDERR
+"This error received calling Perl::Tidy with '$sname' + '$pname'\n";
+ ok( !$stderr_string );
+ }
+ if ($errorfile_string) {
+ print STDERR "---------------------\n";
+ print STDERR "<<.ERR file>>\n$errorfile_string\n";
+ print STDERR "---------------------\n";
+ print STDERR
+"This error received calling Perl::Tidy with '$sname' + '$pname'\n";
+ ok( !$errorfile_string );
+ }
+ }
+ else {
+ ok( $output, $expect );
+ }
+}
expect => <<'#18...........',
# -iscl will not allow alignment of hanging side comments (currently)
$gsmatch = ( $sub >= 50 ) ? "equal" : "lequal"; # Force an equal match for
- # dev, but be more forgiving
- # for releases
+ # dev, but be more forgiving
+ # for releases
#18...........
},
--- /dev/null
+use strict;
+use File::Temp;
+use Test;
+use Carp;
+BEGIN {plan tests => 4}
+use Perl::Tidy;
+
+
+#----------------------------------------------------------------------
+## test string->string
+#----------------------------------------------------------------------
+my $source_template = <<'EOM';
+%height=("letter",27.9, "legal",35.6, "arche",121.9, "archd",91.4, "archc",61,
+ "archb",45.7, "archa",30.5, "flsa",33, "flse",33, "halfletter",21.6,
+ "11x17",43.2, "ledger",27.9);
+%width=("letter",21.6, "legal",21.6, "arche",91.4, "archd",61, "archc",45.7,
+ "archb",30.5, "archa",22.9, "flsa",21.6, "flse",21.6, "halfletter",14,
+ "11x17",27.9, "ledger",43.2);
+EOM
+
+my $perltidyrc;
+
+my $expected_output_template=<<'EOM';
+%height = (
+ "letter", 27.9, "legal", 35.6, "arche", 121.9,
+ "archd", 91.4, "archc", 61, "archb", 45.7,
+ "archa", 30.5, "flsa", 33, "flse", 33,
+ "halfletter", 21.6, "11x17", 43.2, "ledger", 27.9
+ );
+%width = (
+ "letter", 21.6, "legal", 21.6, "arche", 91.4,
+ "archd", 61, "archc", 45.7, "archb", 30.5,
+ "archa", 22.9, "flsa", 21.6, "flse", 21.6,
+ "halfletter", 14, "11x17", 27.9, "ledger", 43.2
+ );
+EOM
+
+my $source;
+my $output;
+my $expected_output;
+
+my $CR = chr(015);
+my $LF = chr(012);
+
+$perltidyrc = <<'EOM';
+-gnu
+--output-line-ending="unix" # use *nix LF EOLs
+EOM
+
+$source = $source_template;
+$source =~ s/\n/$CR$LF/gmsx;
+$expected_output = $expected_output_template;
+$expected_output =~ s/\n/$LF/gmsx;
+
+# my ($source_fh, $source_filename) = File::Temp::tempfile(); close $source_filename;
+my ($output_fh, $output_filename) = File::Temp::tempfile(); close $output_filename;
+
+# print STDERR "# source_filename = ", $source_filename, "\n";
+# print STDERR "# output_filename = ", $output_filename, "\n";
+
+# open $source_fh, ">", $source_filename;
+# binmode $source_fh, ":raw";
+# print $source_fh $source;
+# close $source_fh;
+
+# in-memory output (non-UTF8)
+
+Perl::Tidy::perltidy(
+ source => \$source,
+ destination => \$output,
+ perltidyrc => \$perltidyrc,
+ argv => '',
+);
+
+ok($output, $expected_output, "in-memory EOLs (non-UTF8)");
+
+# file output (non-UTF8)
+Perl::Tidy::perltidy(
+ source => \$source,
+ destination => $output_filename,
+ perltidyrc => \$perltidyrc,
+ argv => '',
+);
+
+{# slurp entire file
+ local $/ = undef;
+ open $output_fh, "<", $output_filename;
+ binmode $output_fh, ":raw";
+ $output = <$output_fh>;
+}
+
+ok($output, $expected_output, "output file EOLs (non-UTF8)");
+
+$perltidyrc = <<'EOM';
+-gnu
+--character-encoding="utf8" # treat files as UTF-8 (decode and encode)
+--output-line-ending="unix" # use *nix LF EOLs
+EOM
+
+# in-memory (UTF8)
+$source = $source_template;
+$source =~ s/\n/$CR$LF/gmsx;
+$expected_output = $expected_output_template;
+$expected_output =~ s/\n/$LF/gmsx;
+
+Perl::Tidy::perltidy(
+ source => \$source,
+ destination => \$output,
+ perltidyrc => \$perltidyrc,
+ argv => '',
+);
+
+ok($output, $expected_output, "in-memory EOLs (UTF8)");
+
+# file output (UTF8)
+
+Perl::Tidy::perltidy(
+ source => \$source,
+ destination => $output_filename,
+ perltidyrc => \$perltidyrc,
+ argv => '',
+);
+
+{# slurp entire file
+ local $/ = undef;
+ open $output_fh, "<", $output_filename;
+ binmode $output_fh, ":raw";
+ $output = <$output_fh>;
+}
+
+ok($output, $expected_output, "output file EOLs (UTF8)");
projects / perltidy.git / commitdiff