Perltidy Change Log
+ 2012 07 01
+ - Corrected problem introduced by using a chomp on scalar references, RT #77978
+
+ - Added support for Perl 5.14 package block syntax, RT #78114.
+
+ - A convergence test is made if three or more iterations are requested with
+ the -it=n parameter to avoid wasting computer time. Several hundred Mb of
+ code gleaned from the internet were searched with the results that:
+ - It is unusual for two iterations to be required unless a major
+ style change is being made.
+ - Only one case has been found where three iterations were required.
+ - No cases requiring four iterations have been found with this version.
+ For the previous version several cases where found the results could
+ oscillate between two semi-stable states. This version corrects this.
+
+ So if it is important that the code be converged it is okay to set -it=4
+ with this version and it will probably stop after the second iteration.
+
+ - Improved ability to identify and retain good line break points in the
+ input stream, such as at commas and equals. You can always tell
+ perltidy to ignore old breakpoints with -iob.
+
+ - Fixed glitch in which a terminal closing hash brace followed by semicolon
+ was not outdented back to the leading line depth like other closing
+ tokens. Thanks to Keith Neargarder for noting this.
+
+ OLD:
+ my ( $pre, $post ) = @{
+ {
+ "pp_anonlist" => [ "[", "]" ],
+ "pp_anonhash" => [ "{", "}" ]
+ }->{ $kid->ppaddr }
+ }; # terminal brace
+
+ NEW:
+ my ( $pre, $post ) = @{
+ {
+ "pp_anonlist" => [ "[", "]" ],
+ "pp_anonhash" => [ "{", "}" ]
+ }->{ $kid->ppaddr }
+ }; # terminal brace
+
+ - Removed extra indentation given to trailing 'if' and 'unless' clauses
+ without parentheses because this occasionally produced undesirable
+ results. This only applies where parens are not used after the if or
+ unless.
+
+ OLD:
+ return undef
+ unless my ( $who, $actions ) =
+ $clause =~ /^($who_re)((?:$action_re)+)$/o;
+
+ NEW:
+ return undef
+ unless my ( $who, $actions ) =
+ $clause =~ /^($who_re)((?:$action_re)+)$/o;
+
+ 2012 06 19
+ - Updated perltidy to handle all quote modifiers defined for perl 5 version 16.
+
+ - Side comment text in perltidyrc configuration files must now begin with
+ at least one space before the #. Thus:
+
+ OK:
+ -l=78 # Max line width is 78 cols
+ BAD:
+ -l=78# Max line width is 78 cols
+
+ This is probably true of almost all existing perltidyrc files,
+ but if you get an error message about bad parameters
+ involving a '#' the first time you run this version, please check the side
+ comments in your perltidyrc file, and add a space before the # if necessary.
+ You can quickly see the contents your perltidyrc file, if any, with the
+ command:
+
+ perltidy -dpro
+
+ The reason for this change is that some parameters naturally involve
+ the # symbol, and this can get interpreted as a side comment unless the
+ parameter is quoted. For example, to define -sphb=# it used to be necessary
+ to write
+ -sbcp='#'
+ to keep the # from becomming part of a comment. This was causing
+ trouble for new users. Now it can also be written without quotes:
+ -sbcp=#
+
+ - Fixed bug in processing some .perltidyrc files containing parameters with
+ an opening brace character, '{'. For example the following was
+ incorrectly processed:
+ --static-block-comment-prefix="^#{2,}[^\s#]"
+ Thanks to pdagosto.
+
+ - Added flag -boa (--break-at-old-attribute-breakpoints) which retains
+ any existing line breaks at attribute separation ':'. This is now the
+ default, use -nboa to deactivate. Thanks to Daphne Phister for the patch.
+ For example, given the following code, the line breaks at the ':'s will be
+ retained:
+
+ my @field
+ : field
+ : Default(1)
+ : Get('Name' => 'foo') : Set('Name');
+
+ whereas the previous version would have output a single line. If
+ the attributes are on a single line then they will remain on a single line.
+
+ - Added new flags --blank-lines-before-subs=n (-blbs=n) and
+ --blank-lines-before-packages=n (-blbp=n) to put n blank lines before
+ subs and packages. The old flag -bbs is now equivalent to -blbs=1 -blbp=1.
+ and -nbbs is equivalent to -blbs=0 -blbp=0. Requested by M. Schwern and
+ several others.
+
+ - Added feature -nsak='*' meaning no space between any keyword and opening
+ paren. This avoids listing entering a long list of keywords. Requested
+ by M. Schwern.
+
+ - Added option to delete a backup of original file with in-place-modify (-b)
+ if there were no errors. This can be requested with the flag -bext='/'.
+ See documentation for details. Requested by M. Schwern and others.
+
+ - Fixed bug where the module postfilter parameter was not applied when -b
+ flag was used. This was discovered during testing.
+
+ - Fixed in-place-modify (-b) to work with symbolic links to source files.
+ Thanks to Ted Johnson.
+
+ - Fixed bug where the Perl::Tidy module did not allow -b to be used
+ in some cases.
+
+ - No extra blank line is added before a comment which follows
+ a short line ending in an opening token, for example like this:
+ OLD:
+ if (
+
+ # unless we follow a blank or comment line
+ $last_line_leading_type !~ /^[#b]$/
+ ...
+
+ NEW:
+ if (
+ # unless we follow a blank or comment line
+ $last_line_leading_type !~ /^[#b]$/
+ ...
+
+ The blank is not needed for readability in these cases because there
+ already is already space above the comment. If a blank already
+ exists there it will not be removed, so this change should not
+ change code which has previously been formatted with perltidy.
+ Thanks to R.W.Stauner.
+
+ - Likewise, no extra blank line is added above a comment consisting of a
+ single #, since nothing is gained in readability.
+
+ - Fixed error in which a blank line was removed after a #>>> directive.
+ Thanks to Ricky Morse.
+
+ - Unnecessary semicolons after given/when/default blocks are now removed.
+
+ - Fixed bug where an unwanted blank line could be added before
+ pod text in __DATA__ or __END__ section. Thanks to jidani.
+
+ - Changed exit flags from 1 to 0 to indicate success for -help, -version,
+ and all -dump commands. Also added -? as another way to dump the help.
+ Requested by Keith Neargarder.
+
+ - Fixed bug where .ERR and .LOG files were not written except for -it=2 or more
+
+ - Fixed bug where trailing blank lines at the end of a file were dropped when
+ -it>1.
+
+ - Fixed bug where a line occasionally ended with an extra space. This reduces
+ rhe number of instances where a second iteration gives a result different
+ from the first.
+
+ - Updated documentation to note that the Tidy.pm module <stderr> parameter may
+ not be a reference to SCALAR or ARRAY; it must be a file.
+
+ - Syntax check with perl now work when the Tidy.pm module is processing
+ references to arrays and strings. Thanks to Charles Alderman.
+
+ - Zero-length files are no longer processed due to concerns for data loss
+ due to side effects in some scenarios.
+
+ - block labels, if any, are now included in closing side comment text
+ when the -csc flag is used. Suggested by Aaron. For example,
+ the label L102 in the following block is now included in the -csc text:
+
+ L102: for my $i ( 1 .. 10 ) {
+ ...
+ } ## end L102: for my $i ( 1 .. 10 )
+
2010 12 17
- added new flag -it=n or --iterations=n
This flag causes perltidy to do n complete iterations.
limit is exceeded, then the comment text must be truncated. Previous
versions of perltidy terminate with three dots, and this can still be
achieved with -ncscb:
-
- perltidy -csc -ncscb
+
+ perltidy -csc -ncscb
} ## end foreach my $foo (sort { $b cmp $a ...
-
- However this causes a problem with older editors which cannot recognize
+
+ However this causes a problem with older editors which cannot recognize
comments or are not configured to doso because they cannot "bounce" around in
the text correctly. The B<-cscb> flag tries to help them by
appending appropriate terminal balancing structure:
-
- perltidy -csc -cscb
+
+ perltidy -csc -cscb
} ## end foreach my $foo (sort { $b cmp $a ... })
-
- Since there is much to be gained and little to be lost by doing this,
+
+ Since there is much to be gained and little to be lost by doing this,
the default is B<-cscb>. Use B<-ncscb> if you do not want this.
Thanks to Daniel Becker for suggesting this option.
dbmclose(%verb_delim); undef %verb_delim;
dbmclose(%expanded); undef %expanded;
dbmclose(%global); undef %global;
-
- -Improved formatting of complex ternary statements, with indentation
+
+ -Improved formatting of complex ternary statements, with indentation
of nested statements.
OLD:
return defined( $cw->{Selected} )
-Fixed problem of a warning issued for multiple subs for BEGIN subs
and other control subs. Thanks to Heiko Eissfeldt.
-
- -Fixed problem where no space was introduced between a keyword or
+
+ -Fixed problem where no space was introduced between a keyword or
bareword and a colon, such as:
( ref($result) eq 'HASH' && !%$result ) ? undef: $result;
);
This is backwards compatible with -icp. See revised manual for
details. Suggested by Mike Pennington.
-
- -Added flag '--preserve-line-endings' or '-ple' to cause the output
+
+ -Added flag '--preserve-line-endings' or '-ple' to cause the output
line ending to be the same as in the input file, for unix, dos,
or mac line endings. Only works under unix. Suggested by
Rainer Hochschild.
-Fixed bug where an __END__ statement would be mistaken for a label
if it is immediately followed by a line with a leading colon. Thanks
to John Bayes.
-
- -Implemented guessing logic for brace types when it is ambiguous. This
+
+ -Implemented guessing logic for brace types when it is ambiguous. This
has been on the TODO list a long time. Thanks to Boris Zentner for
an example.
-Outdenting labels (-ola) has been made the default, in order to follow the
perlstyle guidelines better. It's probably a good idea in general, but
if you do not want this, use -nola in your .perltidyrc file.
-
- -Updated rules for padding logical expressions to include more cases.
+
+ -Updated rules for padding logical expressions to include more cases.
Thanks to Wolfgang Weisselberg for helpful discussions.
-Added new flag -osbc (--outdent-static-block-comments) which will
-Pod file 'perltidy.pod' has been appended to the script 'perltidy', and
Tidy.pod has been append to the module 'Tidy.pm'. Older MakeMaker's
were having trouble.
-
- -A new flag -isbc has been added for more control on comments. This flag
+
+ -A new flag -isbc has been added for more control on comments. This flag
has the effect that if there is no leading space on the line, then the
comment will not be indented, and otherwise it may be. If both -ibc and
-isbc are set, then -isbc takes priority. Thanks to Frank Steinhauer
but not otherwise:
: print "Hello World\n";
-
- Also, perltidy will now mark a first line with leading ':' followed by
+
+ Also, perltidy will now mark a first line with leading ':' followed by
'#' as type SYSTEM (just as a #! line), not to be formatted.
-List formatting improved for certain lists with special
and this has solved a lot of robustness problems. These systems
cannot reliably handle backtick operators. See man page for
details.
-
- -Merged VMS filename handling patch sent by Michael Cartmell. (Invalid
+
+ -Merged VMS filename handling patch sent by Michael Cartmell. (Invalid
output filenames were being created in some cases).
-Numerous minor improvements have been made for -lp style indentation.
Note how the closing ');' is lined up with the first line, even
though it closes a paren in the 'pack' line. That seems wrong.
-
- NEW:
+
+ NEW:
$mw->Button(
-text => "New Document",
-command => \&new_document
This seems nicer: you can up-arrow with an editor and arrive at the
opening 'pack' line.
-
- -corrected minor glitch in which cuddled else (-ce) did not get applied
+
+ -corrected minor glitch in which cuddled else (-ce) did not get applied
to an 'unless' block, which should look like this:
unless ($test) {
Thanks to Jeremy Mates for reporting this.
-The man page has been reorganized to parameters easier to find.
-
- -Added check for multiple definitions of same subroutine. It is easy
+
+ -Added check for multiple definitions of same subroutine. It is easy
to introduce this problem when cutting and pasting. Perl does not
complain about it, but it can lead to disaster.
-Side comment alignment has been improved somewhat across frequent level
changes, as in short if/else blocks. Thanks to Wolfgang Weisselberg
for pointing out this problem. For example:
-
- OLD:
+
+ OLD:
if ( ref $self ) { # Called as a method
$format = shift;
}
);
The structure is clearer with the added indentation:
-
- NEW:
+
+ NEW:
%{ $self->{COMPONENTS} } = (
fname =>
{ type => 'name', adj => 'yes', font => 'Helvetica', 'index' => 0 },
-Corrected tokenization error for the following (highly non-recommended)
construct:
$user = @vars[1] / 100;
-
- -Resolved cause of a difference between perltidy under perl v5.6.1 and
+
+ -Resolved cause of a difference between perltidy under perl v5.6.1 and
5.005_03; the problem was different behavior of \G regex position
marker(!)
The formatter mistakenly thought that it had found the following
one-line block:
-
- eval {#open Socket to Dispatcher$sock = &OpenSocket; };
+
+ eval {#open Socket to Dispatcher$sock = &OpenSocket; };
The patch fixes this. Many thanks to Henry Story for reporting this bug.
-Fixed tokenization error in which a method call of the form
Module::->new();
-
- got a space before the '::' like this:
+
+ got a space before the '::' like this:
Module ::->new();
Thanks to David Holden for reporting this.
-
- -Added -html control over pod text, using a new abbreviation 'pd'. See
+
+ -Added -html control over pod text, using a new abbreviation 'pd'. See
updated perl2web man page. The default is to use the color of a comment,
but italicized. Old .css style sheets will need a new line for
.pd to use this. The old color was the color of a string, and there
was no control.
-
- -.css lines are now printed in sorted order.
+
+ -.css lines are now printed in sorted order.
-Fixed interpolation problem where html files had '$input_file' as title
instead of actual input file name. Thanks to Simon Perreault for finding
: $opts{"s"} ? 'subject'
: $opts{"a"} ? 'author'
: 'title';
-
- You can use -wba=':' to recover the previous default which placed ':'
+
+ You can use -wba=':' to recover the previous default which placed ':'
at the end of a line. Thanks to Michael Cartmell for helpful
discussions and examples.
nevertheless broken in the input file at a 'good' location (see below),
perltidy will try to retain a break. For example, the following line
will be formatted as:
-
- open SUM, "<$file"
+
+ open SUM, "<$file"
or die "Cannot open $file ($!)";
-
- if it was broken in the input file, and like this if not:
+
+ if it was broken in the input file, and like this if not:
open SUM, "<$file" or die "Cannot open $file ($!)";
print "Bye, bye baby!\n";
unlink $0;
}
-
- The new version will not let that happen.
+
+ The new version will not let that happen.
-I am contemplating (but have not yet implemented) making '-lp' the
default indentation, because it is stable now and may be closer to how
-Improved syntax checking and corrected tokenization of functions such
as rand, srand, sqrt, ... These can accept either an operator or a term
to their right. This has been corrected.
-
- -Corrected tokenization of semicolon: testing of the previous update showed
+
+ -Corrected tokenization of semicolon: testing of the previous update showed
that the semicolon in the following statement was being mis-tokenized. That
did no harm, other than adding an extra blank space, but has been corrected.
$biblionumber, $constraint,
$bibitems
);
-
- The updated version doesn't do this unless the space is really needed:
+
+ The updated version doesn't do this unless the space is really needed:
new: my $fee = CalcReserveFee(
$env, $borrnum,
lastName => undef,
hireDay => $hireDay
};
-
- new: my $hireDay = new Date;
+
+ new: my $hireDay = new Date;
my $self = {
firstName => undef,
lastName => undef,
$^W =1 to BEGIN {$^W=1} to use warnings in compile phase, and corrected
several unnecessary 'my' declarations. Many thanks to Wolfgang Weisselberg,
2001-06-12, for catching these errors.
-
- -A '-bar' flag has been added to require braces to always be on the
+
+ -A '-bar' flag has been added to require braces to always be on the
right, even for multi-line if and foreach statements. For example,
the default formatting of a long if statement would be:
calls. This will also cause full indentation ('-i=n, default n= 4) of
continued parameter list lines rather than just the number of spaces
given with -ci=n, default n=2.
-
- -Added support for hanging side comments. Perltidy identifies a hanging
+
+ -Added support for hanging side comments. Perltidy identifies a hanging
side comment as a comment immediately following a line with a side
comment or another hanging side comment. This should work in most
cases. It can be deactivated with --no-hanging-side-comments (-nhsc).
$mw->Label(
-text => "perltidy",
-relief => 'ridge')->pack;
-
- the current default is:
+
+ the current default is:
$mw->Label(
-text => "perltidy",
-fixed another cuddled-else formatting bug (Reported by Craig Bourne)
-added several diagnostic --dump routines
-
- -added token-level whitespace controls (suggested by Hans Ecke)
+
+ -added token-level whitespace controls (suggested by Hans Ecke)
2001 03 23:
-added support for special variables of the form ${^WANT_BITS}
#
# perltidy - a perl script indenter and formatter
#
-# Copyright (c) 2000-2009 by Steve Hancock
+# Copyright (c) 2000-2012 by Steve Hancock
# Distributed under the GPL license agreement; see file COPYING
#
# This program is free software; you can redistribute it and/or modify
use Cwd;
use IO::File;
use File::Basename;
+use File::Copy;
BEGIN {
- ( $VERSION = q($Id: Tidy.pm,v 1.74 2010/12/17 13:56:49 perltidy Exp $) ) =~ s/^.*\s+(\d+)\/(\d+)\/(\d+).*$/$1$2$3/; # all one line for MakeMaker
+ ( $VERSION = q($Id: Tidy.pm,v 1.74 2012/07/01 13:56:49 perltidy Exp $) ) =~ s/^.*\s+(\d+)\/(\d+)\/(\d+).*$/$1$2$3/; # all one line for MakeMaker
}
sub streamhandle {
sub make_temporary_filename {
# Make a temporary filename.
+ # FIXME: return both a name and opened filehandle
#
- # The POSIX tmpnam() function tends to be unreliable for non-unix
- # systems (at least for the win32 systems that I've tested), so use
- # a pre-defined name. A slight disadvantage of this is that two
- # perltidy runs in the same working directory may conflict.
- # However, the chance of that is small and managable by the user.
- # An alternative would be to check for the file's existance and use,
- # say .TMP0, .TMP1, etc, but that scheme has its own problems. So,
- # keep it simple.
+ # The POSIX tmpnam() function tends to be unreliable for non-unix systems
+ # (at least for the win32 systems that I've tested), so use a pre-defined
+ # name for them. A disadvantage of this is that two perltidy
+ # runs in the same working directory may conflict. However, the chance of
+ # that is small and managable by the user, especially on systems for which
+ # the POSIX tmpnam function doesn't work.
my $name = "perltidy.TMP";
if ( $^O =~ /win32|dos/i || $^O eq 'VMS' || $^O eq 'MacOs' ) {
return $name;
use IO::File;
# just make a couple of tries before giving up and using the default
- for ( 0 .. 1 ) {
+ for ( 0 .. 3 ) {
my $tmpname = tmpnam();
my $fh = IO::File->new( $tmpname, O_RDWR | O_CREAT | O_EXCL );
if ($fh) {
# redirect STDERR if requested
if ($stderr_stream) {
+ my $ref_type = ref($stderr_stream);
+ if ( $ref_type eq 'SCALAR' or $ref_type eq 'ARRAY' ) {
+ croak <<EOM;
+------------------------------------------------------------------------
+You are trying to redirect STDERR to a reference of type $ref_type
+It can only be redirected to a file
+Please check value of -stderr in call to perltidy
+------------------------------------------------------------------------
+EOM
+ }
my ( $fh_stderr, $stderr_file ) =
Perl::Tidy::streamhandle( $stderr_stream, 'w' );
if ($fh_stderr) { *STDERR = $fh_stderr }
$dot_pattern = '\.'; # must escape for use in regex
}
- # handle command line options
+ #---------------------------------------------------------------
+ # get command line options
+ #---------------------------------------------------------------
my ( $rOpts, $config_file, $rraw_options, $saw_extrude, $roption_string,
$rexpansion, $roption_category, $roption_range )
= process_command_line(
$rpending_complaint, $dump_options_type,
);
+ #---------------------------------------------------------------
+ # Handle requests to dump information
+ #---------------------------------------------------------------
+
# return or exit immediately after all dumps
my $quit_now = 0;
# dump from command line
if ( $rOpts->{'dump-options'} ) {
print STDOUT $readable_options;
- exit 1;
+ exit 0;
}
+ #---------------------------------------------------------------
+ # check parameters and their interactions
+ #---------------------------------------------------------------
check_options( $rOpts, $is_Windows, $Windows_type,
$rpending_complaint );
make_extension( $rOpts->{'output-file-extension'},
$default_file_extension{ $rOpts->{'format'} }, $dot );
+ # If the backup extension contains a / character then the backup should
+ # be deleted when the -b option is used. On older versions of
+ # perltidy this will generate an error message due to an illegal
+ # file name.
+ #
+ # A backup file will still be generated but will be deleted
+ # at the end. If -bext='/' then this extension will be
+ # the default 'bak'. Otherwise it will be whatever characters
+ # remains after all '/' characters are removed. For example:
+ # -bext extension slashes
+ # '/' bak 1
+ # '/delete' delete 1
+ # 'delete/' delete 1
+ # '/dev/null' devnull 2 (Currently not allowed)
+ my $bext = $rOpts->{'backup-file-extension'};
+ my $delete_backup = ( $rOpts->{'backup-file-extension'} =~ s/\///g );
+
+ # At present only one forward slash is allowed. In the future multiple
+ # slashes may be allowed to allow for other options
+ if ( $delete_backup > 1 ) {
+ die "-bext=$bext contains more than one '/'\n";
+ }
+
my $backup_extension =
make_extension( $rOpts->{'backup-file-extension'}, 'bak', $dot );
make_extension( $rOpts->{'html-src-extension'}, 'src', $dot );
# check for -b option;
+ # silently ignore unless beautify mode
my $in_place_modify = $rOpts->{'backup-and-modify-in-place'}
- && $rOpts->{'format'} eq 'tidy' # silently ignore unless beautify mode
- && @ARGV > 0; # silently ignore if standard input;
- # this allows -b to be in a .perltidyrc file
- # without error messages when running from an editor
+ && $rOpts->{'format'} eq 'tidy';
# turn off -b with warnings in case of conflicts with other options
if ($in_place_modify) {
}
if ($destination_stream) {
warn
-"Ignoring -b; you may not specify a destination array and -b together\n";
+"Ignoring -b; you may not specify a destination stream and -b together\n";
$in_place_modify = 0;
}
- if ($source_stream) {
+ if ( ref($source_stream) ) {
warn
"Ignoring -b; you may not specify a source array and -b together\n";
$in_place_modify = 0;
unshift( @ARGV, '-' ) unless @ARGV;
}
- # loop to process all files in argument list
+ #---------------------------------------------------------------
+ # Ready to go...
+ # main loop to process all files in argument list
+ #---------------------------------------------------------------
my $number_of_files = @ARGV;
my $formatter = undef;
$tokenizer = undef;
my $input_file_permissions;
#---------------------------------------------------------------
- # determine the input file name
+ # prepare this input stream
#---------------------------------------------------------------
if ($source_stream) {
$fileroot = "perltidy";
next;
}
+ # As a safety precaution, skip zero length files.
+ # If for example a source file got clobberred somehow,
+ # the old .tdy or .bak files might still exist so we
+ # shouldn't overwrite them with zero length files.
+ unless ( -s $input_file ) {
+ print "skipping file: $input_file: Zero size\n";
+ next;
+ }
+
unless ( ( -T $input_file ) || $rOpts->{'force-read-binary'} ) {
print
"skipping file: $input_file: Non-text (override with -f)\n";
if $diagnostics_object;
#---------------------------------------------------------------
- # determine the output file name
+ # prepare the output stream
#---------------------------------------------------------------
my $output_file = undef;
my $actual_output_extension;
Perl::Tidy::Debugger->new( $fileroot . $dot . "DEBUG" );
}
- # loop over iterations
- my $max_iterations = $rOpts->{'iterations'};
- my $sink_object_final = $sink_object;
- for ( my $iter = 1 ; $iter <= $max_iterations ; $iter++ ) {
- my $temp_buffer;
+ #---------------------------------------------------------------
+ # loop over iterations for one source stream
+ #---------------------------------------------------------------
- # local copies of some debugging objects which get deleted
- # after first iteration, but will reappear after this loop
- my $debugger_object = $debugger_object;
- my $logger_object = $logger_object;
- my $diagnostics_object = $diagnostics_object;
+ # We will do a convergence test if 3 or more iterations are allowed.
+ # It would be pointless for fewer because we have to make at least
+ # two passes before we can see if we are converged, and the test
+ # would just slow things down.
+ my $max_iterations = $rOpts->{'iterations'};
+ my $convergence_log_message;
+ my %saw_md5;
+ my $do_convergence_test = $max_iterations > 2;
+ if ($do_convergence_test) {
+ eval "use Digest::MD5 qw(md5_hex)";
+ $do_convergence_test = !$@;
+ }
+
+ # save objects to allow redirecting output during iterations
+ my $sink_object_final = $sink_object;
+ my $debugger_object_final = $debugger_object;
+ my $logger_object_final = $logger_object;
+
+ for ( my $iter = 1 ; $iter <= $max_iterations ; $iter++ ) {
- # output to temp buffer until last iteration
+ # send output stream to temp buffers until last iteration
+ my $sink_buffer;
if ( $iter < $max_iterations ) {
$sink_object =
- Perl::Tidy::LineSink->new( \$temp_buffer, $tee_file,
+ Perl::Tidy::LineSink->new( \$sink_buffer, $tee_file,
$line_separator, $rOpts, $rpending_logfile_message,
$binmode );
}
else {
$sink_object = $sink_object_final;
+ }
- # terminate some debugging output after first pass
- # to avoid needless output.
- $debugger_object = undef;
- $logger_object = undef;
- $diagnostics_object = undef;
+ # Save logger, debugger output only on pass 1 because:
+ # (1) line number references must be to the starting
+ # source, not an intermediate result, and
+ # (2) we need to know if there are errors so we can stop the
+ # iterations early if necessary.
+ if ( $iter > 1 ) {
+ $debugger_object = undef;
+ $logger_object = undef;
}
- #---------------------------------------------------------------
- # create a formatter for this file : html writer or pretty printer
- #---------------------------------------------------------------
+ #------------------------------------------------------------
+ # create a formatter for this file : html writer or
+ # pretty printer
+ #------------------------------------------------------------
# we have to delete any old formatter because, for safety,
# the formatter will check to see that there is only one.
$source_object->close_input_file();
# line source for next iteration (if any) comes from the current
- # temporary buffer
+ # temporary output buffer
if ( $iter < $max_iterations ) {
+
+ $sink_object->close_output_file();
$source_object =
- Perl::Tidy::LineSource->new( \$temp_buffer, $rOpts,
+ Perl::Tidy::LineSource->new( \$sink_buffer, $rOpts,
$rpending_logfile_message );
- }
- } # end loop over iterations
+ # stop iterations if errors or converged
+ my $stop_now = $logger_object->{_warning_count};
+ if ($stop_now) {
+ $convergence_log_message = <<EOM;
+Stopping iterations because of errors.
+EOM
+ }
+ elsif ($do_convergence_test) {
+ my $digest = md5_hex($sink_buffer);
+ if ( !$saw_md5{$digest} ) {
+ $saw_md5{$digest} = $iter;
+ }
+ else {
+
+ # Saw this result before, stop iterating
+ $stop_now = 1;
+ my $iterm = $iter - 1;
+ if ( $saw_md5{$digest} != $iterm ) {
+
+ # Blinking (oscillating) between two stable
+ # end states. This has happened in the past
+ # but at present there are no known instances.
+ $convergence_log_message = <<EOM;
+Blinking. Output for iteration $iter same as for $saw_md5{$digest}.
+EOM
+ $diagnostics_object->write_diagnostics(
+ $convergence_log_message)
+ if $diagnostics_object;
+ }
+ else {
+ $convergence_log_message = <<EOM;
+Converged. Output for iteration $iter same as for iter $iterm.
+EOM
+ $diagnostics_object->write_diagnostics(
+ $convergence_log_message)
+ if $diagnostics_object && $iterm > 2;
+ }
+ }
+ } ## end if ($do_convergence_test)
+
+ if ($stop_now) {
+
+ # we are stopping the iterations early;
+ # copy the output stream to its final destination
+ $sink_object = $sink_object_final;
+ while ( my $line = $source_object->get_line() ) {
+ $sink_object->write_line($line);
+ }
+ $source_object->close_input_file();
+ last;
+ }
+ } ## end if ( $iter < $max_iterations)
+ } # end loop over iterations for one source file
+
+ # restore objects which have been temporarily undefined
+ # for second and higher iterations
+ $debugger_object = $debugger_object_final;
+ $logger_object = $logger_object_final;
- # get file names to use for syntax check
- my $ifname = $source_object->get_input_file_copy_name();
- my $ofname = $sink_object->get_output_file_copy();
+ $logger_object->write_logfile_entry($convergence_log_message)
+ if $convergence_log_message;
+
+ #---------------------------------------------------------------
+ # Perform any postfilter operation
+ #---------------------------------------------------------------
+ if ($postfilter) {
+ $sink_object->close_output_file();
+ $sink_object =
+ Perl::Tidy::LineSink->new( $output_file, $tee_file,
+ $line_separator, $rOpts, $rpending_logfile_message,
+ $binmode );
+ my $buf = $postfilter->($postfilter_buffer);
+ $source_object =
+ Perl::Tidy::LineSource->new( \$buf, $rOpts,
+ $rpending_logfile_message );
+ ##chomp $buf;
+ ##foreach my $line ( split( "\n", $buf , -1) ) {
+ while ( my $line = $source_object->get_line() ) {
+ $sink_object->write_line($line);
+ }
+ $source_object->close_input_file();
+ }
+
+ # Save names of the input and output files for syntax check
+ my $ifname = $input_file;
+ my $ofname = $output_file;
#---------------------------------------------------------------
# handle the -b option (backup and modify in-place)
# oh, oh, no real file to backup ..
# shouldn't happen because of numerous preliminary checks
- die print
+ die
"problem with -b backing up input file '$input_file': not a file\n";
}
my $backup_name = $input_file . $backup_extension;
or die
"unable to remove previous '$backup_name' for -b option; check permissions: $!\n";
}
- rename( $input_file, $backup_name )
- or die
+
+ # backup the input file
+ # we use copy for symlinks, move for regular files
+ if ( -l $input_file ) {
+ File::Copy::copy( $input_file, $backup_name )
+ or die "File::Copy failed trying to backup source: $!";
+ }
+ else {
+ rename( $input_file, $backup_name )
+ or die
"problem renaming $input_file to $backup_name for -b option: $!\n";
+ }
$ifname = $backup_name;
+ # copy the output to the original input file
+ # NOTE: it would be nice to just close $output_file and use
+ # File::Copy::copy here, but in this case $output_file is the
+ # handle of an open nameless temporary file so we would lose
+ # everything if we closed it.
seek( $output_file, 0, 0 )
- or die "unable to rewind tmp file for -b option: $!\n";
-
+ or die
+ "unable to rewind a temporary file for -b option: $!\n";
my $fout = IO::File->new("> $input_file")
or die
-"problem opening $input_file for write for -b option; check directory permissions: $!\n";
+"problem re-opening $input_file for write for -b option; check file and directory permissions: $!\n";
binmode $fout;
my $line;
while ( $line = $output_file->getline() ) {
$sink_object->close_output_file() if $sink_object;
$debugger_object->close_debug_file() if $debugger_object;
- if ($postfilter) {
- my $new_sink =
- Perl::Tidy::LineSink->new( $output_file, $tee_file,
- $line_separator, $rOpts, $rpending_logfile_message,
- $binmode );
- my $buf = $postfilter->($postfilter_buffer);
- foreach my $line ( split( "\n", $buf ) ) {
- $new_sink->write_line($line);
- }
- }
-
- my $infile_syntax_ok = 0; # -1 no 0=don't know 1 yes
- if ($output_file) {
-
+ # set output file permissions
+ if ( $output_file && -f $output_file && !-l $output_file ) {
if ($input_file_permissions) {
# give output script same permissions as input script, but
}
# else use default permissions for html and any other format
+ }
+ }
+
+ #---------------------------------------------------------------
+ # Do syntax check if requested and possible
+ #---------------------------------------------------------------
+ my $infile_syntax_ok = 0; # -1 no 0=don't know 1 yes
+ if ( $logger_object
+ && $rOpts->{'check-syntax'}
+ && $ifname
+ && $ofname )
+ {
+ $infile_syntax_ok =
+ check_syntax( $ifname, $ofname, $logger_object, $rOpts );
+ }
+ #---------------------------------------------------------------
+ # remove the original file for in-place modify as follows:
+ # $delete_backup=0 never
+ # $delete_backup=1 only if no errors
+ # $delete_backup>1 always : CURRENTLY NOT ALLOWED, see above
+ #---------------------------------------------------------------
+ if ( $in_place_modify
+ && $delete_backup
+ && -f $ifname
+ && ( $delete_backup > 1 || !$logger_object->{_warning_count} ) )
+ {
+
+ # As an added safety precaution, do not delete the source file
+ # if its size has dropped from positive to zero, since this
+ # could indicate a disaster of some kind, including a hardware
+ # failure. Actually, this could happen if you had a file of
+ # all comments (or pod) and deleted everything with -dac (-dap)
+ # for some reason.
+ if ( !-s $output_file && -s $ifname && $delete_backup == 1 ) {
+ warn(
+"output file '$output_file' missing or zero length; original '$ifname' not deleted\n"
+ );
}
- if ( $logger_object && $rOpts->{'check-syntax'} ) {
- $infile_syntax_ok =
- check_syntax( $ifname, $ofname, $logger_object, $rOpts );
+ else {
+ unlink($ifname)
+ or die
+"unable to remove previous '$ifname' for -b option; check permissions: $!\n";
}
}
$logger_object->finish( $infile_syntax_ok, $formatter )
if $logger_object;
- } # end of loop to process all files
- } # end of main program
+ } # end of main loop to process all files
+ } # end of main program perltidy
+}
+
+sub get_stream_as_named_file {
+
+ # Return the name of a file containing a stream of data, creating
+ # a temporary file if necessary.
+ # Given:
+ # $stream - the name of a file or stream
+ # Returns:
+ # $fname = name of file if possible, or undef
+ # $if_tmpfile = true if temp file, undef if not temp file
+ #
+ # This routine is needed for passing actual files to Perl for
+ # a syntax check.
+ my ($stream) = @_;
+ my $is_tmpfile;
+ my $fname;
+ if ($stream) {
+ if ( ref($stream) ) {
+ my ( $fh_stream, $fh_name ) =
+ Perl::Tidy::streamhandle( $stream, 'r' );
+ if ($fh_stream) {
+ my ( $fout, $tmpnam );
+
+ # FIXME: fix the tmpnam routine to return an open filehandle
+ $tmpnam = Perl::Tidy::make_temporary_filename();
+ $fout = IO::File->new( $tmpnam, 'w' );
+
+ if ($fout) {
+ $fname = $tmpnam;
+ $is_tmpfile = 1;
+ binmode $fout;
+ while ( my $line = $fh_stream->getline() ) {
+ $fout->print($line);
+ }
+ $fout->close();
+ }
+ $fh_stream->close();
+ }
+ }
+ elsif ( $stream ne '-' && -f $stream ) {
+ $fname = $stream;
+ }
+ }
+ return ( $fname, $is_tmpfile );
}
sub fileglob_to_re {
########################################
$category = 7; # Retaining or ignoring existing line breaks
########################################
- $add_option->( 'break-at-old-keyword-breakpoints', 'bok', '!' );
- $add_option->( 'break-at-old-logical-breakpoints', 'bol', '!' );
- $add_option->( 'break-at-old-ternary-breakpoints', 'bot', '!' );
- $add_option->( 'ignore-old-breakpoints', 'iob', '!' );
+ $add_option->( 'break-at-old-keyword-breakpoints', 'bok', '!' );
+ $add_option->( 'break-at-old-logical-breakpoints', 'bol', '!' );
+ $add_option->( 'break-at-old-ternary-breakpoints', 'bot', '!' );
+ $add_option->( 'break-at-old-attribute-breakpoints', 'boa', '!' );
+ $add_option->( 'ignore-old-breakpoints', 'iob', '!' );
########################################
$category = 8; # Blank line control
########################################
- $add_option->( 'blanks-before-blocks', 'bbb', '!' );
- $add_option->( 'blanks-before-comments', 'bbc', '!' );
- $add_option->( 'blanks-before-subs', 'bbs', '!' );
- $add_option->( 'long-block-line-count', 'lbl', '=i' );
- $add_option->( 'maximum-consecutive-blank-lines', 'mbl', '=i' );
- $add_option->( 'keep-old-blank-lines', 'kbl', '=i' );
+ $add_option->( 'blanks-before-blocks', 'bbb', '!' );
+ $add_option->( 'blanks-before-comments', 'bbc', '!' );
+ $add_option->( 'blank-lines-before-subs', 'blbs', '=i' );
+ $add_option->( 'blank-lines-before-packages', 'blbp', '=i' );
+ $add_option->( 'long-block-line-count', 'lbl', '=i' );
+ $add_option->( 'maximum-consecutive-blank-lines', 'mbl', '=i' );
+ $add_option->( 'keep-old-blank-lines', 'kbl', '=i' );
########################################
$category = 9; # Other controls
add-whitespace
blanks-before-blocks
blanks-before-comments
- blanks-before-subs
+ blank-lines-before-subs=1
+ blank-lines-before-packages=1
block-brace-tightness=0
block-brace-vertical-tightness=0
brace-tightness=1
brace-vertical-tightness=0
break-at-old-logical-breakpoints
break-at-old-ternary-breakpoints
+ break-at-old-attribute-breakpoints
break-at-old-keyword-breakpoints
comma-arrow-breakpoints=1
nocheck-syntax
'baa' => [qw(cab=0)],
'nbaa' => [qw(cab=1)],
+ 'blanks-before-subs' => [qw(blbs=1 blbp=1)],
+ 'bbs' => [qw(blbs=1 blbp=1)],
+ 'noblanks-before-subs' => [qw(blbs=0 blbp=0)],
+ 'nbbs' => [qw(blbs=0 blbp=0)],
+
'break-at-old-trinary-breakpoints' => [qw(bot)],
'cti=0' => [qw(cpi=0 cbi=0 csbi=0)],
noadd-semicolons
noadd-whitespace
noblanks-before-blocks
- noblanks-before-subs
+ blank-lines-before-subs=0
+ blank-lines-before-packages=0
notabs
)
],
noadd-semicolons
noadd-whitespace
noblanks-before-blocks
- noblanks-before-subs
+ blank-lines-before-subs=0
+ blank-lines-before-packages=0
nofuzzy-line-length
notabs
norecombine
elsif ( $i =~ /^-extrude$/ ) {
$saw_extrude = 1;
}
- elsif ( $i =~ /^-(help|h|HELP|H)$/ ) {
+ elsif ( $i =~ /^-(help|h|HELP|H|\?)$/ ) {
usage();
- exit 1;
+ exit 0;
}
elsif ( $i =~ /^-(version|v)$/ ) {
show_version();
- exit 1;
+ exit 0;
}
elsif ( $i =~ /^-(dump-defaults|ddf)$/ ) {
dump_defaults(@$rdefaults);
- exit 1;
+ exit 0;
}
elsif ( $i =~ /^-(dump-long-names|dln)$/ ) {
dump_long_names(@$roption_string);
- exit 1;
+ exit 0;
}
elsif ( $i =~ /^-(dump-short-names|dsn)$/ ) {
dump_short_names($rexpansion);
- exit 1;
+ exit 0;
}
elsif ( $i =~ /^-(dump-token-types|dtt)$/ ) {
Perl::Tidy::Tokenizer->dump_token_types(*STDOUT);
- exit 1;
+ exit 0;
}
}
}
if ($saw_dump_profile) {
- if ($saw_dump_profile) {
- dump_config_file( $fh_config, $config_file,
- $rconfig_file_chatter );
- exit 1;
- }
+ dump_config_file( $fh_config, $config_file, $rconfig_file_chatter );
+ exit 0;
}
if ($fh_config) {
# check iteration count and quietly fix if necessary:
# - iterations option only applies to code beautification mode
- # - it shouldn't be nessary to use more than about 2 iterations
+ # - the convergence check should stop most runs on iteration 2, and
+ # virtually all on iteration 3. But we'll allow up to 6.
if ( $rOpts->{'format'} ne 'tidy' ) {
$rOpts->{'iterations'} = 1;
}
elsif ( defined( $rOpts->{'iterations'} ) ) {
if ( $rOpts->{'iterations'} <= 0 ) { $rOpts->{'iterations'} = 1 }
- elsif ( $rOpts->{'iterations'} > 5 ) { $rOpts->{'iterations'} = 5 }
+ elsif ( $rOpts->{'iterations'} > 6 ) { $rOpts->{'iterations'} = 6 }
}
else {
$rOpts->{'iterations'} = 1;
}
+ # check for reasonable number of blank lines and fix to avoid problems
+ if ( $rOpts->{'blank-lines-before-subs'} ) {
+ if ( $rOpts->{'blank-lines-before-subs'} < 0 ) {
+ $rOpts->{'blank-lines-before-subs'} = 0;
+ warn "negative value of -blbs, setting 0\n";
+ }
+ if ( $rOpts->{'blank-lines-before-subs'} > 100 ) {
+ warn "unreasonably large value of -blbs, reducing\n";
+ $rOpts->{'blank-lines-before-subs'} = 100;
+ }
+ }
+ if ( $rOpts->{'blank-lines-before-packages'} ) {
+ if ( $rOpts->{'blank-lines-before-packages'} < 0 ) {
+ warn "negative value of -blbp, setting 0\n";
+ $rOpts->{'blank-lines-before-packages'} = 0;
+ }
+ if ( $rOpts->{'blank-lines-before-packages'} > 100 ) {
+ warn "unreasonably large value of -blbp, reducing\n";
+ $rOpts->{'blank-lines-before-packages'} = 100;
+ }
+ }
+
# see if user set a non-negative logfile-gap
if ( defined( $rOpts->{'logfile-gap'} ) && $rOpts->{'logfile-gap'} >= 0 ) {
while ( my $line = $fh->getline() ) {
$line_no++;
chomp $line;
- next if $line =~ /^\s*#/; # skip full-line comment
( $line, $death_message ) =
strip_comment( $line, $config_file, $line_no );
last if ($death_message);
+ next unless $line;
$line =~ s/^\s*(.*?)\s*$/$1/; # trim both ends
next unless $line;
# or just
# body
- if ( $line =~ /^((\w+)\s*\{)?([^}]*)(\})?$/ ) {
- my ( $newname, $body, $curly ) = ( $2, $3, $4 );
+ my $body = $line;
+ my ($newname);
+ if ( $line =~ /^((\w+)\s*\{)(.*)\}$/ ) {
+ ( $newname, $body ) = ( $2, $3, );
+ }
+ if ($body) {
# handle a new alias definition
if ($newname) {
push( @config_list, @$rbody_parts );
}
}
-
- if ($curly) {
- unless ($name) {
- $death_message =
-"Unexpected '}' seen in config file $config_file line $.\n";
- last;
- }
- $name = undef;
- }
}
}
eval { $fh->close() };
sub strip_comment {
+ # Strip any comment from a command line
my ( $instr, $config_file, $line_no ) = @_;
my $msg = "";
+ # check for full-line comment
+ if ( $instr =~ /^\s*#/ ) {
+ return ( "", $msg );
+ }
+
# nothing to do if no comments
if ( $instr !~ /#/ ) {
return ( $instr, $msg );
}
- # use simple method of no quotes
+ # handle case of no quotes
elsif ( $instr !~ /['"]/ ) {
- $instr =~ s/\s*\#.*$//; # simple trim
+
+ # We now require a space before the # of a side comment
+ # this allows something like:
+ # -sbcp=#
+ # Otherwise, it would have to be quoted:
+ # -sbcp='#'
+ $instr =~ s/\s+\#.*$//;
return ( $instr, $msg );
}
$outstr .= $1;
$quote_char = $1;
}
+
+ # Note: not yet enforcing the space-before-hash rule for side
+ # comments if the parameter is quoted.
elsif ( $instr =~ /\G#/gc ) {
last;
}
print <<"EOM";
This is perltidy, v$VERSION
-Copyright 2000-2010, Steve Hancock
+Copyright 2000-2012, 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.
-bol break at old logical breakpoints: or, and, ||, && (default)
-bok break at old list keyword breakpoints such as map, sort (default)
-bot break at old conditional (ternary ?:) operator breakpoints (default)
+ -boa break at old attribute breakpoints
-cab=n break at commas after a comma-arrow (=>):
n=0 break at all commas after =>
n=1 stable: break unless this breaks an existing one-line container
# Use 'perl -c' to make sure that we did not create bad syntax
# This is a very good independent check for programming errors
#
- # Given names of the input and output files, ($ifname, $ofname),
+ # Given names of the input and output files, ($istream, $ostream),
# we do the following:
# - check syntax of the input file
# - if bad, all done (could be an incomplete code snippet)
# - if outfile syntax bad, issue warning; this implies a code bug!
# - set and return flag "infile_syntax_ok" : =-1 bad 0 unknown 1 good
- my ( $ifname, $ofname, $logger_object, $rOpts ) = @_;
+ my ( $istream, $ostream, $logger_object, $rOpts ) = @_;
my $infile_syntax_ok = 0;
my $line_of_dashes = '-' x 42 . "\n";
}
# this shouldn't happen unless a termporary file couldn't be made
- if ( $ifname eq '-' ) {
+ if ( $istream eq '-' ) {
$logger_object->write_logfile_entry(
"Cannot run perl -c on STDIN and STDOUT\n");
return $infile_syntax_ok;
$logger_object->write_logfile_entry(
"checking input file syntax with perl $flags\n");
- $logger_object->write_logfile_entry($line_of_dashes);
# Not all operating systems/shells support redirection of the standard
# error output.
my $error_redirection = ( $^O eq 'VMS' ) ? "" : '2>&1';
- my $perl_output = do_syntax_check( $ifname, $flags, $error_redirection );
+ my ( $istream_filename, $perl_output ) =
+ do_syntax_check( $istream, $flags, $error_redirection );
+ $logger_object->write_logfile_entry(
+ "Input stream passed to Perl as file $istream_filename\n");
+ $logger_object->write_logfile_entry($line_of_dashes);
$logger_object->write_logfile_entry("$perl_output\n");
if ( $perl_output =~ /syntax\s*OK/ ) {
$logger_object->write_logfile_entry($line_of_dashes);
$logger_object->write_logfile_entry(
"checking output file syntax with perl $flags ...\n");
+ my ( $ostream_filename, $perl_output ) =
+ do_syntax_check( $ostream, $flags, $error_redirection );
+ $logger_object->write_logfile_entry(
+ "Output stream passed to Perl as file $ostream_filename\n");
$logger_object->write_logfile_entry($line_of_dashes);
-
- my $perl_output =
- do_syntax_check( $ofname, $flags, $error_redirection );
$logger_object->write_logfile_entry("$perl_output\n");
unless ( $perl_output =~ /syntax\s*OK/ ) {
$logger_object->write_logfile_entry($line_of_dashes);
$logger_object->warning(
-"The output file has a syntax error when tested with perl $flags $ofname !\n"
+"The output file has a syntax error when tested with perl $flags $ostream !\n"
);
$logger_object->warning(
- "This implies an error in perltidy; the file $ofname is bad\n");
+ "This implies an error in perltidy; the file $ostream is bad\n"
+ );
$logger_object->report_definite_bug();
# the perl version number will be helpful for diagnosing the problem
# Only warn of perl -c syntax errors. Other messages,
# such as missing modules, are too common. They can be
# seen by running with perltidy -w
- $logger_object->complain("A syntax check using perl $flags gives: \n");
+ $logger_object->complain("A syntax check using perl $flags\n");
+ $logger_object->complain(
+ "for the output in file $istream_filename gives:\n");
$logger_object->complain($line_of_dashes);
$logger_object->complain("$perl_output\n");
$logger_object->complain($line_of_dashes);
}
sub do_syntax_check {
- my ( $fname, $flags, $error_redirection ) = @_;
+ my ( $stream, $flags, $error_redirection ) = @_;
+
+ # We need a named input file for executing perl
+ my ( $stream_filename, $is_tmpfile ) = get_stream_as_named_file($stream);
+
+ # TODO: Need to add name of file to log somewhere
+ # otherwise Perl output is hard to read
+ if ( !$stream_filename ) { return $stream_filename, "" }
# We have to quote the filename in case it has unusual characters
# or spaces. Example: this filename #CM11.pm# gives trouble.
- $fname = '"' . $fname . '"';
+ my $quoted_stream_filename = '"' . $stream_filename . '"';
# Under VMS something like -T will become -t (and an error) so we
# will put quotes around the flags. Double quotes seem to work on
$flags = '"' . $flags . '"';
# now wish for luck...
- return qx/perl $flags $fname $error_redirection/;
+ my $msg = qx/perl $flags $quoted_stream_filename $error_redirection/;
+
+ unlink $stream_filename if ($is_tmpfile);
+ return $stream_filename, $msg;
}
#####################################################################
# Convert a scalar to an array.
# This avoids looking for "\n" on each call to getline
- my @array = map { $_ .= "\n" } split /\n/, ${$rscalar};
+ #
+ # NOTES: The -1 count is needed to avoid loss of trailing blank lines
+ # (which might be important in a DATA section).
+ my @array;
+ if ( $rscalar && ${$rscalar} ) {
+ @array = map { $_ .= "\n" } split /\n/, ${$rscalar}, -1;
+
+ # remove possible extra blank line introduced with split
+ if ( @array && $array[-1] eq "\n" ) { pop @array }
+ }
my $i_next = 0;
return bless [ \@array, $mode, $i_next ], $package;
}
EOM
}
my $i = $self->[2]++;
- ##my $line = $self->[0]->[$i];
return $self->[0]->[$i];
}
sub new {
my ( $class, $input_file, $rOpts, $rpending_logfile_message ) = @_;
- my $input_file_copy = undef;
- my $fh_copy;
my $input_line_ending;
if ( $rOpts->{'preserve-line-endings'} ) {
# The reason is that temporary files cause problems on
# on many systems.
$rOpts->{'check-syntax'} = 0;
- $input_file_copy = '-';
$$rpending_logfile_message .= <<EOM;
Note: --syntax check will be skipped because standard input is used
return bless {
_fh => $fh,
- _fh_copy => $fh_copy,
_filename => $input_file,
- _input_file_copy => $input_file_copy,
_input_line_ending => $input_line_ending,
_rinput_buffer => [],
_started => 0,
}, $class;
}
-sub get_input_file_copy_name {
- my $self = shift;
- my $ifname = $self->{_input_file_copy};
- unless ($ifname) {
- $ifname = $self->{_filename};
- }
- return $ifname;
-}
-
sub close_input_file {
my $self = shift;
eval { $self->{_fh}->close() };
- eval { $self->{_fh_copy}->close() } if $self->{_fh_copy};
}
sub get_line {
my $self = shift;
my $line = undef;
my $fh = $self->{_fh};
- my $fh_copy = $self->{_fh_copy};
my $rinput_buffer = $self->{_rinput_buffer};
if ( scalar(@$rinput_buffer) ) {
$self->{_started}++;
}
}
- if ( $line && $fh_copy ) { $fh_copy->print($line); }
return $line;
}
my ( $class, $output_file, $tee_file, $line_separator, $rOpts,
$rpending_logfile_message, $binmode )
= @_;
- my $fh = undef;
- my $fh_copy = undef;
- my $fh_tee = undef;
- my $output_file_copy = "";
+ my $fh = undef;
+ my $fh_tee = undef;
+
my $output_file_open = 0;
if ( $rOpts->{'format'} eq 'tidy' ) {
# The reason is that temporary files cause problems on
# on many systems.
$rOpts->{'check-syntax'} = 0;
- $output_file_copy = '-';
$$rpending_logfile_message .= <<EOM;
Note: --syntax check will be skipped because standard output is used
EOM
bless {
_fh => $fh,
- _fh_copy => $fh_copy,
_fh_tee => $fh_tee,
_output_file => $output_file,
_output_file_open => $output_file_open,
- _output_file_copy => $output_file_copy,
_tee_flag => 0,
_tee_file => $tee_file,
_tee_file_opened => 0,
sub write_line {
- my $self = shift;
- my $fh = $self->{_fh};
- my $fh_copy = $self->{_fh_copy};
+ my $self = shift;
+ my $fh = $self->{_fh};
my $output_file_open = $self->{_output_file_open};
chomp $_[0];
$_[0] .= $self->{_line_separator};
$fh->print( $_[0] ) if ( $self->{_output_file_open} );
- print $fh_copy $_[0] if ( $fh_copy && $self->{_output_file_copy} );
if ( $self->{_tee_flag} ) {
unless ( $self->{_tee_file_opened} ) { $self->really_open_tee_file() }
}
}
-sub get_output_file_copy {
- my $self = shift;
- my $ofname = $self->{_output_file_copy};
- unless ($ofname) {
- $ofname = $self->{_output_file};
- }
- return $ofname;
-}
-
sub tee_on {
my $self = shift;
$self->{_tee_flag} = 1;
sub close_output_file {
my $self = shift;
- eval { $self->{_fh}->close() } if $self->{_output_file_open};
- eval { $self->{_fh_copy}->close() } if ( $self->{_output_file_copy} );
+ eval { $self->{_fh}->close() } if $self->{_output_file_open};
$self->close_tee_file();
}
bless {
_log_file => $log_file,
- _fh_warnings => undef,
_rOpts => $rOpts,
_fh_warnings => undef,
_last_input_line_written => 0,
( $fh_warnings, my $filename ) =
Perl::Tidy::streamhandle( $warning_file, 'w' );
$fh_warnings or die("couldn't open $filename $!\n");
- warn "## Please see file $filename\n";
+ warn "## Please see file $filename\n" unless ref($warning_file);
}
$self->{_fh_warnings} = $fh_warnings;
}
# write style sheet to STDOUT and die if requested
if ( defined( $rOpts->{'stylesheet'} ) ) {
write_style_sheet_file('-');
- exit 1;
+ exit 0;
}
# make sure user gives a file name after -css
$last_indentation_written
$last_unadjusted_indentation
$last_leading_token
+ $last_output_short_opening_token
$saw_VERSION_in_this_file
$saw_END_or_DATA_
%block_leading_text
%block_opening_line_number
$csc_new_statement_ok
+ $csc_last_label
+ %csc_block_label
$accumulating_text_for_block
$leading_block_text
$rleading_block_if_elsif_text
%opening_vertical_tightness
%closing_vertical_tightness
%closing_token_indentation
+ $some_closing_token_indentation
%opening_token_right
%stack_opening_token
$rOpts_break_at_old_comma_breakpoints
$rOpts_break_at_old_logical_breakpoints
$rOpts_break_at_old_ternary_breakpoints
+ $rOpts_break_at_old_attribute_breakpoints
$rOpts_closing_side_comment_else_flag
$rOpts_closing_side_comment_maximum_text
$rOpts_continuation_indentation
# We can remove semicolons after blocks preceded by these keywords
@_ =
qw(BEGIN END CHECK INIT AUTOLOAD DESTROY UNITCHECK continue if elsif else
- unless while until for foreach);
+ unless while until for foreach given when default);
@is_block_without_semicolon{@_} = (1) x scalar(@_);
# 'L' is token for opening { at hash key
$max_gnu_stack_index = 0;
$max_gnu_item_index = -1;
$gnu_stack[0] = new_lp_indentation_item( 0, -1, -1, 0, 0 );
- @gnu_item_list = ();
- $last_output_indentation = 0;
- $last_indentation_written = 0;
- $last_unadjusted_indentation = 0;
- $last_leading_token = "";
+ @gnu_item_list = ();
+ $last_output_indentation = 0;
+ $last_indentation_written = 0;
+ $last_unadjusted_indentation = 0;
+ $last_leading_token = "";
+ $last_output_short_opening_token = 0;
$saw_VERSION_in_this_file = !$rOpts->{'pass-version-line'};
$saw_END_or_DATA_ = 0;
%block_leading_text = ();
%block_opening_line_number = ();
$csc_new_statement_ok = 1;
+ %csc_block_label = ();
%saved_opening_indentation = ();
$in_format_skipping_section = 0;
my $tee_line = 0;
if ( $line_type =~ /^POD/ ) {
- # Pod docs should have a preceding blank line. But be
- # very careful in __END__ and __DATA__ sections, because:
- # 1. the user may be using this section for any purpose whatsoever
- # 2. the blank counters are not active there
- # It should be safe to request a blank line between an
- # __END__ or __DATA__ and an immediately following '=head'
- # type line, (types END_START and DATA_START), but not for
- # any other lines of type END or DATA.
+ # Pod docs should have a preceding blank line. But stay
+ # out of __END__ and __DATA__ sections, because
+ # the user may be using this section for any purpose whatsoever
if ( $rOpts->{'delete-pod'} ) { $skip_line = 1; }
if ( $rOpts->{'tee-pod'} ) { $tee_line = 1; }
if ( !$skip_line
# If the previous line is a __DATA__ line (or data
# contents, it's not valid to change it at all, no
# matter what is in the data
- && $last_line_type !~ /^(END|DATA(?:_START)?)$/ )
+ && !$saw_END_or_DATA_ )
{
want_blank_line();
}
}
if ( $rOpts->{'dump-want-left-space'} ) {
dump_want_left_space(*STDOUT);
- exit 1;
+ exit 0;
}
if ( $rOpts->{'dump-want-right-space'} ) {
dump_want_right_space(*STDOUT);
- exit 1;
+ exit 0;
}
# default keywords for which space is introduced before an opening paren
unless while for foreach return switch case given when);
@space_after_keyword{@_} = (1) x scalar(@_);
- # allow user to modify these defaults
- if ( @_ = split_words( $rOpts->{'space-after-keyword'} ) ) {
- @space_after_keyword{@_} = (1) x scalar(@_);
- }
-
+ # first remove any or all of these if desired
if ( @_ = split_words( $rOpts->{'nospace-after-keyword'} ) ) {
+
+ # -nsak='*' selects all the above keywords
+ if ( @_ == 1 && $_[0] eq '*' ) { @_ = keys(%space_after_keyword) }
@space_after_keyword{@_} = (0) x scalar(@_);
}
+ # then allow user to add to these defaults
+ if ( @_ = split_words( $rOpts->{'space-after-keyword'} ) ) {
+ @space_after_keyword{@_} = (1) x scalar(@_);
+ }
+
# implement user break preferences
my @all_operators = qw(% + - * / x != == >= <= =~ !~ < > | &
= **= += *= &= <<= &&= -= /= |= >>= ||= //= .= %= ^= x=
$rOpts_comma_arrow_breakpoints = $rOpts->{'comma-arrow-breakpoints'};
$rOpts_break_at_old_ternary_breakpoints =
$rOpts->{'break-at-old-ternary-breakpoints'};
+ $rOpts_break_at_old_attribute_breakpoints =
+ $rOpts->{'break-at-old-attribute-breakpoints'};
$rOpts_break_at_old_comma_breakpoints =
$rOpts->{'break-at-old-comma-breakpoints'};
$rOpts_break_at_old_keyword_breakpoints =
'>' => $rOpts->{'closing-paren-indentation'},
);
+ # flag indicating if any closing tokens are indented
+ $some_closing_token_indentation =
+ $rOpts->{'closing-paren-indentation'}
+ || $rOpts->{'closing-brace-indentation'}
+ || $rOpts->{'closing-square-bracket-indentation'}
+ || $rOpts->{'indent-closing-brace'};
+
%opening_token_right = (
'(' => $rOpts->{'opening-paren-right'},
'{' => $rOpts->{'opening-hash-brace-right'},
$tokenl eq 'my'
# /^(for|foreach)$/
- && $is_for_foreach{$tokenll}
+ && $is_for_foreach{$tokenll}
&& $tokenr =~ /^\$/
)
{
$in_format_skipping_section = 0;
write_logfile_entry("Exiting formatting skip section\n");
+ $file_writer_object->reset_consecutive_blank_lines();
}
return;
}
&& $last_line_had_side_comment # last line had side comment
&& $input_line =~ /^\s/ # there is some leading space
&& !$is_static_block_comment # do not make static comment hanging
- && $rOpts->{'hanging-side-comments'} # user is allowing this
+ && $rOpts->{'hanging-side-comments'} # user is allowing
+ # hanging side comments
+ # like this
)
{
# output a blank line before block comments
if (
- $last_line_leading_type !~ /^[#b]$/
- && $rOpts->{'blanks-before-comments'} # only if allowed
- && !
- $is_static_block_comment # never before static block comments
+ # unless we follow a blank or comment line
+ $last_line_leading_type !~ /^[#b]$/
+
+ # only if allowed
+ && $rOpts->{'blanks-before-comments'}
+
+ # not if this is an empty comment line
+ && $$rtokens[0] ne '#'
+
+ # not after a short line ending in an opening token
+ # because we already have space above this comment.
+ # Note that the first comment in this if block, after
+ # the 'if (', does not get a blank line because of this.
+ && !$last_output_short_opening_token
+
+ # never before static block comments
+ && !$is_static_block_comment
)
{
- flush(); # switching to new output stream
+ flush(); # switching to new output stream
$file_writer_object->write_blank_code_line();
$last_line_leading_type = 'b';
}
# TRIM COMMENTS -- This could be turned off as a option
- $$rtokens[0] =~ s/\s*$//; # trim right end
+ $$rtokens[0] =~ s/\s*$//; # trim right end
if (
$rOpts->{'indent-block-comments'}
}
if ( $token =~ /^sub/ ) { $token =~ s/\s+/ /g }
+
+ # trim identifiers of trailing blanks which can occur
+ # under some unusual circumstances, such as if the
+ # identifier 'witch' has trailing blanks on input here:
+ #
+ # sub
+ # witch
+ # () # prototype may be on new line ...
+ # ...
+ if ( $type eq 'i' ) { $token =~ s/\s+$//g }
}
# change 'LABEL :' to 'LABEL:'
# anything left to write?
if ( $imin <= $imax ) {
- # add a blank line before certain key types
- if ( $last_line_leading_type !~ /^[#b]/ ) {
+ # add a blank line before certain key types but not after a comment
+ ##if ( $last_line_leading_type !~ /^[#b]/ ) {
+ if ( $last_line_leading_type !~ /^[#]/ ) {
my $want_blank = 0;
my $leading_token = $tokens_to_go[$imin];
my $leading_type = $types_to_go[$imin];
# blank lines before subs except declarations and one-liners
# MCONVERSION LOCATION - for sub tokenization change
if ( $leading_token =~ /^(sub\s)/ && $leading_type eq 'i' ) {
- $want_blank = ( $rOpts->{'blanks-before-subs'} )
- && (
+ $want_blank = $rOpts->{'blank-lines-before-subs'}
+ if (
terminal_type( \@types_to_go, \@block_type_to_go, $imin,
$imax ) !~ /^[\;\}]$/
);
elsif ($leading_token =~ /^(package\s)/
&& $leading_type eq 'i' )
{
- $want_blank = ( $rOpts->{'blanks-before-subs'} );
+ $want_blank = $rOpts->{'blank-lines-before-packages'};
}
# break before certain key blocks except one-liners
if ( $leading_token =~ /^(BEGIN|END)$/ && $leading_type eq 'k' ) {
- $want_blank = ( $rOpts->{'blanks-before-subs'} )
- && (
+ $want_blank = $rOpts->{'blank-lines-before-subs'}
+ if (
terminal_type( \@types_to_go, \@block_type_to_go, $imin,
$imax ) ne '}'
);
# Break before certain block types if we haven't had a
# break at this level for a while. This is the
# difficult decision..
- elsif ($leading_token =~ /^(unless|if|while|until|for|foreach)$/
- && $leading_type eq 'k' )
+ elsif ($leading_type eq 'k'
+ && $last_line_leading_type ne 'b'
+ && $leading_token =~ /^(unless|if|while|until|for|foreach)$/ )
{
my $lc = $nonblank_lines_at_depth[$last_line_leading_level];
if ( !defined($lc) ) { $lc = 0 }
# future: send blank line down normal path to VerticalAligner
Perl::Tidy::VerticalAligner::flush();
- $file_writer_object->write_blank_code_line();
+ $file_writer_object->require_blank_code_lines($want_blank);
}
}
my $i_nonblank =
( $$rtoken_type[ $i + 1 ] eq 'b' ) ? $i + 2 : $i + 1;
- if ( $$rtoken_type[$i_nonblank] eq '#' ) {
+ # Patch for one-line sort/map/grep/eval blocks with side comments:
+ # We will ignore the side comment length for sort/map/grep/eval
+ # because this can lead to statements which change every time
+ # perltidy is run. Here is an example from Denis Moskowitz which
+ # oscillates between these two states without this patch:
+
+## --------
+## grep { $_->foo ne 'bar' } # asdfa asdf asdf asdf asdf asdf asdf asdf asdf asdf asdf
+## @baz;
+##
+## grep {
+## $_->foo ne 'bar'
+## } # asdfa asdf asdf asdf asdf asdf asdf asdf asdf asdf asdf
+## @baz;
+## --------
+
+ # When the first line is input it gets broken apart by the main
+ # line break logic in sub print_line_of_tokens.
+ # When the second line is input it gets recombined by
+ # print_line_of_tokens and passed to the output routines. The
+ # output routines (set_continuation_breaks) do not break it apart
+ # because the bond strengths are set to the highest possible value
+ # for grep/map/eval/sort blocks, so the first version gets output.
+ # It would be possible to fix this by changing bond strengths,
+ # but they are high to prevent errors in older versions of perl.
+
+ if ( $$rtoken_type[$i_nonblank] eq '#'
+ && !$is_sort_map_grep{$block_type} )
+ {
+
+ ## POSSIBLE FUTURE PATCH FOR IGNORING SIDE COMMENT LENGTHS
+ ## WHEN CHECKING FOR ONE-LINE BLOCKS:
+ ## if (flag set) then (just add 1 to pos)
$pos += length( $$rtokens[$i_nonblank] );
if ( $i_nonblank > $i + 1 ) {
- $pos += length( $$rtokens[ $i + 1 ] );
+
+ # source whitespace could be anything, assume
+ # at least one space before the hash on output
+ if ( $$rtoken_type[ $i + 1 ] eq 'b' ) { $pos += 1 }
+ else { $pos += length( $$rtokens[ $i + 1 ] ) }
}
- if ( $pos > $rOpts_maximum_line_length ) {
+ if ( $pos >= $rOpts_maximum_line_length ) {
return 0;
}
}
last unless $ipad;
}
+ # We cannot pad a leading token at the lowest level because
+ # it could cause a bug in which the starting indentation
+ # level is guessed incorrectly each time the code is run
+ # though perltidy, thus causing the code to march off to
+ # the right. For example, the following snippet would have
+ # this problem:
+
+## ov_method mycan( $package, '(""' ), $package
+## or ov_method mycan( $package, '(0+' ), $package
+## or ov_method mycan( $package, '(bool' ), $package
+## or ov_method mycan( $package, '(nomethod' ), $package;
+
+ # If this snippet is within a block this won't happen
+ # unless the user just processes the snippet alone within
+ # an editor. In that case either the user will see and
+ # fix the problem or it will be corrected next time the
+ # entire file is processed with perltidy.
+ next if ( $ipad == 0 && $levels_to_go[$ipad] == 0 );
+
# next line must not be at greater depth
my $iend_next = $$ri_last[ $line + 1 ];
next
# this will contain the column number of the last character
# of the closing side comment
+ ##$csc_last_label="" unless $csc_last_label;
$leading_block_text_line_length =
+ length($csc_last_label) +
length($accumulating_text_for_block) +
length( $rOpts->{'closing-side-comment-prefix'} ) +
$leading_block_text_level * $rOpts_indent_columns + 3;
my $i_terminal = 0; # index of last nonblank token
my $terminal_block_type = "";
+ # update most recent statement label
+ $csc_last_label = "" unless ($csc_last_label);
+ if ( $types_to_go[0] eq 'J' ) { $csc_last_label = $tokens_to_go[0] }
+ my $block_label = $csc_last_label;
+
+ # Loop over all tokens of this batch
for my $i ( 0 .. $max_index_to_go ) {
my $type = $types_to_go[$i];
my $block_type = $block_type_to_go[$i];
$rblock_leading_if_elsif_text;
}
+ if ( defined( $csc_block_label{$type_sequence} ) ) {
+ $block_label = $csc_block_label{$type_sequence};
+ delete $csc_block_label{$type_sequence};
+ }
+
# if we run into a '}' then we probably started accumulating
# at something like a trailing 'if' clause..no harm done.
if ( $accumulating_text_for_block
$vertical_aligner_object->get_output_line_number();
$block_opening_line_number{$type_sequence} = $line_number;
+ # set a label for this block, except for
+ # a bare block which already has the label
+ # A label can only be used on the next {
+ if ( $block_type =~ /:$/ ) { $csc_last_label = "" }
+ $csc_block_label{$type_sequence} = $csc_last_label;
+ $csc_last_label = "";
+
if ( $accumulating_text_for_block
&& $levels_to_go[$i] == $leading_block_text_level )
{
$block_leading_text, $rblock_leading_if_elsif_text );
}
+ # if this line ends in a label then remember it for the next pass
+ $csc_last_label = "";
+ if ( $terminal_type eq 'J' ) {
+ $csc_last_label = $tokens_to_go[$i_terminal];
+ }
+
return ( $terminal_type, $i_terminal, $i_block_leading_text,
- $block_leading_text, $block_line_count );
+ $block_leading_text, $block_line_count, $block_label );
}
}
#---------------------------------------------------------------
my ( $terminal_type, $i_terminal, $i_block_leading_text,
- $block_leading_text, $block_line_count )
+ $block_leading_text, $block_line_count, $block_label )
= accumulate_csc_text();
#---------------------------------------------------------------
{
# then make the closing side comment text
+ if ($block_label) { $block_label .= " " }
my $token =
-"$rOpts->{'closing-side-comment-prefix'} $block_type_to_go[$i_terminal]";
+"$rOpts->{'closing-side-comment-prefix'} $block_label$block_type_to_go[$i_terminal]";
# append any extra descriptive text collected above
if ( $i_block_leading_text == $i_terminal ) {
my ( $rtokens, $rfields, $rpatterns ) =
make_alignment_patterns( $ibeg, $iend );
+ # Set flag to show how much level changes between this line
+ # and the next line, if we have it.
+ my $ljump = 0;
+ if ( $n < $n_last_line ) {
+ my $ibegp = $$ri_first[ $n + 1 ];
+ $ljump = $levels_to_go[$ibegp] - $levels_to_go[$iend];
+ }
+
my ( $indentation, $lev, $level_end, $terminal_type,
$is_semicolon_terminated, $is_outdented_line )
= set_adjusted_indentation( $ibeg, $iend, $rfields, $rpatterns,
- $ri_first, $ri_last, $rindentation_list );
+ $ri_first, $ri_last, $rindentation_list, $ljump );
# we will allow outdenting of long lines..
my $outdent_long_lines = (
$do_not_pad = 0;
+ # Set flag indicating if this line ends in an opening
+ # token and is very short, so that a blank line is not
+ # needed if the subsequent line is a comment.
+ # Examples of what we are looking for:
+ # {
+ # && (
+ # BEGIN {
+ # default {
+ # sub {
+ $last_output_short_opening_token
+
+ # line ends in opening token
+ = $types_to_go[$iend] =~ /^[\{\(\[L]$/
+
+ # and either
+ && (
+ # line has either single opening token
+ $iend == $ibeg
+
+ # or is a single token followed by opening token.
+ # Note that sub identifiers have blanks like 'sub doit'
+ || ( $iend - $ibeg <= 2 && $tokens_to_go[$ibeg] !~ /\s+/ )
+ )
+
+ # and limit total to 10 character widths
+ && token_sequence_length( $ibeg, $iend ) <= 10;
+
+## $last_output_short_opening_token =
+## $types_to_go[$iend] =~ /^[\{\(\[L]$/
+## && $iend - $ibeg <= 2
+## && $tokens_to_go[$ibeg] !~ /^sub/
+## && token_sequence_length( $ibeg, $iend ) <= 10;
+
} # end of loop to output each line
# remember indentation of lines containing opening containers for
# outdenting.
my ( $ibeg, $iend, $rfields, $rpatterns, $ri_first, $ri_last,
- $rindentation_list )
+ $rindentation_list, $level_jump )
= @_;
# we need to know the last token of this line
);
# if we are at a closing token of some type..
- if ( $types_to_go[$ibeg] =~ /^[\)\}\]]$/ ) {
+ if ( $types_to_go[$ibeg] =~ /^[\)\}\]R]$/ ) {
# get the indentation of the line containing the corresponding
# opening token
$rindentation_list );
# First set the default behavior:
- # default behavior is to outdent closing lines
- # of the form: "); }; ]; )->xxx;"
if (
+
+ # default behavior is to outdent closing lines
+ # of the form: "); }; ]; )->xxx;"
$is_semicolon_terminated
# and 'cuddled parens' of the form: ")->pack("
&& ( $nesting_depth_to_go[$iend] + 1 ==
$nesting_depth_to_go[$ibeg] )
)
+
+ # and when the next line is at a lower indentation level
+ # PATCH: and only if the style allows undoing continuation
+ # for all closing token types. We should really wait until
+ # the indentation of the next line is known and then make
+ # a decision, but that would require another pass.
+ || ( $level_jump < 0 && !$some_closing_token_indentation )
)
{
$adjust_indentation = 1;
}
- # TESTING: outdent something like '),'
+ # outdent something like '),'
if (
$terminal_type eq ','
my $is_isolated_block_brace = $block_type_to_go[$ibeg]
&& ( $iend == $ibeg
|| $is_if_elsif_else_unless_while_until_for_foreach{
- $block_type_to_go[$ibeg] } );
+ $block_type_to_go[$ibeg]
+ } );
# only do this for a ':; which is aligned with its leading '?'
my $is_unaligned_colon = $types_to_go[$ibeg] eq ':' && !$is_leading;
if ( $token eq '(' && $vert_last_nonblank_type eq 'k' ) {
$alignment_type = ""
unless $vert_last_nonblank_token =~
- /^(if|unless|elsif)$/;
+ /^(if|unless|elsif)$/;
}
# be sure the alignment tokens are unique
# adjust bond strength bias
#-----------------------------------------------------------------
- # TESTING: add any bias set by sub scan_list at old comma
- # break points.
+ # add any bias set by sub scan_list at old comma break points.
elsif ( $type eq ',' ) {
$bond_str += $bond_strength_to_go[$i];
}
# won't work very well. However, the user can always
# prevent following the old breakpoints with the
# -iob flag.
- my $dd = shift;
- my $bias = -.01;
+ my $dd = shift;
+ my $bias = -.01;
+ my $old_comma_break_count = 0;
foreach my $ii ( @{ $comma_index[$dd] } ) {
if ( $old_breakpoint_to_go[$ii] ) {
+ $old_comma_break_count++;
$bond_strength_to_go[$ii] = $bias;
# reduce bias magnitude to force breaks in order
# Also put a break before the first comma if
# (1) there was a break there in the input, and
# (2) that was exactly one previous break in the input
+ # (3) there are multiple old comma breaks
#
# For example, we will follow the user and break after
# 'print' in this snippet:
# "\t", $have, " is ", text_unit($hu), "\n",
# "\t", $want, " is ", text_unit($wu), "\n",
# ;
+ # But we will not force a break after the first comma here
+ # (causes a blinker):
+ # $heap->{stream}->set_output_filter(
+ # poe::filter::reference->new('myotherfreezer') ),
+ # ;
+ #
my $i_first_comma = $comma_index[$dd]->[0];
if ( $old_breakpoint_to_go[$i_first_comma] ) {
my $level_comma = $levels_to_go[$i_first_comma];
if ( $levels_to_go[$ii] == $level_comma );
}
}
- if ( $ibreak >= 0 && $obp_count == 1 ) {
+ if ( $ibreak >= 0 && $obp_count == 1 && $old_comma_break_count > 1 )
+ {
set_forced_breakpoint($ibreak);
}
}
$item_count_stack[$dd] == 0
&& $is_logical_container{ $container_type[$dd] }
- # TESTING:
|| $has_old_logical_breakpoints[$dd]
)
{
$want_previous_breakpoint = $i;
}
}
+
+ # Break before attributes if user broke there
+ if ($rOpts_break_at_old_attribute_breakpoints) {
+ if ( $next_nonblank_type eq 'A' ) {
+ $want_previous_breakpoint = $i;
+ }
+ }
}
next if ( $type eq 'b' );
$depth = $nesting_depth_to_go[ $i + 1 ];
if ( $type eq ':' ) {
$last_colon_sequence_number = $type_sequence;
- # TESTING: retain break at a ':' line break
+ # retain break at a ':' line break
if ( ( $i == $i_line_start || $i == $i_line_end )
&& $rOpts_break_at_old_ternary_breakpoints )
{
# if '=' at end of line ...
elsif ( $is_assignment{ $types_to_go[$iend_1] } ) {
+ # keep break after = if it was in input stream
+ # this helps prevent 'blinkers'
+ next if $old_breakpoint_to_go[$iend_1]
+
+ # don't strand an isolated '='
+ && $iend_1 != $ibeg_1;
+
my $is_short_quote =
( $types_to_go[$ibeg_2] eq 'Q'
&& $ibeg_2 == $iend_2
foreach my $ii ( $ibeg_0, $ibeg_1, $ibeg_3, $ibeg_4 ) {
$local_count++
if $ii >= 0
- && $types_to_go[$ii] eq ':'
- && $levels_to_go[$ii] == $lev;
+ && $types_to_go[$ii] eq ':'
+ && $levels_to_go[$ii] == $lev;
}
next unless ( $local_count > 1 );
}
# handle line with leading = or similar
elsif ( $is_assignment{ $types_to_go[$ibeg_2] } ) {
- next unless $n == 1;
+ next unless ( $n == 1 || $n == $nmax );
next
unless (
# or the next line ends with a here doc
|| $types_to_go[$iend_2] eq 'h'
+
+ # or this is a short line ending in ;
+ || ( $n == $nmax && $this_line_is_semicolon_terminated )
);
+ $forced_breakpoint_to_go[$iend_1] = 0;
}
#----------------------------------------------------------
my $bs = $bond_strength_to_go[$iend_1] + $bs_tweak;
# combined line cannot be too long
+ my $excess = excess_line_length( $ibeg_1, $iend_2 );
+ next if ( $excess > 0 );
+
+ # Require a few extra spaces before recombining lines if we are
+ # at an old breakpoint unless this is a simple list or terminal
+ # line. The goal is to avoid oscillating between two
+ # quasi-stable end states. For example this snippet caused
+ # problems:
+## my $this =
+## bless {
+## TText => "[" . ( join ',', map { "\"$_\"" } split "\n", $_ ) . "]"
+## },
+## $type;
next
- if excess_line_length( $ibeg_1, $iend_2 ) > 0;
+ if ( $old_breakpoint_to_go[$iend_1]
+ && !$this_line_is_semicolon_terminated
+ && $n < $nmax
+ && $excess + 4 > 0
+ && $types_to_go[$iend_2] ne ',' );
# do not recombine if we would skip in indentation levels
if ( $n < $nmax ) {
my $next_nonblank_token = $tokens_to_go[$i_next_nonblank];
my $next_nonblank_block_type = $block_type_to_go[$i_next_nonblank];
my $strength = $bond_strength_to_go[$i_test];
- my $must_break = 0;
- # FIXME: TESTING: Might want to be able to break after these
+ # use old breaks as a tie-breaker. For example to
+ # prevent blinkers with -pbp in this code:
+
+##@keywords{
+## qw/ARG OUTPUT PROTO CONSTRUCTOR RETURNS DESC PARAMS SEEALSO EXAMPLE/}
+## = ();
+
+ # At the same time try to prevent a leading * in this code
+ # with the default formatting:
+ #
+## return
+## factorial( $a + $b - 1 ) / factorial( $a - 1 ) / factorial( $b - 1 )
+## * ( $x**( $a - 1 ) )
+## * ( ( 1 - $x )**( $b - 1 ) );
+
+ # reduce strength a bit to break ties at an old breakpoint ...
+ $strength -= $tiny_bias
+ if $old_breakpoint_to_go[$i_test]
+
+ # which is a 'good' breakpoint, meaning ...
+ # we don't want to break before it
+ && !$want_break_before{$type}
+
+ # and either we want to break before the next token
+ # or the next token is not short (i.e. not a '*', '/' etc.)
+ && $i_next_nonblank <= $imax
+ && (
+ $want_break_before{$next_nonblank_type}
+ || ( $lengths_to_go[ $i_next_nonblank + 1 ] -
+ $lengths_to_go[$i_next_nonblank] > 2 )
+ || $next_nonblank_type =~ /^[\(\[\{L]$/
+ );
+
+ my $must_break = 0;
+
+ # FIXME: Might want to be able to break after these
# force an immediate break at certain operators
# with lower level than the start of the line
if (
# Avoid a break which would strand a single punctuation
# token. For example, we do not want to strand a leading
# '.' which is followed by a long quoted string.
+ # But note that we do want to do this with -extrude (l=1)
+ # so please test any changes to this code on -extrude.
if (
!$must_break
&& ( $i_test == $i_begin )
$leading_spaces +
$lengths_to_go[ $i_test + 1 ] -
$starting_sum
- ) <= $rOpts_maximum_line_length
+ ) < $rOpts_maximum_line_length
)
)
{
$i_l = $$ri_last[$line_number];
}
+ # Do not leave a blank at the end of a line; back up if necessary
+ if ( $types_to_go[$i_break_left] eq 'b' ) { $i_break_left-- }
+
my $i_break_right = $i_break_left + 1;
if ( $types_to_go[$i_break_right] eq 'b' ) { $i_break_right++ }
}
else {
- # REMOVE AFTER TESTING
# shouldn't happen - program error counting whitespace
# we'll skip entabbing
warning(
}
else {
- # REMOVE AFTER TESTING
# shouldn't happen - program error counting whitespace
# we'll skip entabbing
warning(
}
}
+sub require_blank_code_lines {
+
+ # write out the requested number of blanks regardless of the value of -mbl
+ # unless -mbl=0. This allows extra blank lines to be written for subs and
+ # packages even with the default -mbl=1
+ my $self = shift;
+ my $count = shift;
+ my $need = $count - $self->{_consecutive_blank_lines};
+ my $rOpts = $self->{_rOpts};
+ my $forced = $rOpts->{'maximum-consecutive-blank-lines'} > 0;
+ for ( my $i = 0 ; $i < $need ; $i++ ) {
+ $self->write_blank_code_line($forced);
+ }
+}
+
sub write_blank_code_line {
my $self = shift;
my $forced = shift;
@paren_structural_type
@brace_type
@brace_structural_type
- @brace_statement_type
@brace_context
@brace_package
@square_bracket_type
@square_bracket_structural_type
@depth_array
@nested_ternary_flag
+ @nested_statement_type
@starting_line_of_current_depth
};
$paren_structural_type[$brace_depth] = '';
$brace_type[$brace_depth] = ';'; # identify opening brace as code block
$brace_structural_type[$brace_depth] = '';
- $brace_statement_type[$brace_depth] = "";
$brace_context[$brace_depth] = UNKNOWN_CONTEXT;
$brace_package[$paren_depth] = $current_package;
$square_bracket_type[$square_bracket_depth] = '';
# localize all package variables
local (
- $tokenizer_self, $last_nonblank_token,
- $last_nonblank_type, $last_nonblank_block_type,
- $statement_type, $in_attribute_list,
- $current_package, $context,
- %is_constant, %is_user_function,
- %user_function_prototype, %is_block_function,
- %is_block_list_function, %saw_function_definition,
- $brace_depth, $paren_depth,
- $square_bracket_depth, @current_depth,
- @total_depth, $total_depth,
- @nesting_sequence_number, @current_sequence_number,
- @paren_type, @paren_semicolon_count,
- @paren_structural_type, @brace_type,
- @brace_structural_type, @brace_statement_type,
- @brace_context, @brace_package,
- @square_bracket_type, @square_bracket_structural_type,
- @depth_array, @starting_line_of_current_depth,
- @nested_ternary_flag,
+ $tokenizer_self, $last_nonblank_token,
+ $last_nonblank_type, $last_nonblank_block_type,
+ $statement_type, $in_attribute_list,
+ $current_package, $context,
+ %is_constant, %is_user_function,
+ %user_function_prototype, %is_block_function,
+ %is_block_list_function, %saw_function_definition,
+ $brace_depth, $paren_depth,
+ $square_bracket_depth, @current_depth,
+ @total_depth, $total_depth,
+ @nesting_sequence_number, @current_sequence_number,
+ @paren_type, @paren_semicolon_count,
+ @paren_structural_type, @brace_type,
+ @brace_structural_type, @brace_context,
+ @brace_package, @square_bracket_type,
+ @square_bracket_structural_type, @depth_array,
+ @starting_line_of_current_depth, @nested_ternary_flag,
+ @nested_statement_type,
);
# save all lexical variables
if ($is_pattern) {
$in_quote = 1;
$type = 'Q';
- $allowed_quote_modifiers = '[cgimosxp]';
+ $allowed_quote_modifiers = '[msixpodualgc]';
}
else { # not a pattern; check for a /= token
}
}
}
- $brace_type[ ++$brace_depth ] = $block_type;
- $brace_package[$brace_depth] = $current_package;
- ( $type_sequence, $indent_flag ) =
- increase_nesting_depth( BRACE, $$rtoken_map[$i_tok] );
+ $brace_type[ ++$brace_depth ] = $block_type;
+ $brace_package[$brace_depth] = $current_package;
$brace_structural_type[$brace_depth] = $type;
$brace_context[$brace_depth] = $context;
- $brace_statement_type[$brace_depth] = $statement_type;
+ ( $type_sequence, $indent_flag ) =
+ increase_nesting_depth( BRACE, $$rtoken_map[$i_tok] );
},
'}' => sub {
$block_type = $brace_type[$brace_depth];
$tok = $brace_type[$brace_depth];
}
- $context = $brace_context[$brace_depth];
- $statement_type = $brace_statement_type[$brace_depth];
+ $context = $brace_context[$brace_depth];
if ( $brace_depth > 0 ) { $brace_depth--; }
},
'&' => sub { # maybe sub call? start looking
# got mistaken as a q operator in an early version:
# print BODY &q(<<'EOT');
if ( $expecting != OPERATOR ) {
- scan_identifier();
+
+ # But only look for a sub call if we are expecting a term or
+ # if there is no existing space after the &.
+ # For example we probably don't want & as sub call here:
+ # Fcntl::S_IRUSR & $mode;
+ if ( $expecting == TERM || $next_type ne 'b' ) {
+ scan_identifier();
+ }
}
else {
}
if ($is_pattern) {
$in_quote = 1;
$type = 'Q';
- $allowed_quote_modifiers = '[cgimosxp]';
+ $allowed_quote_modifiers = '[msixpodualgc]';
}
else {
( $type_sequence, $indent_flag ) =
# ref: camel 3 p 147,
# but perl may accept undocumented flags
# perl 5.10 adds 'p' (preserve)
+ # Perl version 5.16, http://perldoc.perl.org/perlop.html, has these:
+ # /PATTERN/msixpodualgc or m?PATTERN?msixpodualgc
+ # s/PATTERN/REPLACEMENT/msixpodualgcer
+ # y/SEARCHLIST/REPLACEMENTLIST/cdsr
+ # tr/SEARCHLIST/REPLACEMENTLIST/cdsr
+ # qr/STRING/msixpodual
my %quote_modifiers = (
- 's' => '[cegimosxp]',
- 'y' => '[cds]',
- 'tr' => '[cds]',
- 'm' => '[cgimosxp]',
- 'qr' => '[imosxp]',
+ 's' => '[msixpodualgcer]',
+ 'y' => '[cdsr]',
+ 'tr' => '[cdsr]',
+ 'm' => '[msixpodualgc]',
+ 'qr' => '[msixpodual]',
'q' => "",
'qq' => "",
'qw' => "",
# mistaking {s} in the following for a quoted bare word:
# for(@[){s}bla}BLA}
# Also treat q in something like var{-q} as a bare word, not qoute operator
- ##if ( ( $last_nonblank_type eq 'L' )
- ## && ( $next_nonblank_token eq '}' ) )
if (
$next_nonblank_token eq '}'
&& (
if ($next_nonblank_token) {
if ( $is_keyword{$next_nonblank_token} ) {
- warning(
+
+ # Assume qw is used as a quote and okay, as in:
+ # use constant qw{ DEBUG 0 };
+ # Not worth trying to parse for just a warning
+ if ( $next_nonblank_token ne 'qw' ) {
+ warning(
"Attempting to define constant '$next_nonblank_token' which is a perl keyword\n"
- );
+ );
+ }
}
# FIXME: could check for error in which next token is
$statement_type = $tok; # next '{' is block
}
+ #
# indent trailing if/unless/while/until
# outdenting will be handled by later indentation loop
- if ( $tok =~ /^(if|unless|while|until)$/
- && $next_nonblank_token ne '(' )
- {
- $indent_flag = 1;
- }
+## DEACTIVATED: unfortunately this can cause some unwanted indentation like:
+##$opt_o = 1
+## if !(
+## $opt_b
+## || $opt_c
+## || $opt_d
+## || $opt_f
+## || $opt_i
+## || $opt_l
+## || $opt_o
+## || $opt_x
+## );
+## if ( $tok =~ /^(if|unless|while|until)$/
+## && $next_nonblank_token ne '(' )
+## {
+## $indent_flag = 1;
+## }
}
# check for inline label following
if ( $type eq 'k' ) {
$indented_if_level = $level_in_tokenizer;
}
- }
- if ( $routput_block_type->[$i] ) {
- $nesting_block_flag = 1;
- $nesting_block_string .= '1';
+ # do not change container environement here if we are not
+ # at a real list. Adding this check prevents "blinkers"
+ # often near 'unless" clauses, such as in the following
+ # code:
+## next
+## unless -e (
+## $archive =
+## File::Spec->catdir( $_, "auto", $root, "$sub$lib_ext" )
+## );
+
+ $nesting_block_string .= "$nesting_block_flag";
}
else {
- $nesting_block_flag = 0;
- $nesting_block_string .= '0';
+
+ if ( $routput_block_type->[$i] ) {
+ $nesting_block_flag = 1;
+ $nesting_block_string .= '1';
+ }
+ else {
+ $nesting_block_flag = 0;
+ $nesting_block_string .= '0';
+ }
}
# we will use continuation indentation within containers
else {
$bit = 1
unless
- $is_logical_container{ $routput_container_type->[$i]
- };
+ $is_logical_container{ $routput_container_type->[$i]
+ };
}
}
$nesting_list_string .= $bit;
# /^(\}|\{|BEGIN|END|CHECK|INIT|AUTOLOAD|DESTROY|UNITCHECK|continue|;|if|elsif|else|unless|while|until|for|foreach)$/
elsif (
$is_zero_continuation_block_type{
- $routput_block_type->[$i] } )
+ $routput_block_type->[$i]
+ } )
{
$in_statement_continuation = 0;
}
# /^(sort|grep|map|do|eval)$/ )
elsif (
$is_not_zero_continuation_block_type{
- $routput_block_type->[$i] } )
+ $routput_block_type->[$i]
+ } )
{
}
# or a sub definition
elsif ( ( $last_nonblank_type eq 'i' || $last_nonblank_type eq 't' )
- && $last_nonblank_token =~ /^sub\b/ )
+ && $last_nonblank_token =~ /^(sub|package)\b/ )
{
return $last_nonblank_token;
}
my ( $aa, $pos ) = @_;
# USES GLOBAL VARIABLES: $tokenizer_self, @current_depth,
- # @current_sequence_number, @depth_array, @starting_line_of_current_depth
+ # @current_sequence_number, @depth_array, @starting_line_of_current_depth,
+ # $statement_type
my $bb;
$current_depth[$aa]++;
$total_depth++;
}
}
}
+ $nested_statement_type[$aa][ $current_depth[$aa] ] = $statement_type;
+ $statement_type = "";
return ( $seqno, $indent );
}
# USES GLOBAL VARIABLES: $tokenizer_self, @current_depth,
# @current_sequence_number, @depth_array, @starting_line_of_current_depth
+ # $statement_type
my $bb;
my $seqno = 0;
my $input_line_number = $tokenizer_self->{_last_line_number};
if ( $aa == QUESTION_COLON ) {
$outdent = $nested_ternary_flag[ $current_depth[$aa] ];
}
+ $statement_type = $nested_statement_type[$aa][ $current_depth[$aa] ];
# check that any brace types $bb contained within are balanced
for $bb ( 0 .. $#closing_brace_names ) {
# check for error
my ( $next_nonblank_token, $i_next ) =
find_next_nonblank_token( $i, $rtokens, $max_token_index );
- if ( $next_nonblank_token !~ /^[;\}]$/ ) {
+ if ( $next_nonblank_token !~ /^[;\{\}]$/ ) {
warning(
"Unexpected '$next_nonblank_token' after package name '$tok'\n"
);
# -1 - no
my ( $i, $rtokens, $max_token_index ) = @_;
my $next_token = $$rtokens[ $i + 1 ];
- if ( $next_token =~ /^[cgimosxp]/ ) { $i++; } # skip possible modifier
+ if ( $next_token =~ /^[msixpodualgc]/ ) { $i++; } # skip possible modifier
my ( $next_nonblank_token, $i_next ) =
find_next_nonblank_token( $i, $rtokens, $max_token_index );
vec
warn
while
+ given
+ when
);
@is_keyword_taking_list{@keyword_taking_list} =
(1) x scalar(@keyword_taking_list);
# __PACKAGE__
# );
- # The list of keywords was extracted from function 'keyword' in
+ # The list of keywords was originally extracted from function 'keyword' in
# perl file toke.c version 5.005.03, using this utility, plus a
# little editing: (file getkwd.pl):
# while (<>) { while (/\"(.*)\"/g) { print "$1\n"; } }
Perl::Tidy::perltidy();
The module accepts input and output streams by a variety of methods.
-The following list of parameters may be any of a the following: a
+The following list of parameters may be any of the following: a
filename, an ARRAY reference, a SCALAR reference, or an object with
either a B<getline> or B<print> method, as appropriate.
=item source
-If the B<source> parameter is given, it defines the source of the
-input stream.
+If the B<source> parameter is given, it defines the source of the input stream.
+If an input stream is defined with the B<source> parameter then no other source
+filenames may be specified in the @ARGV array or B<argv> parameter.
=item destination
=item stderr
-The B<stderr> parameter allows the calling program to capture the output
-to what would otherwise go to the standard error output device.
+The B<stderr> parameter allows the calling program to redirect to a file the
+output of what would otherwise go to the standard error output device. Unlike
+many other parameters, $stderr must be a file or file handle; it may not be a
+reference to a SCALAR or ARRAY.
=item perltidyrc
=back
-=head1 EXAMPLE
+=head1 NOTES ON FORMATTING PARAMETERS
+
+Parameters which control formatting may be passed in several ways: in a
+F<.perltidyrc> configuration file, in the B<perltidyrc> parameter, and in the
+B<argv> parameter.
+
+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
+use of temporary files can cause somewhat confusing output from Perl.
+
+=head1 EXAMPLES
+
+The perltidy script itself is a simple example, and several
+examples are given in the perltidy distribution.
The following example passes perltidy a snippet as a reference
to a string and receives the result back in a reference to
=head1 VERSION
-This man page documents Perl::Tidy version 20101217.
+This man page documents Perl::Tidy version 20120701.
+
+=head1 LICENSE
+
+This package is free software; you can redistribute it and/or modify it
+under the terms of the "GNU General Public License".
+
+Please refer to the file "COPYING" for details.
=head1 AUTHOR