#
-###########################################################-
+###########################################################
#
# perltidy - a perl script indenter and formatter
#
-# Copyright (c) 2000-2019 by Steve Hancock
+# Copyright (c) 2000-2022 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 strict;
use Exporter;
use Carp;
+use English qw( -no_match_vars );
use Digest::MD5 qw(md5_hex);
use Perl::Tidy::Debugger;
use Perl::Tidy::DevNull;
use Perl::Tidy::Logger;
use Perl::Tidy::Tokenizer;
use Perl::Tidy::VerticalAligner;
-local $| = 1;
+local $OUTPUT_AUTOFLUSH = 1;
+
+# DEVEL_MODE can be turned on for extra checking during development
+use constant DEVEL_MODE => 0;
+use constant EMPTY_STRING => q{};
+use constant SPACE => q{ };
use vars qw{
$VERSION
@ISA
@EXPORT
- $missing_file_spec
- $fh_stderr
- $rOpts_character_encoding
};
@ISA = qw( Exporter );
use Cwd;
use Encode ();
+use Encode::Guess;
use IO::File;
use File::Basename;
use File::Copy;
# To make the number continually increasing, the Development Number is a 2
# digit number starting at 01 after a release is continually bumped along
- # at significant points during developement. If it ever reaches 99 then the
+ # at significant points during development. If it ever reaches 99 then the
# Release version must be bumped, and it is probably past time for a
# release anyway.
- $VERSION = '20190601';
+ $VERSION = '20220613';
+}
+
+sub DESTROY {
+
+ # required to avoid call to AUTOLOAD in some versions of perl
}
+sub AUTOLOAD {
+
+ # Catch any undefined sub calls so that we are sure to get
+ # some diagnostic information. This sub should never be called
+ # except for a programming error.
+ our $AUTOLOAD;
+ return if ( $AUTOLOAD =~ /\bDESTROY$/ );
+ my ( $pkg, $fname, $lno ) = caller();
+ print STDERR <<EOM;
+======================================================================
+Unexpected call to Autoload looking for sub $AUTOLOAD
+Called from package: '$pkg'
+Called from File '$fname' at line '$lno'
+This error is probably due to a recent programming change
+======================================================================
+EOM
+ exit 1;
+} ## end sub AUTOLOAD
+
sub streamhandle {
# given filename and mode (r or w), create an object which:
# object object
# (check for 'print' method for 'w' mode)
# (check for 'getline' method for 'r' mode)
- my ( $filename, $mode ) = @_;
+
+ # An optional flag $is_encoded_data may be given, as follows:
+
+ # Case 1. Any non-empty string: encoded data is being transferred, set
+ # encoding to be utf8 for files and for stdin.
+
+ # Case 2. Not given, or an empty string: unencoded binary data is being
+ # transferred, set binary mode for files and for stdin.
+
+ my ( $filename, $mode, $is_encoded_data ) = @_;
my $ref = ref($filename);
my $New;
# handle a reference
if ($ref) {
if ( $ref eq 'ARRAY' ) {
- $New = sub { Perl::Tidy::IOScalarArray->new(@_) };
+ $New = sub { Perl::Tidy::IOScalarArray->new( $filename, $mode ) };
}
elsif ( $ref eq 'SCALAR' ) {
- $New = sub { Perl::Tidy::IOScalar->new(@_) };
+ $New = sub { Perl::Tidy::IOScalar->new( $filename, $mode ) };
}
else {
$New = sub { undef };
confess <<EOM;
------------------------------------------------------------------------
-No 'getline' method is defined for object of class $ref
+No 'getline' method is defined for object of class '$ref'
Please check your call to Perl::Tidy::perltidy. Trace follows.
------------------------------------------------------------------------
EOM
$New = sub { undef };
confess <<EOM;
------------------------------------------------------------------------
-No 'print' method is defined for object of class $ref
+No 'print' method is defined for object of class '$ref'
Please check your call to Perl::Tidy::perltidy. Trace follows.
------------------------------------------------------------------------
EOM
$New = sub { $mode eq 'w' ? *STDOUT : *STDIN }
}
else {
- $New = sub { IO::File->new(@_) };
+ $New = sub { IO::File->new( $filename, $mode ) };
+ }
+ }
+ $fh = $New->( $filename, $mode );
+ if ( !$fh ) {
+
+ Warn("Couldn't open file:$filename in mode:$mode : $ERRNO\n");
+
+ }
+ else {
+
+ # Case 1: handle encoded data
+ if ($is_encoded_data) {
+ if ( ref($fh) eq 'IO::File' ) {
+ ## binmode object call not available in older perl versions
+ ## $fh->binmode(":raw:encoding(UTF-8)");
+ binmode $fh, ":raw:encoding(UTF-8)";
+ }
+ elsif ( $filename eq '-' ) {
+ binmode STDOUT, ":raw:encoding(UTF-8)";
+ }
+ else {
+ # shouldn't happen
+ }
+ }
+
+ # Case 2: handle unencoded data
+ else {
+ if ( ref($fh) eq 'IO::File' ) { binmode $fh }
+ elsif ( $filename eq '-' ) { binmode STDOUT }
+ else { } # shouldn't happen
}
}
- $fh = $New->( $filename, $mode )
- or Warn("Couldn't open file:$filename in mode:$mode : $!\n");
return $fh, ( $ref or $filename );
-}
+} ## end sub streamhandle
sub find_input_line_ending {
binmode $fh;
my $buf;
read( $fh, $buf, 1024 );
- close $fh;
+ close $fh || return $ending;
if ( $buf && $buf =~ /([\012\015]+)/ ) {
my $test = $1;
else { }
return $ending;
-}
-
-sub catfile {
+} ## end sub find_input_line_ending
- # concatenate a path and file basename
- # returns undef in case of error
+{ ## begin closure for sub catfile
- my @parts = @_;
+ my $missing_file_spec;
BEGIN {
eval { require File::Spec };
- $missing_file_spec = $@;
+ $missing_file_spec = $EVAL_ERROR;
}
- # use File::Spec if we can
- unless ($missing_file_spec) {
- return File::Spec->catfile(@parts);
- }
+ sub catfile {
- # Perl 5.004 systems may not have File::Spec so we'll make
- # a simple try. We assume File::Basename is available.
- # return if not successful.
- my $name = pop @parts;
- my $path = join '/', @parts;
- my $test_file = $path . $name;
- my ( $test_name, $test_path ) = fileparse($test_file);
- return $test_file if ( $test_name eq $name );
- return if ( $^O eq 'VMS' );
+ # concatenate a path and file basename
+ # returns undef in case of error
- # this should work at least for Windows and Unix:
- $test_file = $path . '/' . $name;
- ( $test_name, $test_path ) = fileparse($test_file);
- return $test_file if ( $test_name eq $name );
- return;
-}
+ my @parts = @_;
+
+ # use File::Spec if we can
+ unless ($missing_file_spec) {
+ return File::Spec->catfile(@parts);
+ }
+
+ # Perl 5.004 systems may not have File::Spec so we'll make
+ # a simple try. We assume File::Basename is available.
+ # return if not successful.
+ my $name = pop @parts;
+ my $path = join '/', @parts;
+ my $test_file = $path . $name;
+ my ( $test_name, $test_path ) = fileparse($test_file);
+ return $test_file if ( $test_name eq $name );
+ return if ( $OSNAME eq 'VMS' );
+
+ # this should work at least for Windows and Unix:
+ $test_file = $path . '/' . $name;
+ ( $test_name, $test_path ) = fileparse($test_file);
+ return $test_file if ( $test_name eq $name );
+ return;
+ } ## end sub catfile
+} ## end closure for sub catfile
# Here is a map of the flow of data from the input source to the output
# line sink:
# messages. It writes a .LOG file, which may be saved with a
# '-log' or a '-g' flag.
+{ #<<<
+
+my $Warn_count;
+my $fh_stderr;
+
+# Bump Warn_count only: it is essential to bump the count on all warnings, even
+# if no message goes out, so that the correct exit status is set.
+sub Warn_count_bump { $Warn_count++; return }
+
+# Output Warn message only
+sub Warn_msg { my $msg = shift; $fh_stderr->print($msg); return }
+
+# Output Warn message and bump Warn count
+sub Warn { my $msg = shift; $fh_stderr->print($msg); $Warn_count++; return }
+
+sub is_char_mode {
+
+ my ($string) = @_;
+
+ # Returns:
+ # true if $string is in Perl's internal character mode
+ # (also called the 'upgraded form', or UTF8=1)
+ # false if $string is in Perl's internal byte mode
+
+ # This function isolates the call to Perl's internal function
+ # utf8::is_utf8() which is true for strings represented in an 'upgraded
+ # form'. It is available after Perl version 5.8.
+ # See https://perldoc.perl.org/Encode.
+ # See also comments in Carp.pm and other modules using this function
+
+ return 1 if ( utf8::is_utf8($string) );
+ return;
+} ## end sub is_char_mode
+
sub perltidy {
my %input_hash = @_;
formatter => undef,
logfile => undef,
errorfile => undef,
+ teefile => undef,
+ debugfile => undef,
perltidyrc => undef,
source => undef,
stderr => undef,
postfilter => undef,
);
+ # Status information which can be returned for diagnostic purposes.
+ # This is intended for testing and subject to change.
+
+ # List of "key => value" hash entries:
+
+ # Some relevant user input parameters for convenience:
+ # opt_format => value of --format: 'tidy', 'html', or 'user'
+ # opt_encoding => value of -enc flag: 'utf8', 'none', or 'guess'
+ # opt_encode_output => value of -eos flag: 'eos' or 'neos'
+ # opt_max_iterations => value of --iterations=n
+
+ # file_count => number of files processed in this call
+
+ # If multiple files are processed, then the following values will be for
+ # the last file only:
+
+ # input_name => name of the input stream
+ # output_name => name of the output stream
+
+ # The following two variables refer to Perl's two internal string modes,
+ # and have the values 0 for 'byte' mode and 1 for 'char' mode:
+ # char_mode_source => true if source is in 'char' mode. Will be false
+ # unless we received a source string ref with utf8::is_utf8() set.
+ # char_mode_used => true if text processed by perltidy in 'char' mode.
+ # Normally true for text identified as utf8, otherwise false.
+
+ # This tells if Unicode::GCString was used
+ # gcs_used => true if -gcs and Unicode::GCString found & used
+
+ # These variables tell what utf8 decoding/encoding was done:
+ # input_decoded_as => non-blank if perltidy decoded the source text
+ # output_encoded_as => non-blank if perltidy encoded before return
+
+ # These variables are related to iterations and convergence testing:
+ # iteration_count => number of iterations done
+ # ( can be from 1 to opt_max_iterations )
+ # converged => true if stopped on convergence
+ # ( can only happen if opt_max_iterations > 1 )
+ # blinking => true if stopped on blinking states
+ # ( i.e., unstable formatting, should not happen )
+
+ my $rstatus = {
+
+ file_count => 0,
+ opt_format => EMPTY_STRING,
+ opt_encoding => EMPTY_STRING,
+ opt_encode_output => EMPTY_STRING,
+ opt_max_iterations => EMPTY_STRING,
+
+ input_name => EMPTY_STRING,
+ output_name => EMPTY_STRING,
+ char_mode_source => 0,
+ char_mode_used => 0,
+ input_decoded_as => EMPTY_STRING,
+ output_encoded_as => EMPTY_STRING,
+ gcs_used => 0,
+ iteration_count => 0,
+ converged => 0,
+ blinking => 0,
+ };
+
+ # Fix for issue git #57
+ $Warn_count = 0;
+
# don't overwrite callers ARGV
local @ARGV = @ARGV;
local *STDERR = *STDERR;
if ( my @bad_keys = grep { !exists $defaults{$_} } keys %input_hash ) {
- local $" = ')(';
+ local $LIST_SEPARATOR = ')(';
my @good_keys = sort keys %defaults;
@bad_keys = sort @bad_keys;
confess <<EOM;
my $destination_stream = $input_hash{'destination'};
my $errorfile_stream = $input_hash{'errorfile'};
my $logfile_stream = $input_hash{'logfile'};
+ my $teefile_stream = $input_hash{'teefile'};
+ my $debugfile_stream = $input_hash{'debugfile'};
my $perltidyrc_stream = $input_hash{'perltidyrc'};
my $source_stream = $input_hash{'source'};
my $stderr_stream = $input_hash{'stderr'};
$fh_stderr = *STDERR;
}
- sub Warn { my $msg = shift; $fh_stderr->print($msg); return }
-
sub Exit {
my $flag = shift;
if ($flag) { goto ERROR_EXIT }
croak "unexpected return to Die";
}
+ my $md5_hex = sub {
+ my ($buf) = @_;
+
+ # Evaluate the MD5 sum for a string
+ # Patch for [rt.cpan.org #88020]
+ # Use utf8::encode since md5_hex() only operates on bytes.
+ # my $digest = md5_hex( utf8::encode($sink_buffer) );
+
+ # Note added 20180114: the above patch did not work correctly. I'm not
+ # sure why. But switching to the method recommended in the Perl 5
+ # documentation for Encode worked. According to this we can either use
+ # $octets = encode_utf8($string) or equivalently
+ # $octets = encode("utf8",$string)
+ # and then calculate the checksum. So:
+ my $octets = Encode::encode( "utf8", $buf );
+ my $digest = md5_hex($octets);
+ return $digest;
+ };
+
# extract various dump parameters
my $dump_options_type = $input_hash{'dump_options_type'};
my $dump_options = $get_hash_ref->('dump_options');
unless ( defined($dump_options_type) ) {
$dump_options_type = 'perltidyrc';
}
- unless ( $dump_options_type =~ /^(perltidyrc|full)$/ ) {
+ if ( $dump_options_type ne 'perltidyrc'
+ && $dump_options_type ne 'full' )
+ {
croak <<EOM;
------------------------------------------------------------------------
Please check value of -dump_options_type in call to perltidy;
}
}
else {
- $dump_options_type = "";
+ $dump_options_type = EMPTY_STRING;
}
if ($user_formatter) {
# string
else {
- my ( $rargv, $msg ) = parse_args($argv);
+ my ( $rargv_str, $msg ) = parse_args($argv);
if ($msg) {
Die(<<EOM);
Error parsing this string passed to to perltidy with 'argv':
$msg
EOM
}
- @ARGV = @{$rargv};
+ @ARGV = @{$rargv_str};
}
}
my $rpending_complaint;
- ${$rpending_complaint} = "";
+ ${$rpending_complaint} = EMPTY_STRING;
my $rpending_logfile_message;
- ${$rpending_logfile_message} = "";
+ ${$rpending_logfile_message} = EMPTY_STRING;
my ( $is_Windows, $Windows_type ) = look_for_Windows($rpending_complaint);
# instead of .tdy, etc. (but see also sub check_vms_filename)
my $dot;
my $dot_pattern;
- if ( $^O eq 'VMS' ) {
+ if ( $OSNAME eq 'VMS' ) {
$dot = '_';
$dot_pattern = '_';
}
$rpending_complaint, $dump_options_type,
);
- my $saw_extrude = ( grep { m/^-extrude$/ } @{$rraw_options} ) ? 1 : 0;
my $saw_pbp =
- ( grep { m/^-(pbp|perl-best-practices)$/ } @{$rraw_options} ) ? 1 : 0;
+ grep { $_ eq '-pbp' || $_ eq '-perl-best-practices' } @{$rraw_options};
#---------------------------------------------------------------
# Handle requests to dump information
$quit_now = 1;
foreach my $op ( @{$roption_string} ) {
my $opt = $op;
- my $flag = "";
+ my $flag = EMPTY_STRING;
# Examples:
# some-option=s
my %default_file_extension = (
tidy => 'tdy',
html => 'html',
- user => '',
+ user => EMPTY_STRING,
);
- $rOpts_character_encoding = $rOpts->{'character-encoding'};
+ $rstatus->{'opt_format'} = $rOpts->{'format'};
+ $rstatus->{'opt_max_iterations'} = $rOpts->{'iterations'};
+ $rstatus->{'opt_encode_output'} =
+ $rOpts->{'encode-output-strings'} ? 'eos' : 'neos';
# be sure we have a valid output format
unless ( exists $default_file_extension{ $rOpts->{'format'} } ) {
- my $formats = join ' ',
+ my $formats = join SPACE,
sort map { "'" . $_ . "'" } keys %default_file_extension;
my $fmt = $rOpts->{'format'};
Die("-format='$fmt' but must be one of: $formats\n");
}
}
+ # Turn off assert-tidy and assert-untidy unless we are tidying files
+ if ( $rOpts->{'format'} ne 'tidy' ) {
+ if ( $rOpts->{'assert-tidy'} ) {
+ $rOpts->{'assert-tidy'} = 0;
+ Warn("ignoring --assert-tidy, --format is not 'tidy'\n");
+ }
+ if ( $rOpts->{'assert-untidy'} ) {
+ $rOpts->{'assert-untidy'} = 0;
+ Warn("ignoring --assert-untidy, --format is not 'tidy'\n");
+ }
+ }
+
Perl::Tidy::Formatter::check_options($rOpts);
+ Perl::Tidy::Tokenizer::check_options($rOpts);
+ Perl::Tidy::VerticalAligner::check_options($rOpts);
if ( $rOpts->{'format'} eq 'html' ) {
Perl::Tidy::HtmlWriter->check_options($rOpts);
}
unshift( @ARGV, '-' ) unless @ARGV;
}
+ # Flag for loading module Unicode::GCString for evaluating text width:
+ # undef = ok to use but not yet loaded
+ # 0 = do not use; failed to load or not wanted
+ # 1 = successfully loaded and ok to use
+ # The module is not actually loaded unless/until it is needed
+ my $loaded_unicode_gcstring;
+ if ( !$rOpts->{'use-unicode-gcstring'} ) {
+ $loaded_unicode_gcstring = 0;
+ }
+
#---------------------------------------------------------------
# Ready to go...
# main loop to process all files in argument list
#---------------------------------------------------------------
- my $number_of_files = @ARGV;
- my $formatter = undef;
- my $tokenizer = undef;
+ my $formatter = undef;
+ my $tokenizer = undef;
+
+ # Remove duplicate filenames. Otherwise, for example if the user entered
+ # perltidy -b myfile.pl myfile.pl
+ # the backup version of the original would be lost.
+ if ( @ARGV > 1 ) {
+ my %seen = ();
+ @ARGV = grep { !$seen{$_}++ } @ARGV;
+ }
# If requested, process in order of increasing file size
# This can significantly reduce perl's virtual memory usage during testing.
- if ( $number_of_files > 1 && $rOpts->{'file-size-order'} ) {
+ if ( @ARGV > 1 && $rOpts->{'file-size-order'} ) {
@ARGV =
map { $_->[0] }
sort { $a->[1] <=> $b->[1] }
map { [ $_, -e $_ ? -s $_ : 0 ] } @ARGV;
}
+ my $number_of_files = @ARGV;
while ( my $input_file = shift @ARGV ) {
my $fileroot;
my @input_file_stat;
+ my $display_name;
#---------------------------------------------------------------
# prepare this input stream
#---------------------------------------------------------------
if ($source_stream) {
- $fileroot = "perltidy";
+ $fileroot = "perltidy";
+ $display_name = "<source_stream>";
# If the source is from an array or string, then .LOG output
# is only possible if a logfile stream is specified. This prevents
# unexpected perltidy.LOG files.
if ( !defined($logfile_stream) ) {
$logfile_stream = Perl::Tidy::DevNull->new();
+
+ # Likewise for .TEE and .DEBUG output
+ }
+ if ( !defined($teefile_stream) ) {
+ $teefile_stream = Perl::Tidy::DevNull->new();
+ }
+ if ( !defined($debugfile_stream) ) {
+ $debugfile_stream = Perl::Tidy::DevNull->new();
}
}
elsif ( $input_file eq '-' ) { # '-' indicates input from STDIN
- $fileroot = "perltidy"; # root name to use for .ERR, .LOG, etc
+ $fileroot = "perltidy"; # root name to use for .ERR, .LOG, etc
+ $display_name = "<stdin>";
$in_place_modify = 0;
}
else {
- $fileroot = $input_file;
+ $fileroot = $input_file;
+ $display_name = $input_file;
unless ( -e $input_file ) {
# file doesn't exist - check for a file glob
if ( $input_file =~ /^\'(.+)\'$/ ) { $input_file = $1 }
if ( $input_file =~ /^\"(.+)\"$/ ) { $input_file = $1 }
my $pattern = fileglob_to_re($input_file);
- ##eval "/$pattern/";
- if ( !$@ && opendir( DIR, './' ) ) {
+ my $dh;
+ if ( opendir( $dh, './' ) ) {
my @files =
- grep { /$pattern/ && !-d $_ } readdir(DIR);
- closedir(DIR);
+ grep { /$pattern/ && !-d } readdir($dh);
+ ##grep { /$pattern/ && !-d $_ } readdir($dh);
+ closedir($dh);
if (@files) {
unshift @ARGV, @files;
next;
next;
}
+ # And avoid formatting extremely large files. Since perltidy reads
+ # files into memory, trying to process an extremely large file
+ # could cause system problems.
+ my $size_in_mb = ( -s $input_file ) / ( 1024 * 1024 );
+ if ( $size_in_mb > $rOpts->{'maximum-file-size-mb'} ) {
+ $size_in_mb = sprintf( "%0.1f", $size_in_mb );
+ Warn(
+"skipping file: $input_file: size $size_in_mb MB exceeds limit $rOpts->{'maximum-file-size-mb'}; use -mfs=i to change\n"
+ );
+ next;
+ }
+
unless ( ( -T $input_file ) || $rOpts->{'force-read-binary'} ) {
Warn(
"skipping file: $input_file: Non-text (override with -f)\n"
$fileroot = $input_file;
@input_file_stat = stat($input_file);
- if ( $^O eq 'VMS' ) {
+ if ( $OSNAME eq 'VMS' ) {
( $fileroot, $dot ) = check_vms_filename($fileroot);
}
my $new_path = $rOpts->{'output-path'};
unless ( -d $new_path ) {
unless ( mkdir $new_path, 0777 ) {
- Die("unable to create directory $new_path: $!\n");
+ Die("unable to create directory $new_path: $ERRNO\n");
}
}
my $path = $new_path;
# rerun perltidy over and over with wildcard input.
if (
!$source_stream
- && ( $input_file =~ /$forbidden_file_extensions/o
+ && ( $input_file =~ /$forbidden_file_extensions/
|| $input_file eq 'DIAGNOSTICS' )
)
{
}
# the 'source_object' supplies a method to read the input file
- my $source_object =
- Perl::Tidy::LineSource->new( $input_file, $rOpts,
- $rpending_logfile_message );
+ my $source_object = Perl::Tidy::LineSource->new(
+ input_file => $input_file,
+ rOpts => $rOpts,
+ rpending_logfile_message => $rpending_logfile_message,
+ );
next unless ($source_object);
- # Prefilters and postfilters: The prefilter is a code reference
- # that will be applied to the source before tidying, and the
- # postfilter is a code reference to the result before outputting.
- if (
- $prefilter
- || ( $rOpts_character_encoding
- && $rOpts_character_encoding eq 'utf8' )
- )
+ my $max_iterations = $rOpts->{'iterations'};
+ my $do_convergence_test = $max_iterations > 1;
+ my $convergence_log_message;
+ my %saw_md5;
+ my $digest_input = 0;
+
+ my $buf = EMPTY_STRING;
+ while ( my $line = $source_object->get_line() ) {
+ $buf .= $line;
+ }
+
+ my $remove_terminal_newline =
+ !$rOpts->{'add-terminal-newline'} && substr( $buf, -1, 1 ) !~ /\n/;
+
+ # Decode the input stream if necessary or requested
+ my $encoding_in = EMPTY_STRING;
+ my $rOpts_character_encoding = $rOpts->{'character-encoding'};
+ my $encoding_log_message;
+ my $decoded_input_as = EMPTY_STRING;
+ $rstatus->{'char_mode_source'} = 0;
+
+ # Case 1: If Perl is already in a character-oriented mode for this
+ # string rather than a byte-oriented mode. Normally, this happens if
+ # the caller has decoded a utf8 string before calling perltidy. But it
+ # could also happen if the user has done some unusual manipulations of
+ # the source. In any case, we will not attempt to decode it because
+ # that could result in an output string in a different mode.
+ if ( is_char_mode($buf) ) {
+ $encoding_in = "utf8";
+ $rstatus->{'char_mode_source'} = 1;
+ }
+
+ # Case 2. No input stream encoding requested. This is appropriate
+ # for single-byte encodings like ascii, latin-1, etc
+ elsif ( !$rOpts_character_encoding
+ || $rOpts_character_encoding eq 'none' )
{
- my $buf = '';
- while ( my $line = $source_object->get_line() ) {
- $buf .= $line;
+
+ # nothing to do
+ }
+
+ # Case 3. guess input stream encoding if requested
+ elsif ( lc($rOpts_character_encoding) eq 'guess' ) {
+
+ # The guessing strategy is simple: use Encode::Guess to guess
+ # an encoding. If and only if the guess is utf8, try decoding and
+ # use it if successful. Otherwise, we proceed assuming the
+ # characters are encoded as single bytes (same as if 'none' had
+ # been specified as the encoding).
+
+ # In testing I have found that including additional guess 'suspect'
+ # encodings sometimes works but can sometimes lead to disaster by
+ # using an incorrect decoding. The user can always specify a
+ # specific input encoding.
+ my $buf_in = $buf;
+
+ my $decoder = guess_encoding( $buf_in, 'utf8' );
+ if ( ref($decoder) ) {
+ $encoding_in = $decoder->name;
+ if ( $encoding_in ne 'UTF-8' && $encoding_in ne 'utf8' ) {
+ $encoding_in = EMPTY_STRING;
+ $buf = $buf_in;
+ $encoding_log_message .= <<EOM;
+Guessed encoding '$encoding_in' is not utf8; no encoding will be used
+EOM
+ }
+ else {
+
+ eval { $buf = $decoder->decode($buf_in); };
+ if ($EVAL_ERROR) {
+
+ $encoding_log_message .= <<EOM;
+Guessed encoding '$encoding_in' but decoding was unsuccessful; no encoding is used
+EOM
+
+ # Note that a guess failed, but keep going
+ # This warning can eventually be removed
+ Warn(
+"file: $input_file: bad guess to decode source as $encoding_in\n"
+ );
+ $encoding_in = EMPTY_STRING;
+ $buf = $buf_in;
+ }
+ else {
+ $encoding_log_message .= <<EOM;
+Guessed encoding '$encoding_in' successfully decoded
+EOM
+ $decoded_input_as = $encoding_in;
+ }
+ }
}
+ else {
+ $encoding_log_message .= <<EOM;
+Does not look like utf8 encoded text so processing as raw bytes
+EOM
+ }
+ }
- $buf = $prefilter->($buf) if $prefilter;
+ # Case 4. Decode with a specific encoding
+ else {
+ $encoding_in = $rOpts_character_encoding;
+ eval {
+ $buf = Encode::decode( $encoding_in, $buf,
+ Encode::FB_CROAK | Encode::LEAVE_SRC );
+ };
+ if ($EVAL_ERROR) {
+
+ # Quit if we cannot decode by the requested encoding;
+ # Something is not right.
+ Warn(
+"skipping file: $display_name: Unable to decode source as $encoding_in\n"
+ );
+ next;
+ }
+ else {
+ $encoding_log_message .= <<EOM;
+Specified encoding '$encoding_in' successfully decoded
+EOM
+ $decoded_input_as = $encoding_in;
+ }
+ }
- if ( $rOpts_character_encoding
- && $rOpts_character_encoding eq 'utf8'
- && !utf8::is_utf8($buf) )
- {
- eval {
- $buf = Encode::decode( 'UTF-8', $buf,
- Encode::FB_CROAK | Encode::LEAVE_SRC );
- };
- if ($@) {
- Warn(
-"skipping file: $input_file: Unable to decode source as UTF-8\n"
- );
- next;
+ # Set the encoding to be used for all further i/o: If we have
+ # decoded the data with any format, then we must continue to
+ # read and write it as encoded data, and we will normalize these
+ # operations with utf8. If we have not decoded the data, then
+ # we must not treat it as encoded data.
+ my $is_encoded_data = $encoding_in ? 'utf8' : EMPTY_STRING;
+
+ $rstatus->{'input_name'} = $display_name;
+ $rstatus->{'opt_encoding'} = $rOpts_character_encoding;
+ $rstatus->{'char_mode_used'} = $encoding_in ? 1 : 0;
+ $rstatus->{'input_decoded_as'} = $decoded_input_as;
+
+ # Define the function to determine the display width of character
+ # strings
+ my $length_function = sub { return length( $_[0] ) };
+ if ($is_encoded_data) {
+
+ # Delete any Byte Order Mark (BOM), which can cause trouble
+ $buf =~ s/^\x{FEFF}//;
+
+ # Try to load Unicode::GCString for defining text display width, if
+ # requested, when the first encoded file is encountered
+ if ( !defined($loaded_unicode_gcstring) ) {
+ eval { require Unicode::GCString };
+ $loaded_unicode_gcstring = !$EVAL_ERROR;
+ if ( $EVAL_ERROR && $rOpts->{'use-unicode-gcstring'} ) {
+ Warn(<<EOM);
+----------------------
+Unable to load Unicode::GCString: $EVAL_ERROR
+Processing continues but some vertical alignment may be poor
+To prevent this warning message, you can either:
+- install module Unicode::GCString, or
+- remove '--use-unicode-gcstring' or '-gcs' from your perltidyrc or command line
+----------------------
+EOM
}
}
+ if ($loaded_unicode_gcstring) {
+ $length_function = sub {
+ return Unicode::GCString->new( $_[0] )->columns;
+ };
+ $encoding_log_message .= <<EOM;
+Using 'Unicode::GCString' to measure horizontal character widths
+EOM
+ $rstatus->{'gcs_used'} = 1;
+ }
+ }
- $source_object = Perl::Tidy::LineSource->new( \$buf, $rOpts,
- $rpending_logfile_message );
+ # MD5 sum of input file is evaluated before any prefilter
+ my $saved_input_buf;
+ if ( $rOpts->{'assert-tidy'} || $rOpts->{'assert-untidy'} ) {
+ $digest_input = $md5_hex->($buf);
+ $saved_input_buf = $buf;
}
+ # Prefilters and postfilters: The prefilter is a code reference
+ # that will be applied to the source before tidying, and the
+ # postfilter is a code reference to the result before outputting.
+
+ $buf = $prefilter->($buf) if $prefilter;
+
+ # starting MD5 sum for convergence test is evaluated after any prefilter
+ if ($do_convergence_test) {
+ my $digest = $md5_hex->($buf);
+ $saw_md5{$digest} = 0;
+ }
+
+ $source_object = Perl::Tidy::LineSource->new(
+ input_file => \$buf,
+ rOpts => $rOpts,
+ rpending_logfile_message => $rpending_logfile_message,
+ );
+
# register this file name with the Diagnostics package
$diagnostics_object->set_input_file($input_file)
if $diagnostics_object;
# prepare the output stream
#---------------------------------------------------------------
my $output_file = undef;
+ my $output_name = EMPTY_STRING;
my $actual_output_extension;
if ( $rOpts->{'outfile'} ) {
Die("You may not specify -o and -oext together\n");
}
$output_file = $rOpts->{outfile};
+ $output_name = $output_file;
# make sure user gives a file name after -o
if ( $output_file =~ /^-/ ) {
Die("$msg\n");
}
$output_file = '-';
+ $output_name = "<stdout>";
if ( $number_of_files <= 1 ) {
}
}
}
elsif ($destination_stream) {
+
$output_file = $destination_stream;
+ $output_name = "<destination_stream>";
}
elsif ($source_stream) { # source but no destination goes to stdout
$output_file = '-';
+ $output_name = "<stdout>";
}
elsif ( $input_file eq '-' ) {
$output_file = '-';
+ $output_name = "<stdout>";
}
else {
if ($in_place_modify) {
$output_file = IO::File->new_tmpfile()
- or Die("cannot open temp file for -b option: $!\n");
+ or Die("cannot open temp file for -b option: $ERRNO\n");
+ $output_name = $display_name;
}
else {
$actual_output_extension = $output_extension;
$output_file = $fileroot . $output_extension;
+ $output_name = $output_file;
}
}
- # the 'sink_object' knows how to write the output file
+ $rstatus->{'file_count'} += 1;
+ $rstatus->{'output_name'} = $output_name;
+ $rstatus->{'iteration_count'} = 0;
+ $rstatus->{'converged'} = 0;
+
+ my $fh_tee;
my $tee_file = $fileroot . $dot . "TEE";
+ if ($teefile_stream) { $tee_file = $teefile_stream }
+ if ( $rOpts->{'tee-pod'}
+ || $rOpts->{'tee-block-comments'}
+ || $rOpts->{'tee-side-comments'} )
+ {
+ ( $fh_tee, my $tee_filename ) =
+ Perl::Tidy::streamhandle( $tee_file, 'w', $is_encoded_data );
+ if ( !$fh_tee ) {
+ Warn("couldn't open TEE file $tee_file: $ERRNO\n");
+ }
+ }
my $line_separator = $rOpts->{'output-line-ending'};
if ( $rOpts->{'preserve-line-endings'} ) {
$line_separator = find_input_line_ending($input_file);
}
- # Eventually all I/O may be done with binmode, but for now it is
- # only done when a user requests a particular line separator
- # through the -ple or -ole flags
- my $binmode = defined($line_separator)
- || defined($rOpts_character_encoding);
$line_separator = "\n" unless defined($line_separator);
+ # the 'sink_object' knows how to write the output file
my ( $sink_object, $postfilter_buffer );
- if ($postfilter) {
- $sink_object =
- Perl::Tidy::LineSink->new( \$postfilter_buffer, $tee_file,
- $line_separator, $rOpts, $rpending_logfile_message, $binmode );
- }
- else {
- $sink_object =
- Perl::Tidy::LineSink->new( $output_file, $tee_file,
- $line_separator, $rOpts, $rpending_logfile_message, $binmode );
+ my $use_buffer =
+ $postfilter
+ || $remove_terminal_newline
+ || $rOpts->{'assert-tidy'}
+ || $rOpts->{'assert-untidy'};
+
+ # Postpone final output to a destination SCALAR or ARRAY ref to allow
+ # possible encoding at the end of processing.
+ my $destination_buffer;
+ my $use_destination_buffer;
+ my $encode_destination_buffer;
+ my $ref_destination_stream = ref($destination_stream);
+ if ( $ref_destination_stream && !$user_formatter ) {
+ $use_destination_buffer = 1;
+ $output_file = \$destination_buffer;
+
+ # Strings and arrays use special encoding rules
+ if ( $ref_destination_stream eq 'SCALAR'
+ || $ref_destination_stream eq 'ARRAY' )
+ {
+ $encode_destination_buffer =
+ $rOpts->{'encode-output-strings'} && $decoded_input_as;
+ }
+
+ # An object with a print method will use file encoding rules
+ elsif ( $ref_destination_stream->can('print') ) {
+ $encode_destination_buffer = $is_encoded_data;
+ }
+ else {
+ confess <<EOM;
+------------------------------------------------------------------------
+No 'print' method is defined for object of class '$ref_destination_stream'
+Please check your call to Perl::Tidy::perltidy. Trace follows.
+------------------------------------------------------------------------
+EOM
+ }
}
+ $sink_object = Perl::Tidy::LineSink->new(
+ output_file => $use_buffer ? \$postfilter_buffer : $output_file,
+ line_separator => $line_separator,
+ rOpts => $rOpts,
+ rpending_logfile_message => $rpending_logfile_message,
+ is_encoded_data => $is_encoded_data,
+ );
+
#---------------------------------------------------------------
# initialize the error logger for this file
#---------------------------------------------------------------
my $log_file = $fileroot . $dot . "LOG";
if ($logfile_stream) { $log_file = $logfile_stream }
- my $logger_object =
- Perl::Tidy::Logger->new( $rOpts, $log_file, $warning_file,
- $fh_stderr, $saw_extrude );
+ my $logger_object = Perl::Tidy::Logger->new(
+ rOpts => $rOpts,
+ log_file => $log_file,
+ warning_file => $warning_file,
+ fh_stderr => $fh_stderr,
+ display_name => $display_name,
+ is_encoded_data => $is_encoded_data,
+ );
write_logfile_header(
$rOpts, $logger_object, $config_file,
$rraw_options, $Windows_type, $readable_options,
);
+ $logger_object->write_logfile_entry($encoding_log_message)
+ if $encoding_log_message;
+
if ( ${$rpending_logfile_message} ) {
$logger_object->write_logfile_entry( ${$rpending_logfile_message} );
}
#---------------------------------------------------------------
my $debugger_object = undef;
if ( $rOpts->{DEBUG} ) {
+ my $debug_file = $fileroot . $dot . "DEBUG";
+ if ($debugfile_stream) { $debug_file = $debugfile_stream }
$debugger_object =
- Perl::Tidy::Debugger->new( $fileroot . $dot . "DEBUG" );
+ Perl::Tidy::Debugger->new( $debug_file, $is_encoded_data );
}
#---------------------------------------------------------------
# loop over iterations for one source stream
#---------------------------------------------------------------
- # We will do a convergence test if 3 or more iterations are allowed.
- # It would be pointless for fewer because we have to make at least
- # two passes before we can see if we are converged, and the test
- # would just slow things down.
- my $max_iterations = $rOpts->{'iterations'};
- my $convergence_log_message;
- my %saw_md5;
- my $do_convergence_test = $max_iterations > 2;
-
- # Since Digest::MD5 qw(md5_hex) has been in the earliest version of Perl
- # we are requiring (5.8), I have commented out this check
-##? if ($do_convergence_test) {
-##? eval "use Digest::MD5 qw(md5_hex)";
-##? $do_convergence_test = !$@;
-##?
-##? ### Trying to avoid problems with ancient versions of perl
-##? ##eval { my $string = "perltidy"; utf8::encode($string) };
-##? ##$do_convergence_test = $do_convergence_test && !$@;
-##? }
-
# save objects to allow redirecting output during iterations
my $sink_object_final = $sink_object;
my $debugger_object_final = $debugger_object;
my $logger_object_final = $logger_object;
+ my $fh_tee_final = $fh_tee;
+ my $iteration_of_formatter_convergence;
foreach my $iter ( 1 .. $max_iterations ) {
+ $rstatus->{'iteration_count'} += 1;
+
# send output stream to temp buffers until last iteration
my $sink_buffer;
if ( $iter < $max_iterations ) {
- $sink_object =
- Perl::Tidy::LineSink->new( \$sink_buffer, $tee_file,
- $line_separator, $rOpts, $rpending_logfile_message,
- $binmode );
+ $sink_object = Perl::Tidy::LineSink->new(
+ output_file => \$sink_buffer,
+ line_separator => $line_separator,
+ rOpts => $rOpts,
+ rpending_logfile_message => $rpending_logfile_message,
+ is_encoded_data => $is_encoded_data,
+ );
}
else {
$sink_object = $sink_object_final;
}
- # Save logger, debugger output only on pass 1 because:
+ # Save logger, debugger and tee output only on pass 1 because:
# (1) line number references must be to the starting
# source, not an intermediate result, and
# (2) we need to know if there are errors so we can stop the
# iterations early if necessary.
+ # (3) the tee option only works on first pass if comments are also
+ # being deleted.
+
if ( $iter > 1 ) {
$debugger_object = undef;
$logger_object = undef;
+ $fh_tee = undef;
}
#------------------------------------------------------------
$formatter = $user_formatter;
}
elsif ( $rOpts->{'format'} eq 'html' ) {
- $formatter =
- Perl::Tidy::HtmlWriter->new( $fileroot, $output_file,
- $actual_output_extension, $html_toc_extension,
- $html_src_extension );
+ $formatter = Perl::Tidy::HtmlWriter->new(
+ input_file => $fileroot,
+ html_file => $output_file,
+ extension => $actual_output_extension,
+ html_toc_extension => $html_toc_extension,
+ html_src_extension => $html_src_extension,
+ );
}
elsif ( $rOpts->{'format'} eq 'tidy' ) {
$formatter = Perl::Tidy::Formatter->new(
logger_object => $logger_object,
diagnostics_object => $diagnostics_object,
sink_object => $sink_object,
+ length_function => $length_function,
+ is_encoded_data => $is_encoded_data,
+ fh_tee => $fh_tee,
);
}
else {
debugger_object => $debugger_object,
diagnostics_object => $diagnostics_object,
tabsize => $tabsize,
+ rOpts => $rOpts,
starting_level => $rOpts->{'starting-indentation-level'},
indent_columns => $rOpts->{'indent-columns'},
#---------------------------------------------------------------
$source_object->close_input_file();
+ # see if the formatter is converged
+ if ( $max_iterations > 1
+ && !defined($iteration_of_formatter_convergence)
+ && $formatter->can('get_convergence_check') )
+ {
+ if ( $formatter->get_convergence_check() ) {
+ $iteration_of_formatter_convergence = $iter;
+ $rstatus->{'converged'} = 1;
+ }
+ }
+
# line source for next iteration (if any) comes from the current
# temporary output buffer
if ( $iter < $max_iterations ) {
$sink_object->close_output_file();
- $source_object =
- Perl::Tidy::LineSource->new( \$sink_buffer, $rOpts,
- $rpending_logfile_message );
+ $source_object = Perl::Tidy::LineSource->new(
+ input_file => \$sink_buffer,
+ rOpts => $rOpts,
+ rpending_logfile_message => $rpending_logfile_message,
+ );
# stop iterations if errors or converged
- #my $stop_now = $logger_object->{_warning_count};
my $stop_now = $tokenizer->report_tokenization_errors();
+ $stop_now ||= $tokenizer->get_unexpected_error_count();
+ my $stopping_on_error = $stop_now;
if ($stop_now) {
$convergence_log_message = <<EOM;
Stopping iterations because of severe errors.
}
elsif ($do_convergence_test) {
- # Patch for [rt.cpan.org #88020]
- # Use utf8::encode since md5_hex() only operates on bytes.
- # my $digest = md5_hex( utf8::encode($sink_buffer) );
-
- # Note added 20180114: this patch did not work correctly.
- # I'm not sure why. But switching to the method
- # recommended in the Perl 5 documentation for Encode
- # worked. According to this we can either use
- # $octets = encode_utf8($string) or equivalently
- # $octets = encode("utf8",$string)
- # and then calculate the checksum. So:
- my $octets = Encode::encode( "utf8", $sink_buffer );
- my $digest = md5_hex($octets);
- if ( !$saw_md5{$digest} ) {
+ # stop if the formatter has converged
+ $stop_now ||= defined($iteration_of_formatter_convergence);
+
+ my $digest = $md5_hex->($sink_buffer);
+ if ( !defined( $saw_md5{$digest} ) ) {
$saw_md5{$digest} = $iter;
}
else {
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.
+ # Blinking (oscillating) between two or more stable
+ # end states. This is unlikely to occur with normal
+ # parameters, but it can occur in stress testing
+ # with extreme parameter values, such as very short
+ # maximum line lengths. We want to catch and fix
+ # them when they happen.
+ $rstatus->{'blinking'} = 1;
$convergence_log_message = <<EOM;
-Blinking. Output for iteration $iter same as for $saw_md5{$digest}.
+BLINKER. Output for iteration $iter same as for $saw_md5{$digest}.
EOM
+ $stopping_on_error ||= $convergence_log_message;
+ if (DEVEL_MODE) {
+ print STDERR $convergence_log_message;
+ }
$diagnostics_object->write_diagnostics(
$convergence_log_message)
if $diagnostics_object;
+
+# Uncomment to search for blinking states
+# Warn( "$display_name: blinking; iter $iter same as for $saw_md5{$digest}\n" );
+
}
else {
$convergence_log_message = <<EOM;
$diagnostics_object->write_diagnostics(
$convergence_log_message)
if $diagnostics_object && $iterm > 2;
+ $rstatus->{'converged'} = 1;
}
}
} ## end if ($do_convergence_test)
if ($stop_now) {
+ if (DEVEL_MODE) {
+
+ if ( defined($iteration_of_formatter_convergence) ) {
+
+ # This message cannot appear unless the formatter
+ # convergence test above is temporarily skipped for
+ # testing.
+ if ( $iteration_of_formatter_convergence <
+ $iter - 1 )
+ {
+ print STDERR
+"STRANGE Early conv in $display_name: Stopping on it=$iter, converged in formatter on $iteration_of_formatter_convergence\n";
+ }
+ }
+ elsif ( !$stopping_on_error ) {
+ print STDERR
+"STRANGE no conv in $display_name: stopping on it=$iter, but not converged in formatter\n";
+ }
+ }
+
# we are stopping the iterations early;
# copy the output stream to its final destination
$sink_object = $sink_object_final;
last;
}
} ## end if ( $iter < $max_iterations)
- } # end loop over iterations for one source file
+ } ## end loop over iterations for one source file
# restore objects which have been temporarily undefined
# for second and higher iterations
$debugger_object = $debugger_object_final;
$logger_object = $logger_object_final;
+ $fh_tee = $fh_tee_final;
$logger_object->write_logfile_entry($convergence_log_message)
if $convergence_log_message;
#---------------------------------------------------------------
# Perform any postfilter operation
#---------------------------------------------------------------
- if ($postfilter) {
+ if ($use_buffer) {
$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 );
- while ( my $line = $source_object->get_line() ) {
- $sink_object->write_line($line);
+ $sink_object = Perl::Tidy::LineSink->new(
+ output_file => $output_file,
+ line_separator => $line_separator,
+ rOpts => $rOpts,
+ rpending_logfile_message => $rpending_logfile_message,
+ is_encoded_data => $is_encoded_data,
+ );
+
+ my $buf_post =
+ $postfilter
+ ? $postfilter->($postfilter_buffer)
+ : $postfilter_buffer;
+
+ # Check if file changed if requested, but only after any postfilter
+ if ( $rOpts->{'assert-tidy'} ) {
+ my $digest_output = $md5_hex->($buf_post);
+ if ( $digest_output ne $digest_input ) {
+ my $diff_msg =
+ compare_string_buffers( $saved_input_buf, $buf_post,
+ $is_encoded_data );
+ $logger_object->warning(<<EOM);
+assertion failure: '--assert-tidy' is set but output differs from input
+EOM
+ $logger_object->interrupt_logfile();
+ $logger_object->warning( $diff_msg . "\n" );
+ $logger_object->resume_logfile();
+ ## $Warn_count ||= 1; # logger warning does this now
+ }
+ }
+ if ( $rOpts->{'assert-untidy'} ) {
+ my $digest_output = $md5_hex->($buf_post);
+ if ( $digest_output eq $digest_input ) {
+ $logger_object->warning(
+"assertion failure: '--assert-untidy' is set but output equals input\n"
+ );
+ ## $Warn_count ||= 1; # logger warning does this now
+ }
}
+
+ $source_object = Perl::Tidy::LineSource->new(
+ input_file => \$buf_post,
+ rOpts => $rOpts,
+ rpending_logfile_message => $rpending_logfile_message,
+ );
+
+ # Copy the filtered buffer to the final destination
+ if ( !$remove_terminal_newline ) {
+ while ( my $line = $source_object->get_line() ) {
+ $sink_object->write_line($line);
+ }
+ }
+ else {
+
+ # Copy the filtered buffer but remove the newline char from the
+ # final line
+ my $line;
+ while ( my $next_line = $source_object->get_line() ) {
+ $sink_object->write_line($line) if ($line);
+ $line = $next_line;
+ }
+ if ($line) {
+ $sink_object->set_line_separator(undef);
+ chomp $line;
+ $sink_object->write_line($line);
+ }
+ }
+
$source_object->close_input_file();
}
- # Save names of the input and output files for syntax check
+ #------------------------------------------------------------------
+ # For string output, store the result to the destination, encoding
+ # if requested. This is a fix for issue git #83 (tidyall issue)
+ #------------------------------------------------------------------
+ if ($use_destination_buffer) {
+
+ # At this point, all necessary encoding has been done except for
+ # output to a string or array ref. We use the -eos flag to decide
+ # if we should encode.
+
+ # -neos, DEFAULT: perltidy does not return encoded string output.
+ # This is a result of the code evolution but not very convenient for
+ # most applications. It would be hard to change without breaking
+ # some programs.
+
+ # -eos flag set: If perltidy decodes a string, regardless of
+ # source, it encodes before returning.
+ $rstatus->{'output_encoded_as'} = EMPTY_STRING;
+
+ if ($encode_destination_buffer) {
+ my $encoded_buffer;
+ eval {
+ $encoded_buffer =
+ Encode::encode( "UTF-8", $destination_buffer,
+ Encode::FB_CROAK | Encode::LEAVE_SRC );
+ };
+ if ($EVAL_ERROR) {
+
+ Warn(
+"Error attempting to encode output string ref; encoding not done\n"
+ );
+ }
+ else {
+ $destination_buffer = $encoded_buffer;
+ $rstatus->{'output_encoded_as'} = 'UTF-8';
+ }
+ }
+
+ # Send data for SCALAR, ARRAY & OBJ refs to its final destination
+ if ( ref($destination_stream) eq 'SCALAR' ) {
+ ${$destination_stream} = $destination_buffer;
+ }
+ elsif ($destination_buffer) {
+ my @lines = split /^/, $destination_buffer;
+ if ( ref($destination_stream) eq 'ARRAY' ) {
+ @{$destination_stream} = @lines;
+ }
+
+ # destination stream must be an object with print method
+ else {
+ foreach my $line (@lines) {
+ $destination_stream->print($line);
+ }
+ if ( $ref_destination_stream->can('close') ) {
+ $destination_stream->close();
+ }
+ }
+ }
+ else {
+
+ # Empty destination buffer not going to a string ... could
+ # happen for example if user deleted all pod or comments
+ }
+ }
+ else {
+
+ # output went to a file ...
+ if ($is_encoded_data) {
+ $rstatus->{'output_encoded_as'} = 'UTF-8';
+ }
+ }
+
+ # Save names of the input and output files
my $ifname = $input_file;
my $ofname = $output_file;
if ( -f $backup_name ) {
unlink($backup_name)
or Die(
-"unable to remove previous '$backup_name' for -b option; check permissions: $!\n"
+"unable to remove previous '$backup_name' for -b option; check permissions: $ERRNO\n"
);
}
# we use copy for symlinks, move for regular files
if ( -l $input_file ) {
File::Copy::copy( $input_file, $backup_name )
- or Die("File::Copy failed trying to backup source: $!");
+ or Die("File::Copy failed trying to backup source: $ERRNO");
}
else {
rename( $input_file, $backup_name )
or Die(
-"problem renaming $input_file to $backup_name for -b option: $!\n"
+"problem renaming $input_file to $backup_name for -b option: $ERRNO\n"
);
}
$ifname = $backup_name;
# handle of an open nameless temporary file so we would lose
# everything if we closed it.
seek( $output_file, 0, 0 )
- or Die("unable to rewind a temporary file for -b option: $!\n");
- my $fout = IO::File->new("> $input_file")
- or Die(
-"problem re-opening $input_file for write for -b option; check file and directory permissions: $!\n"
- );
- if ($binmode) {
- if ( $rOpts->{'character-encoding'}
- && $rOpts->{'character-encoding'} eq 'utf8' )
- {
- binmode $fout, ":raw:encoding(UTF-8)";
- }
- else { binmode $fout }
+ or
+ Die("unable to rewind a temporary file for -b option: $ERRNO\n");
+
+ my ( $fout, $iname ) =
+ Perl::Tidy::streamhandle( $input_file, 'w', $is_encoded_data );
+ if ( !$fout ) {
+ Die(
+"problem re-opening $input_file for write for -b option; check file and directory permissions: $ERRNO\n"
+ );
}
+
my $line;
while ( $line = $output_file->getline() ) {
$fout->print($line);
#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
+ # 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 ) )
{
}
}
- #---------------------------------------------------------------
- # 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
if ( $in_place_modify
&& $delete_backup
&& -f $ifname
- && ( $delete_backup > 1 || !$logger_object->{_warning_count} ) )
+ && ( $delete_backup > 1 || !$logger_object->get_warning_count() ) )
{
# As an added safety precaution, do not delete the source file
else {
unlink($ifname)
or Die(
-"unable to remove previous '$ifname' for -b option; check permissions: $!\n"
+"unable to remove previous '$ifname' for -b option; check permissions: $ERRNO\n"
);
}
}
- $logger_object->finish( $infile_syntax_ok, $formatter )
+ $logger_object->finish($formatter)
if $logger_object;
- } # end of main loop to process all files
+ } ## end of main loop to process all files
+
+ # Fix for RT #130297: return a true value if anything was written to the
+ # standard error output, even non-fatal warning messages, otherwise return
+ # false.
+
+ # These exit codes are returned:
+ # 0 = perltidy ran to completion with no errors
+ # 1 = perltidy could not run to completion due to errors
+ # 2 = perltidy ran to completion with error messages
+
+ # Note that if perltidy is run with multiple files, any single file with
+ # errors or warnings will write a line like
+ # '## Please see file testing.t.ERR'
+ # to standard output for each file with errors, so the flag will be true,
+ # even if only some of the multiple files may have had errors.
NORMAL_EXIT:
- return 0;
+ my $ret = $Warn_count ? 2 : 0;
+ return wantarray ? ( $ret, $rstatus ) : $ret;
ERROR_EXIT:
- return 1;
-} # end of main program perltidy
+ return wantarray ? ( 1, $rstatus ) : 1;
+
+} ## end sub perltidy
+} ## end of closure for sub perltidy
+
+sub line_diff {
+
+ # Given two strings, return
+ # $diff_marker = a string with carat (^) symbols indicating differences
+ # $pos1 = character position of first difference; pos1=-1 if no difference
+
+ # Form exclusive or of the strings, which has null characters where strings
+ # have same common characters so non-null characters indicate character
+ # differences.
+ my ( $s1, $s2 ) = @_;
+ my $diff_marker = EMPTY_STRING;
+ my $pos = -1;
+ my $pos1 = $pos;
+ if ( defined($s1) && defined($s2) ) {
+ my $count = 0;
+ my $mask = $s1 ^ $s2;
+
+ while ( $mask =~ /[^\0]/g ) {
+ $count++;
+ my $pos_last = $pos;
+ $pos = $LAST_MATCH_START[0];
+ if ( $count == 1 ) { $pos1 = $pos; }
+ $diff_marker .= SPACE x ( $pos - $pos_last - 1 ) . '^';
+
+ # we could continue to mark all differences, but there is no point
+ last;
+ }
+ }
+ return wantarray ? ( $diff_marker, $pos1 ) : $diff_marker;
+} ## end sub line_diff
+
+sub compare_string_buffers {
+
+ # Compare input and output string buffers and return a brief text
+ # description of the first difference.
+ my ( $bufi, $bufo, $is_encoded_data ) = @_;
+
+ my $leni = length($bufi);
+ my $leno = defined($bufo) ? length($bufo) : 0;
+ my $msg =
+ "Input file length is $leni chars\nOutput file length is $leno chars\n";
+ return $msg unless $leni && $leno;
+
+ my ( $fhi, $fnamei ) = streamhandle( \$bufi, 'r', $is_encoded_data );
+ my ( $fho, $fnameo ) = streamhandle( \$bufo, 'r', $is_encoded_data );
+ return $msg unless ( $fho && $fhi ); # for safety, shouldn't happen
+ my ( $linei, $lineo );
+ my ( $counti, $counto ) = ( 0, 0 );
+ my ( $last_nonblank_line, $last_nonblank_count ) = ( EMPTY_STRING, 0 );
+ my $truncate = sub {
+ my ( $str, $lenmax ) = @_;
+ if ( length($str) > $lenmax ) {
+ $str = substr( $str, 0, $lenmax ) . "...";
+ }
+ return $str;
+ };
+ while (1) {
+ if ($linei) {
+ $last_nonblank_line = $linei;
+ $last_nonblank_count = $counti;
+ }
+ $linei = $fhi->getline();
+ $lineo = $fho->getline();
+
+ # compare chomp'ed lines
+ if ( defined($linei) ) { $counti++; chomp $linei }
+ if ( defined($lineo) ) { $counto++; chomp $lineo }
+
+ # see if one or both ended before a difference
+ last unless ( defined($linei) && defined($lineo) );
+
+ next if ( $linei eq $lineo );
+
+ # lines differ ...
+ my ( $line_diff, $pos1 ) = line_diff( $linei, $lineo );
+ my $reason = "Files first differ at character $pos1 of line $counti";
+
+ my ( $leading_ws_i, $leading_ws_o ) = ( EMPTY_STRING, EMPTY_STRING );
+ if ( $linei =~ /^(\s+)/ ) { $leading_ws_i = $1; }
+ if ( $lineo =~ /^(\s+)/ ) { $leading_ws_o = $1; }
+ if ( $leading_ws_i ne $leading_ws_o ) {
+ $reason .= "; leading whitespace differs";
+ if ( $leading_ws_i =~ /\t/ ) {
+ $reason .= "; input has tab char";
+ }
+ }
+ else {
+ my ( $trailing_ws_i, $trailing_ws_o ) =
+ ( EMPTY_STRING, EMPTY_STRING );
+ if ( $linei =~ /(\s+)$/ ) { $trailing_ws_i = $1; }
+ if ( $lineo =~ /(\s+)$/ ) { $trailing_ws_o = $1; }
+ if ( $trailing_ws_i ne $trailing_ws_o ) {
+ $reason .= "; trailing whitespace differs";
+ }
+ }
+ $msg .= $reason . "\n";
+
+ # limit string display length
+ if ( $pos1 > 60 ) {
+ my $drop = $pos1 - 40;
+ $linei = "..." . substr( $linei, $drop );
+ $lineo = "..." . substr( $lineo, $drop );
+ $line_diff = SPACE x 3 . substr( $line_diff, $drop );
+ }
+ $linei = $truncate->( $linei, 72 );
+ $lineo = $truncate->( $lineo, 72 );
+ $last_nonblank_line = $truncate->( $last_nonblank_line, 72 );
+
+ if ($last_nonblank_line) {
+ my $countm = $counti - 1;
+ $msg .= <<EOM;
+ $last_nonblank_count:$last_nonblank_line
+EOM
+ }
+ $line_diff = SPACE x ( 2 + length($counto) ) . $line_diff;
+ $msg .= <<EOM;
+<$counti:$linei
+>$counto:$lineo
+$line_diff
+EOM
+ return $msg;
+ } ## end while
+
+ # no line differences found, but one file may have fewer lines
+ if ( $counti > $counto ) {
+ $msg .= <<EOM;
+Files initially match file but output file has fewer lines
+EOM
+ }
+ elsif ( $counti < $counto ) {
+ $msg .= <<EOM;
+Files initially match file but input file has fewer lines
+EOM
+ }
+ else {
+ $msg .= <<EOM;
+Text in lines of file match but checksums differ. Perhaps line endings differ.
+EOM
+ }
+ return $msg;
+} ## end sub compare_string_buffers
sub get_stream_as_named_file {
# $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.
+ # NOTE: This routine was previously needed for passing actual files to Perl
+ # for a syntax check. It is not currently used.
my ($stream) = @_;
my $is_tmpfile;
my $fname;
}
}
return ( $fname, $is_tmpfile );
-}
+} ## end sub get_stream_as_named_file
sub fileglob_to_re {
$extension = $dot . $extension;
}
return $extension;
-}
+} ## end sub make_extension
sub write_logfile_header {
my (
$rOpts, $logger_object, $config_file,
$rraw_options, $Windows_type, $readable_options
) = @_;
+
+ # Note: the punctuation variable '$]' is not in older versions of
+ # English.pm so leave it as is to avoid failing installation tests.
$logger_object->write_logfile_entry(
-"perltidy version $VERSION log file on a $^O system, OLD_PERL_VERSION=$]\n"
+"perltidy version $VERSION log file on a $OSNAME system, OLD_PERL_VERSION=$]\n"
);
if ($Windows_type) {
$logger_object->write_logfile_entry("Windows type is $Windows_type\n");
}
- my $options_string = join( ' ', @{$rraw_options} );
+ my $options_string = join( SPACE, @{$rraw_options} );
if ($config_file) {
$logger_object->write_logfile_entry(
$logger_object->write_logfile_entry(
"To find error messages search for 'WARNING' with your editor\n");
return;
-}
+} ## end sub write_logfile_header
sub generate_options {
# which is mainly for debugging
# scl --> short-concatenation-item-length # helps break at '.'
# recombine # for debugging line breaks
- # valign # for debugging vertical alignment
# I --> DIAGNOSTICS # for debugging [**DEACTIVATED**]
######################################################################
no-profile
npro
recombine!
- valign!
notidy
);
$expansion{$nshort_name} = [$nolong_name];
}
}
+ return;
};
# Install long option names which have a simple abbreviation.
###########################
$add_option->( 'backup-and-modify-in-place', 'b', '!' );
$add_option->( 'backup-file-extension', 'bext', '=s' );
+ $add_option->( 'character-encoding', 'enc', '=s' );
$add_option->( 'force-read-binary', 'f', '!' );
$add_option->( 'format', 'fmt', '=s' );
$add_option->( 'iterations', 'it', '=i' );
$add_option->( 'quiet', 'q', '!' );
$add_option->( 'standard-error-output', 'se', '!' );
$add_option->( 'standard-output', 'st', '!' );
+ $add_option->( 'use-unicode-gcstring', 'gcs', '!' );
$add_option->( 'warning-output', 'w', '!' );
- $add_option->( 'character-encoding', 'enc', '=s' );
+ $add_option->( 'add-terminal-newline', 'atnl', '!' );
# options which are both toggle switches and values moved here
# to hide from tidyview (which does not show category 0 flags):
$add_option->( 'tabs', 't', '!' );
$add_option->( 'default-tabsize', 'dt', '=i' );
$add_option->( 'extended-syntax', 'xs', '!' );
+ $add_option->( 'assert-tidy', 'ast', '!' );
+ $add_option->( 'assert-untidy', 'asu', '!' );
+ $add_option->( 'encode-output-strings', 'eos', '!' );
+ $add_option->( 'sub-alias-list', 'sal', '=s' );
+ $add_option->( 'grep-alias-list', 'gal', '=s' );
+ $add_option->( 'grep-alias-exclusion-list', 'gaxl', '=s' );
########################################
$category = 2; # Code indentation control
########################################
- $add_option->( 'continuation-indentation', 'ci', '=i' );
- $add_option->( 'line-up-parentheses', 'lp', '!' );
- $add_option->( 'outdent-keyword-list', 'okwl', '=s' );
- $add_option->( 'outdent-keywords', 'okw', '!' );
- $add_option->( 'outdent-labels', 'ola', '!' );
- $add_option->( 'outdent-long-quotes', 'olq', '!' );
- $add_option->( 'indent-closing-brace', 'icb', '!' );
- $add_option->( 'closing-token-indentation', 'cti', '=i' );
- $add_option->( 'closing-paren-indentation', 'cpi', '=i' );
- $add_option->( 'closing-brace-indentation', 'cbi', '=i' );
- $add_option->( 'closing-square-bracket-indentation', 'csbi', '=i' );
- $add_option->( 'brace-left-and-indent', 'bli', '!' );
- $add_option->( 'brace-left-and-indent-list', 'blil', '=s' );
+ $add_option->( 'continuation-indentation', 'ci', '=i' );
+ $add_option->( 'extended-continuation-indentation', 'xci', '!' );
+ $add_option->( 'line-up-parentheses', 'lp', '!' );
+ $add_option->( 'extended-line-up-parentheses', 'xlp', '!' );
+ $add_option->( 'line-up-parentheses-exclusion-list', 'lpxl', '=s' );
+ $add_option->( 'line-up-parentheses-inclusion-list', 'lpil', '=s' );
+ $add_option->( 'outdent-keyword-list', 'okwl', '=s' );
+ $add_option->( 'outdent-keywords', 'okw', '!' );
+ $add_option->( 'outdent-labels', 'ola', '!' );
+ $add_option->( 'outdent-long-quotes', 'olq', '!' );
+ $add_option->( 'indent-closing-brace', 'icb', '!' );
+ $add_option->( 'closing-token-indentation', 'cti', '=i' );
+ $add_option->( 'closing-paren-indentation', 'cpi', '=i' );
+ $add_option->( 'closing-brace-indentation', 'cbi', '=i' );
+ $add_option->( 'closing-square-bracket-indentation', 'csbi', '=i' );
+ $add_option->( 'brace-left-and-indent', 'bli', '!' );
+ $add_option->( 'brace-left-and-indent-list', 'blil', '=s' );
+ $add_option->( 'brace-left-and-indent-exclusion-list', 'blixl', '=s' );
########################################
$category = 3; # Whitespace control
$add_option->( 'brace-tightness', 'bt', '=i' );
$add_option->( 'delete-old-whitespace', 'dws', '!' );
$add_option->( 'delete-semicolons', 'dsm', '!' );
+ $add_option->( 'function-paren-vertical-alignment', 'fpva', '!' );
+ $add_option->( 'keyword-paren-inner-tightness', 'kpit', '=i' );
+ $add_option->( 'keyword-paren-inner-tightness-list', 'kpitl', '=s' );
+ $add_option->( 'logical-padding', 'lop', '!' );
$add_option->( 'nospace-after-keyword', 'nsak', '=s' );
$add_option->( 'nowant-left-space', 'nwls', '=s' );
$add_option->( 'nowant-right-space', 'nwrs', '=s' );
$add_option->( 'trim-pod', 'trp', '!' );
$add_option->( 'want-left-space', 'wls', '=s' );
$add_option->( 'want-right-space', 'wrs', '=s' );
+ $add_option->( 'space-prototype-paren', 'spp', '=i' );
+ $add_option->( 'valign-code', 'vc', '!' );
+ $add_option->( 'valign-block-comments', 'vbc', '!' );
+ $add_option->( 'valign-side-comments', 'vsc', '!' );
+ $add_option->( 'valign-exclusion-list', 'vxl', '=s' );
+ $add_option->( 'valign-inclusion-list', 'vil', '=s' );
########################################
$category = 4; # Comment controls
$add_option->( 'closing-side-comment-warnings', 'cscw', '!' );
$add_option->( 'closing-side-comments', 'csc', '!' );
$add_option->( 'closing-side-comments-balanced', 'cscb', '!' );
+ $add_option->( 'code-skipping', 'cs', '!' );
+ $add_option->( 'code-skipping-begin', 'csb', '=s' );
+ $add_option->( 'code-skipping-end', 'cse', '=s' );
$add_option->( 'format-skipping', 'fs', '!' );
$add_option->( 'format-skipping-begin', 'fsb', '=s' );
$add_option->( 'format-skipping-end', 'fse', '=s' );
$add_option->( 'indent-spaced-block-comments', 'isbc', '!' );
$add_option->( 'fixed-position-side-comment', 'fpsc', '=i' );
$add_option->( 'minimum-space-to-comment', 'msc', '=i' );
+ $add_option->( 'non-indenting-braces', 'nib', '!' );
+ $add_option->( 'non-indenting-brace-prefix', 'nibp', '=s' );
$add_option->( 'outdent-long-comments', 'olc', '!' );
$add_option->( 'outdent-static-block-comments', 'osbc', '!' );
$add_option->( 'static-block-comment-prefix', 'sbcp', '=s' );
$add_option->( 'paren-vertical-tightness', 'pvt', '=i' );
$add_option->( 'paren-vertical-tightness-closing', 'pvtc', '=i' );
$add_option->( 'weld-nested-containers', 'wn', '!' );
+ $add_option->( 'weld-nested-exclusion-list', 'wnxl', '=s' );
$add_option->( 'space-backslash-quote', 'sbq', '=i' );
$add_option->( 'stack-closing-block-brace', 'scbb', '!' );
$add_option->( 'stack-closing-hash-brace', 'schb', '!' );
$add_option->( 'stack-closing-paren', 'scp', '!' );
$add_option->( 'stack-closing-square-bracket', 'scsb', '!' );
- $add_option->( 'stack-opening-block-brace', 'sobb', '!' );
$add_option->( 'stack-opening-hash-brace', 'sohb', '!' );
$add_option->( 'stack-opening-paren', 'sop', '!' );
$add_option->( 'stack-opening-square-bracket', 'sosb', '!' );
$add_option->( 'break-before-all-operators', 'bbao', '!' );
$add_option->( 'keep-interior-semicolons', 'kis', '!' );
$add_option->( 'one-line-block-semicolons', 'olbs', '=i' );
+ $add_option->( 'one-line-block-nesting', 'olbn', '=i' );
+ $add_option->( 'break-before-hash-brace', 'bbhb', '=i' );
+ $add_option->( 'break-before-hash-brace-and-indent', 'bbhbi', '=i' );
+ $add_option->( 'break-before-square-bracket', 'bbsb', '=i' );
+ $add_option->( 'break-before-square-bracket-and-indent', 'bbsbi', '=i' );
+ $add_option->( 'break-before-paren', 'bbp', '=i' );
+ $add_option->( 'break-before-paren-and-indent', 'bbpi', '=i' );
+ $add_option->( 'brace-left-list', 'bll', '=s' );
+ $add_option->( 'brace-left-exclusion-list', 'blxl', '=s' );
+ $add_option->( 'break-after-labels', 'bal', '=i' );
+
+ # This was an experiment mentioned in git #78, originally named -bopl. I
+ # expanded it to also open logical blocks, based on git discussion #100,
+ # and renamed it -bocp. It works, but will remain commented out due to
+ # apparent lack of interest.
+ # $add_option->( 'break-open-compact-parens', 'bocp', '=s' );
########################################
$category = 6; # Controlling list formatting
$add_option->( 'break-at-old-keyword-breakpoints', 'bok', '!' );
$add_option->( 'break-at-old-logical-breakpoints', 'bol', '!' );
$add_option->( 'break-at-old-method-breakpoints', 'bom', '!' );
+ $add_option->( 'break-at-old-semicolon-breakpoints', 'bos', '!' );
$add_option->( 'break-at-old-ternary-breakpoints', 'bot', '!' );
$add_option->( 'break-at-old-attribute-breakpoints', 'boa', '!' );
+ $add_option->( 'keep-old-breakpoints-before', 'kbb', '=s' );
+ $add_option->( 'keep-old-breakpoints-after', 'kba', '=s' );
$add_option->( 'ignore-old-breakpoints', 'iob', '!' );
########################################
########################################
$category = 13; # Debugging
########################################
-## $add_option->( 'DIAGNOSTICS', 'I', '!' );
- $add_option->( 'DEBUG', 'D', '!' );
- $add_option->( 'dump-cuddled-block-list', 'dcbl', '!' );
- $add_option->( 'dump-defaults', 'ddf', '!' );
- $add_option->( 'dump-long-names', 'dln', '!' );
- $add_option->( 'dump-options', 'dop', '!' );
- $add_option->( 'dump-profile', 'dpro', '!' );
- $add_option->( 'dump-short-names', 'dsn', '!' );
- $add_option->( 'dump-token-types', 'dtt', '!' );
- $add_option->( 'dump-want-left-space', 'dwls', '!' );
- $add_option->( 'dump-want-right-space', 'dwrs', '!' );
- $add_option->( 'fuzzy-line-length', 'fll', '!' );
- $add_option->( 'help', 'h', '' );
- $add_option->( 'short-concatenation-item-length', 'scl', '=i' );
- $add_option->( 'show-options', 'opt', '!' );
- $add_option->( 'timestamp', 'ts', '!' );
- $add_option->( 'version', 'v', '' );
- $add_option->( 'memoize', 'mem', '!' );
- $add_option->( 'file-size-order', 'fso', '!' );
+ $add_option->( 'DIAGNOSTICS', 'I', '!' ) if (DEVEL_MODE);
+ $add_option->( 'DEBUG', 'D', '!' );
+ $add_option->( 'dump-cuddled-block-list', 'dcbl', '!' );
+ $add_option->( 'dump-defaults', 'ddf', '!' );
+ $add_option->( 'dump-long-names', 'dln', '!' );
+ $add_option->( 'dump-options', 'dop', '!' );
+ $add_option->( 'dump-profile', 'dpro', '!' );
+ $add_option->( 'dump-short-names', 'dsn', '!' );
+ $add_option->( 'dump-token-types', 'dtt', '!' );
+ $add_option->( 'dump-want-left-space', 'dwls', '!' );
+ $add_option->( 'dump-want-right-space', 'dwrs', '!' );
+ $add_option->( 'fuzzy-line-length', 'fll', '!' );
+ $add_option->( 'help', 'h', EMPTY_STRING );
+ $add_option->( 'short-concatenation-item-length', 'scl', '=i' );
+ $add_option->( 'show-options', 'opt', '!' );
+ $add_option->( 'timestamp', 'ts', '!' );
+ $add_option->( 'version', 'v', EMPTY_STRING );
+ $add_option->( 'memoize', 'mem', '!' );
+ $add_option->( 'file-size-order', 'fso', '!' );
+ $add_option->( 'maximum-file-size-mb', 'maxfs', '=i' );
+ $add_option->( 'maximum-level-errors', 'maxle', '=i' );
+ $add_option->( 'maximum-unexpected-errors', 'maxue', '=i' );
#---------------------------------------------------------------------
# if max is undefined, there is no upper limit
# Parameters not listed here have defaults
%option_range = (
- 'format' => [ 'tidy', 'html', 'user' ],
- 'output-line-ending' => [ 'dos', 'win', 'mac', 'unix' ],
- 'character-encoding' => [ 'none', 'utf8' ],
-
- 'space-backslash-quote' => [ 0, 2 ],
-
- 'block-brace-tightness' => [ 0, 2 ],
- 'brace-tightness' => [ 0, 2 ],
- 'paren-tightness' => [ 0, 2 ],
- 'square-bracket-tightness' => [ 0, 2 ],
+ 'format' => [ 'tidy', 'html', 'user' ],
+ 'output-line-ending' => [ 'dos', 'win', 'mac', 'unix' ],
+ 'space-backslash-quote' => [ 0, 2 ],
+ 'block-brace-tightness' => [ 0, 2 ],
+ 'keyword-paren-inner-tightness' => [ 0, 2 ],
+ 'brace-tightness' => [ 0, 2 ],
+ 'paren-tightness' => [ 0, 2 ],
+ 'square-bracket-tightness' => [ 0, 2 ],
'block-brace-vertical-tightness' => [ 0, 2 ],
'brace-vertical-tightness' => [ 0, 2 ],
'keyword-group-blanks-before' => [ 0, 2 ],
'keyword-group-blanks-after' => [ 0, 2 ],
+
+ 'space-prototype-paren' => [ 0, 2 ],
+ 'break-after-labels' => [ 0, 2 ],
);
# Note: we could actually allow negative ci if someone really wants it:
# $option_range{'continuation-indentation'} = [ undef, undef ];
#---------------------------------------------------------------
- # Assign default values to the above options here, except
+ # DEFAULTS: Assign default values to the above options here, except
# for 'outfile' and 'help'.
# These settings should approximate the perlstyle(1) suggestions.
#---------------------------------------------------------------
my @defaults = qw(
add-newlines
+ add-terminal-newline
add-semicolons
add-whitespace
blanks-before-blocks
brace-tightness=1
brace-vertical-tightness-closing=0
brace-vertical-tightness=0
+ break-after-labels=0
break-at-old-logical-breakpoints
break-at-old-ternary-breakpoints
break-at-old-attribute-breakpoints
break-at-old-keyword-breakpoints
+ break-before-hash-brace=0
+ break-before-hash-brace-and-indent=0
+ break-before-square-bracket=0
+ break-before-square-bracket-and-indent=0
+ break-before-paren=0
+ break-before-paren-and-indent=0
comma-arrow-breakpoints=5
nocheck-syntax
+ character-encoding=guess
closing-side-comment-interval=6
closing-side-comment-maximum-text=20
closing-side-comment-else-flag=0
closing-brace-indentation=0
closing-square-bracket-indentation=0
continuation-indentation=2
+ noextended-continuation-indentation
cuddled-break-option=1
delete-old-newlines
delete-semicolons
extended-syntax
+ encode-output-strings
+ function-paren-vertical-alignment
fuzzy-line-length
hanging-side-comments
indent-block-comments
indent-columns=4
iterations=1
keep-old-blank-lines=1
+ keyword-paren-inner-tightness=1
+ logical-padding
long-block-line-count=8
look-for-autoloader
look-for-selfloader
maximum-consecutive-blank-lines=1
maximum-fields-per-table=0
maximum-line-length=80
+ maximum-file-size-mb=10
+ maximum-level-errors=1
+ maximum-unexpected-errors=0
memoize
minimum-space-to-comment=4
nobrace-left-and-indent
nodelete-old-whitespace
nohtml
nologfile
+ non-indenting-braces
noquiet
noshow-options
nostatic-side-comments
notabs
nowarning-output
- character-encoding=none
one-line-block-semicolons=1
+ one-line-block-nesting=0
outdent-labels
outdent-long-quotes
outdent-long-comments
pass-version-line
noweld-nested-containers
recombine
- valign
+ nouse-unicode-gcstring
+ valign-code
+ valign-block-comments
+ valign-side-comments
short-concatenation-item-length=8
space-for-semicolon
space-backslash-quote=1
+ space-prototype-paren=1
square-bracket-tightness=1
square-bracket-vertical-tightness-closing=0
square-bracket-vertical-tightness=0
trim-qw
format=tidy
backup-file-extension=bak
+ code-skipping
format-skipping
default-tabsize=8
#---------------------------------------------------------------
%expansion = (
%expansion,
- 'freeze-newlines' => [qw(noadd-newlines nodelete-old-newlines)],
- 'fnl' => [qw(freeze-newlines)],
- 'freeze-whitespace' => [qw(noadd-whitespace nodelete-old-whitespace)],
- 'fws' => [qw(freeze-whitespace)],
+ 'freeze-newlines' => [qw(noadd-newlines nodelete-old-newlines)],
+ 'fnl' => [qw(freeze-newlines)],
+ 'freeze-whitespace' => [qw(noadd-whitespace nodelete-old-whitespace)],
+ 'fws' => [qw(freeze-whitespace)],
'freeze-blank-lines' =>
[qw(maximum-consecutive-blank-lines=0 keep-old-blank-lines=2)],
'fbl' => [qw(freeze-blank-lines)],
'outdent-long-lines' => [qw(outdent-long-quotes outdent-long-comments)],
'nooutdent-long-lines' =>
[qw(nooutdent-long-quotes nooutdent-long-comments)],
- 'noll' => [qw(nooutdent-long-lines)],
- 'io' => [qw(indent-only)],
+ 'oll' => [qw(outdent-long-lines)],
+ 'noll' => [qw(nooutdent-long-lines)],
+ 'io' => [qw(indent-only)],
'delete-all-comments' =>
[qw(delete-block-comments delete-side-comments delete-pod)],
'nodelete-all-comments' =>
[qw(nodelete-block-comments nodelete-side-comments nodelete-pod)],
- 'dac' => [qw(delete-all-comments)],
- 'ndac' => [qw(nodelete-all-comments)],
- 'gnu' => [qw(gnu-style)],
- 'pbp' => [qw(perl-best-practices)],
+ 'dac' => [qw(delete-all-comments)],
+ 'ndac' => [qw(nodelete-all-comments)],
+ 'gnu' => [qw(gnu-style)],
+ 'pbp' => [qw(perl-best-practices)],
'tee-all-comments' =>
[qw(tee-block-comments tee-side-comments tee-pod)],
'notee-all-comments' =>
'nhtml' => [qw(format=tidy)],
'tidy' => [qw(format=tidy)],
+ 'brace-left' => [qw(opening-brace-on-new-line)],
+
# -cb is now a synonym for -ce
'cb' => [qw(cuddled-else)],
'cuddled-blocks' => [qw(cuddled-else)],
- 'utf8' => [qw(character-encoding=utf8)],
- 'UTF8' => [qw(character-encoding=utf8)],
+ 'utf8' => [qw(character-encoding=utf8)],
+ 'UTF8' => [qw(character-encoding=utf8)],
+ 'guess' => [qw(character-encoding=guess)],
'swallow-optional-blank-lines' => [qw(kbl=0)],
'noswallow-optional-blank-lines' => [qw(kbl=1)],
'nostack-opening-tokens' => [qw(nsop nsohb nsosb)],
'sct' => [qw(scp schb scsb)],
- 'stack-closing-tokens' => => [qw(scp schb scsb)],
+ 'stack-closing-tokens' => [qw(scp schb scsb)],
'nsct' => [qw(nscp nschb nscsb)],
'nostack-closing-tokens' => [qw(nscp nschb nscsb)],
'conv' => [qw(it=4)],
'nconv' => [qw(it=1)],
+ 'valign' => [qw(vc vsc vbc)],
+ 'novalign' => [qw(nvc nvsc nvbc)],
+
+ # NOTE: This is a possible future shortcut. But it will remain
+ # deactivated until the -lpxl flag is no longer experimental.
+ # 'line-up-function-parentheses' => [ qw(lp), q#lpxl=[ { F(2# ],
+ # 'lfp' => [qw(line-up-function-parentheses)],
+
# 'mangle' originally deleted pod and comments, but to keep it
# reversible, it no longer does. But if you really want to
# delete them, just use:
'mangle' => [
qw(
- check-syntax
keep-old-blank-lines=0
delete-old-newlines
delete-old-whitespace
blank-lines-before-subs=0
blank-lines-before-packages=0
notabs
- )
+ )
],
# 'extrude' originally deleted pod and comments, but to keep it
# An interesting use for 'extrude' is to do this:
# perltidy -extrude myfile.pl -st | perltidy -o myfile.pl.new
# which will break up all one-line blocks.
- #
- # Removed 'check-syntax' option, which is unsafe because it may execute
- # code in BEGIN blocks. Example 'Moose/debugger-duck_type.t'.
-
'extrude' => [
qw(
ci=0
nofuzzy-line-length
notabs
norecombine
- )
+ )
],
# this style tries to follow the GNU Coding Standards (which do
'gnu-style' => [
qw(
lp bl noll pt=2 bt=2 sbt=2 cpi=1 csbi=1 cbi=1
- )
+ )
],
# Style suggested in Damian Conway's Perl Best Practices
\%option_category, \%option_range
);
-} # end of generate_options
+} ## end sub generate_options
# Memoize process_command_line. Given same @ARGV passed in, return same
# values and same @ARGV back.
else {
return _process_command_line(@q);
}
-}
+} ## end sub process_command_line
# (note the underscore here)
sub _process_command_line {
# Previous configuration is reset at the exit of this routine.
my $glc;
eval { $glc = Getopt::Long::Configure() };
- unless ($@) {
+ unless ($EVAL_ERROR) {
eval { Getopt::Long::ConfigDefaults() };
}
else { $glc = undef }
my $word;
my @raw_options = ();
- my $config_file = "";
+ my $config_file = EMPTY_STRING;
my $saw_ignore_profile = 0;
my $saw_dump_profile = 0;
}
}
unless ( -e $config_file ) {
- Warn("cannot find file given with -pro=$config_file: $!\n");
- $config_file = "";
+ Warn("cannot find file given with -pro=$config_file: $ERRNO\n");
+ $config_file = EMPTY_STRING;
}
}
elsif ( $i =~ /^-(pro|profile)=?$/ ) {
# look for a config file if we don't have one yet
my $rconfig_file_chatter;
- ${$rconfig_file_chatter} = "";
+ ${$rconfig_file_chatter} = EMPTY_STRING;
$config_file =
find_config_file( $is_Windows, $Windows_type, $rconfig_file_chatter,
$rpending_complaint )
return ( \%Opts, $config_file, \@raw_options, $roption_string,
$rexpansion, $roption_category, $roption_range );
-} # end of _process_command_line
+} ## end sub _process_command_line
+
+sub make_grep_alias_string {
+ my ($rOpts) = @_;
+
+ # Defaults: list operators in List::Util
+ # Possible future additions: pairfirst pairgrep pairmap
+ my $default_string = join SPACE, qw(
+ all
+ any
+ first
+ none
+ notall
+ reduce
+ reductions
+ );
+
+ # make a hash of any excluded words
+ my %is_excluded_word;
+ my $exclude_string = $rOpts->{'grep-alias-exclusion-list'};
+ if ($exclude_string) {
+ $exclude_string =~ s/,/ /g; # allow commas
+ $exclude_string =~ s/^\s+//;
+ $exclude_string =~ s/\s+$//;
+ my @q = split /\s+/, $exclude_string;
+ @is_excluded_word{@q} = (1) x scalar(@q);
+ }
+
+ # The special option -gaxl='*' removes all defaults
+ if ( $is_excluded_word{'*'} ) { $default_string = EMPTY_STRING }
+
+ # combine the defaults and any input list
+ my $input_string = $rOpts->{'grep-alias-list'};
+ if ($input_string) { $input_string .= SPACE . $default_string }
+ else { $input_string = $default_string }
+
+ # Now make the final list of unique grep alias words
+ $input_string =~ s/,/ /g; # allow commas
+ $input_string =~ s/^\s+//;
+ $input_string =~ s/\s+$//;
+ my @word_list = split /\s+/, $input_string;
+ my @filtered_word_list;
+ my %seen;
+
+ foreach my $word (@word_list) {
+ if ($word) {
+ if ( $word !~ /^\w[\w\d]*$/ ) {
+ Warn(
+ "unexpected word in --grep-alias-list: '$word' - ignoring\n"
+ );
+ }
+ if ( !$seen{$word} && !$is_excluded_word{$word} ) {
+ $seen{$word}++;
+ push @filtered_word_list, $word;
+ }
+ }
+ }
+ my $joined_words = join SPACE, @filtered_word_list;
+ $rOpts->{'grep-alias-list'} = $joined_words;
+ return;
+} ## end sub make_grep_alias_string
sub check_options {
# check and handle any interactions among the basic options..
#---------------------------------------------------------------
+ # Since perltidy only encodes in utf8, problems can occur if we let it
+ # decode anything else. See discussions for issue git #83.
+ my $encoding = $rOpts->{'character-encoding'};
+ if ( $encoding !~ /^\s*(guess|none|utf8|utf-8)\s*$/i ) {
+ Die(<<EOM);
+--character-encoding = '$encoding' is not allowed; the options are: 'none', 'guess', 'utf8'
+EOM
+ }
+
# Since -vt, -vtc, and -cti are abbreviations, but under
# msdos, an unquoted input parameter like vtc=1 will be
# seen as 2 parameters, vtc and 1, so the abbreviations
$rOpts->{'closing-paren-indentation'} = $cti;
}
- # In quiet mode, there is no log file and hence no way to report
- # results of syntax check, so don't do it.
- if ( $rOpts->{'quiet'} ) {
- $rOpts->{'check-syntax'} = 0;
- }
-
- # can't check syntax if no output
- if ( $rOpts->{'format'} ne 'tidy' ) {
- $rOpts->{'check-syntax'} = 0;
- }
-
- # Never let Windows 9x/Me systems run syntax check -- this will prevent a
- # wide variety of nasty problems on these systems, because they cannot
- # reliably run backticks. Don't even think about changing this!
- if ( $rOpts->{'check-syntax'}
- && $is_Windows
- && ( !$Windows_type || $Windows_type =~ /^(9|Me)/ ) )
- {
- $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. Also fix sub 'do_check_syntax' in this file.
- ###########################################################################
- else {
- $rOpts->{'check-syntax'} = 0;
- }
-
- # It's really a bad idea to check syntax as root unless you wrote
- # the script yourself. FIXME: not sure if this works with VMS
- unless ($is_Windows) {
-
- if ( $< == 0 && $rOpts->{'check-syntax'} ) {
- $rOpts->{'check-syntax'} = 0;
- ${$rpending_complaint} .=
-"Syntax check deactivated for safety; you shouldn't run this as root\n";
- }
- }
+ # Syntax checking is no longer supported due to concerns about executing
+ # code in BEGIN blocks. The flag is still accepted for backwards
+ # compatibility but is ignored if set.
+ $rOpts->{'check-syntax'} = 0;
# check iteration count and quietly fix if necessary:
# - iterations option only applies to code beautification mode
$rOpts->{$key} = 100;
}
}
+ return;
};
# check for reasonable number of blank lines and fix to avoid problems
$rOpts->{'indent-block-comments'} = 1;
}
- # -bli flag implies -bl
- if ( $rOpts->{'brace-left-and-indent'} ) {
- $rOpts->{'opening-brace-on-new-line'} = 1;
- }
+ # -bar cannot be used with -bl or -bli; arbitrarily keep -bar
+ if ( $rOpts->{'opening-brace-always-on-right'} ) {
- if ( $rOpts->{'opening-brace-always-on-right'}
- && $rOpts->{'opening-brace-on-new-line'} )
- {
- Warn(<<EOM);
+ if ( $rOpts->{'opening-brace-on-new-line'} ) {
+ Warn(<<EOM);
Conflict: you specified both 'opening-brace-always-on-right' (-bar) and
- 'opening-brace-on-new-line' (-bl). Ignoring -bl.
+ 'opening-brace-on-new-line' (-bl). Ignoring -bl.
EOM
- $rOpts->{'opening-brace-on-new-line'} = 0;
+ $rOpts->{'opening-brace-on-new-line'} = 0;
+ }
+ if ( $rOpts->{'brace-left-and-indent'} ) {
+ Warn(<<EOM);
+ Conflict: you specified both 'opening-brace-always-on-right' (-bar) and
+ '--brace-left-and-indent' (-bli). Ignoring -bli.
+EOM
+ $rOpts->{'brace-left-and-indent'} = 0;
+ }
}
# it simplifies things if -bl is 0 rather than undefined
$rOpts->{'opening-brace-on-new-line'} = 0;
}
- # -sbl defaults to -bl if not defined
- if ( !defined( $rOpts->{'opening-sub-brace-on-new-line'} ) ) {
- $rOpts->{'opening-sub-brace-on-new-line'} =
- $rOpts->{'opening-brace-on-new-line'};
- }
-
if ( $rOpts->{'entab-leading-whitespace'} ) {
if ( $rOpts->{'entab-leading-whitespace'} < 0 ) {
Warn("-et=n must use a positive integer; ignoring -et\n");
}
# entab leading whitespace has priority over the older 'tabs' option
- if ( $rOpts->{'tabs'} ) { $rOpts->{'tabs'} = 0; }
+ if ( $rOpts->{'tabs'} ) {
+
+ # The following warning could be added but would annoy a lot of
+ # users who have a perltidyrc with both -t and -et=n. So instead
+ # there is a note in the manual that -et overrides -t.
+ ##Warn("-tabs and -et=n conflict; ignoring -tabs\n");
+ $rOpts->{'tabs'} = 0;
+ }
}
# set a default tabsize to be used in guessing the starting indentation
$rOpts->{'default-tabsize'} = 8;
}
+ # Check and clean up any sub-alias-list
+ if ( $rOpts->{'sub-alias-list'} ) {
+ my $sub_alias_string = $rOpts->{'sub-alias-list'};
+ $sub_alias_string =~ s/,/ /g; # allow commas
+ $sub_alias_string =~ s/^\s+//;
+ $sub_alias_string =~ s/\s+$//;
+ my @sub_alias_list = split /\s+/, $sub_alias_string;
+ my @filtered_word_list = ('sub');
+ my %seen;
+
+ # include 'sub' for later convenience
+ $seen{sub}++;
+ foreach my $word (@sub_alias_list) {
+ if ($word) {
+ if ( $word !~ /^\w[\w\d]*$/ ) {
+ Warn("unexpected sub alias '$word' - ignoring\n");
+ }
+ if ( !$seen{$word} ) {
+ $seen{$word}++;
+ push @filtered_word_list, $word;
+ }
+ }
+ }
+ $rOpts->{'sub-alias-list'} = join SPACE, @filtered_word_list;
+ }
+
+ make_grep_alias_string($rOpts);
+
+ # Turn on fuzzy-line-length unless this is an extrude run, as determined
+ # by the -i and -ci settings. Otherwise blinkers can form (case b935)
+ if ( !$rOpts->{'fuzzy-line-length'} ) {
+ if ( $rOpts->{'maximum-line-length'} != 1
+ || $rOpts->{'continuation-indentation'} != 0 )
+ {
+ $rOpts->{'fuzzy-line-length'} = 1;
+ }
+ }
+
+ # The freeze-whitespace option is currently a derived option which has its
+ # own key
+ $rOpts->{'freeze-whitespace'} = !$rOpts->{'add-whitespace'}
+ && !$rOpts->{'delete-old-whitespace'};
+
+ # Turn off certain options if whitespace is frozen
+ # Note: vertical alignment will be automatically shut off
+ if ( $rOpts->{'freeze-whitespace'} ) {
+ $rOpts->{'logical-padding'} = 0;
+ }
+
# Define $tabsize, the number of spaces per tab for use in
# guessing the indentation of source lines with leading tabs.
# Assume same as for this run if tabs are used , otherwise assume
: $rOpts->{'tabs'} ? $rOpts->{'indent-columns'}
: $rOpts->{'default-tabsize'};
return $tabsize;
-}
+} ## end sub check_options
sub find_file_upwards {
my ( $search_dir, $search_file ) = @_;
# This return is for Perl-Critic.
# We shouldn't get out of the while loop without a return
return;
-}
+} ## end sub find_file_upwards
sub expand_command_abbreviations {
# 10 should be plenty, but it may be increased to allow deeply
# nested expansions.
my $max_passes = 10;
- my @new_argv = ();
# keep looping until all expansions have been converted into actual
# dash parameters..
# to allow abbreviations with arguments such as '-vt=1'
if ( $rexpansion->{ $abr . $flags } ) {
$abr = $abr . $flags;
- $flags = "";
+ $flags = EMPTY_STRING;
}
# if we see this dash item in the expansion hash..
else {
push( @new_argv, $word );
}
- } # end of this pass
+ } ## end of this pass
# update parameter list @ARGV to the new one
@ARGV = @new_argv;
# make sure we are not in an infinite loop
if ( $pass_count == $max_passes ) {
- local $" = ')(';
+ local $LIST_SEPARATOR = ')(';
Warn(<<EOM);
I'm tired. We seem to be in an infinite loop trying to expand aliases.
Here are the raw options;
a recent program change.
DIE
}
- } # end of check for circular references
- } # end of loop over all passes
+ } ## end of check for circular references
+ } ## end of loop over all passes
return;
-}
+} ## end sub expand_command_abbreviations
# Debug routine -- this will dump the expansion hash
sub dump_short_names {
For a list of all long names, use perltidy --dump-long-names (-dln).
--------------------------------------------------------------------------
EOM
- foreach my $abbrev ( sort keys %$rexpansion ) {
+ foreach my $abbrev ( sort keys %{$rexpansion} ) {
my @list = @{ $rexpansion->{$abbrev} };
print STDOUT "$abbrev --> @list\n";
}
return;
-}
+} ## end sub dump_short_names
sub check_vms_filename {
\.-?\d*$ # match . version number
/$1/x;
- # normalise filename, if there are no unescaped dots then append one
+ # normalize filename, if there are no unescaped dots then append one
$base .= '.' unless $base =~ /(?:^|[^^])\./;
# if we don't already have an extension then we just append the extension
- my $separator = ( $base =~ /\.$/ ) ? "" : "_";
+ my $separator = ( $base =~ /\.$/ ) ? EMPTY_STRING : "_";
return ( $path . $base, $separator );
-}
+} ## end sub check_vms_filename
sub Win_OS_Type {
# We need to know this to decide where to look for config files
my $rpending_complaint = shift;
- my $os = "";
- return $os unless $^O =~ /win32|dos/i; # is it a MS box?
+ my $os = EMPTY_STRING;
+ return $os unless $OSNAME =~ /win32|dos/i; # is it a MS box?
# Systems built from Perl source may not have Win32.pm
# But probably have Win32::GetOSVersion() anyway so the
90 => "Me"
},
2 => {
- 0 => "2000", # or NT 4, see below
+ 0 => "2000", # or NT 4, see below
1 => "XP/.Net",
2 => "Win2003",
51 => "NT3.51"
# If $os is undefined, the above code is out of date. Suggested updates
# are welcome.
unless ( defined $os ) {
- $os = "";
+ $os = EMPTY_STRING;
# Deactivated this message 20180322 because it was needlessly
# causing some test scripts to fail. Need help from someone
# Unfortunately the logic used for the various versions isn't so clever..
# so we have to handle an outside case.
return ( $os eq "2000" && $major != 5 ) ? "NT4" : $os;
-}
+} ## end sub Win_OS_Type
sub is_unix {
return
- ( $^O !~ /win32|dos/i )
- && ( $^O ne 'VMS' )
- && ( $^O ne 'OS2' )
- && ( $^O ne 'MacOS' );
+ ( $OSNAME !~ /win32|dos/i )
+ && ( $OSNAME ne 'VMS' )
+ && ( $OSNAME ne 'OS2' )
+ && ( $OSNAME ne 'MacOS' );
}
sub look_for_Windows {
# determine Windows sub-type and location of
# system-wide configuration files
my $rpending_complaint = shift;
- my $is_Windows = ( $^O =~ /win32|dos/i );
+ my $is_Windows = ( $OSNAME =~ /win32|dos/i );
my $Windows_type;
$Windows_type = Win_OS_Type($rpending_complaint) if $is_Windows;
return ( $is_Windows, $Windows_type );
-}
+} ## end sub look_for_Windows
sub find_config_file {
# look for a .perltidyrc configuration file
# For Windows also look for a file named perltidy.ini
my ( $is_Windows, $Windows_type, $rconfig_file_chatter,
- $rpending_complaint ) = @_;
+ $rpending_complaint )
+ = @_;
${$rconfig_file_chatter} .= "# Config file search...system reported as:";
if ($is_Windows) {
${$rconfig_file_chatter} .= "Windows $Windows_type\n";
}
else {
- ${$rconfig_file_chatter} .= " $^O\n";
+ ${$rconfig_file_chatter} .= " $OSNAME\n";
}
# sub to check file existence and record all tests
# Check the NT/2k/XP locations, first a local machine def, then a
# network def
- push @envs, qw(USERPROFILE HOMESHARE) if $^O =~ /win32/i;
+ push @envs, qw(USERPROFILE HOMESHARE) if $OSNAME =~ /win32/i;
# Now go through the environment ...
foreach my $var (@envs) {
}
# Place to add customization code for other systems
- elsif ( $^O eq 'OS2' ) {
+ elsif ( $OSNAME eq 'OS2' ) {
}
- elsif ( $^O eq 'MacOS' ) {
+ elsif ( $OSNAME eq 'MacOS' ) {
}
- elsif ( $^O eq 'VMS' ) {
+ elsif ( $OSNAME eq 'VMS' ) {
}
# Assume some kind of Unix
# Couldn't find a config file
return;
-}
+} ## end sub find_config_file
sub Win_Config_Locs {
return unless $os;
- my $system = "";
- my $allusers = "";
+ my $system = EMPTY_STRING;
+ my $allusers = EMPTY_STRING;
if ( $os =~ /9[58]|Me/ ) {
$system = "C:/Windows";
return;
}
return wantarray ? ( $os, $system, $allusers ) : $os;
-}
+} ## end sub Win_Config_Locs
sub dump_config_file {
my ( $fh, $config_file, $rconfig_file_chatter ) = @_;
print STDOUT "# ...no config file found\n";
}
return;
-}
+} ## end sub dump_config_file
sub read_config_file {
my @config_list = ();
# file is bad if non-empty $death_message is returned
- my $death_message = "";
+ my $death_message = EMPTY_STRING;
my $name = undef;
my $line_no;
$opening_brace_line = $line_no unless ( $body && $body =~ s/\}$// );
# handle a new alias definition
- if ( ${$rexpansion}{$name} ) {
- local $" = ')(';
- my @names = sort keys %$rexpansion;
+ if ( $rexpansion->{$name} ) {
+ local $LIST_SEPARATOR = ')(';
+ my @names = sort keys %{$rexpansion};
$death_message =
"Here is a list of all installed aliases\n(@names)\n"
- . "Attempting to redefine alias ($name) in config file $config_file line $.\n";
+ . "Attempting to redefine alias ($name) in config file $config_file line $INPUT_LINE_NUMBER\n";
last;
}
- ${$rexpansion}{$name} = [];
+ $rexpansion->{$name} = [];
}
# leading opening braces not allowed
# remove leading dashes if this is an alias
foreach ( @{$rbody_parts} ) { s/^\-+//; }
- push @{ ${$rexpansion}{$name} }, @{$rbody_parts};
+ push @{ $rexpansion->{$name} }, @{$rbody_parts};
}
else {
push( @config_list, @{$rbody_parts} );
}
eval { $fh->close() };
return ( \@config_list, $death_message );
-}
+} ## end sub read_config_file
sub strip_comment {
# Strip any comment from a command line
my ( $instr, $config_file, $line_no ) = @_;
- my $msg = "";
+ my $msg = EMPTY_STRING;
# check for full-line comment
if ( $instr =~ /^\s*#/ ) {
- return ( "", $msg );
+ return ( EMPTY_STRING, $msg );
}
# nothing to do if no comments
}
# handle comments and quotes
- my $outstr = "";
- my $quote_char = "";
+ my $outstr = EMPTY_STRING;
+ my $quote_char = EMPTY_STRING;
while (1) {
# looking for ending quote character
if ($quote_char) {
if ( $instr =~ /\G($quote_char)/gc ) {
- $quote_char = "";
+ $quote_char = EMPTY_STRING;
$outstr .= $1;
}
elsif ( $instr =~ /\G(.)/gc ) {
}
}
return ( $outstr, $msg );
-}
+} ## end sub strip_comment
sub parse_args {
my ($body) = @_;
my @body_parts = ();
- my $quote_char = "";
- my $part = "";
- my $msg = "";
+ my $quote_char = EMPTY_STRING;
+ my $part = EMPTY_STRING;
+ my $msg = EMPTY_STRING;
+
+ # Check for external call with undefined $body - added to fix
+ # github issue Perl-Tidy-Sweetened issue #23
+ if ( !defined($body) ) { $body = EMPTY_STRING }
+
while (1) {
# looking for ending quote character
if ($quote_char) {
if ( $body =~ /\G($quote_char)/gc ) {
- $quote_char = "";
+ $quote_char = EMPTY_STRING;
}
elsif ( $body =~ /\G(.)/gc ) {
$part .= $1;
}
elsif ( $body =~ /\G(\s+)/gc ) {
if ( length($part) ) { push @body_parts, $part; }
- $part = "";
+ $part = EMPTY_STRING;
}
elsif ( $body =~ /\G(.)/gc ) {
$part .= $1;
}
}
return ( \@body_parts, $msg );
-}
+} ## end sub parse_args
sub dump_long_names {
foreach my $name ( sort @names ) { print STDOUT "$name\n" }
return;
-}
+} ## end sub dump_long_names
sub dump_defaults {
my @defaults = @_;
$readable_options .=
"# See utility 'perltidyrc_dump.pl' for nicer formatting.\n";
foreach my $opt ( @{$roption_string} ) {
- my $flag = "";
+ my $flag = EMPTY_STRING;
if ( $opt =~ /(.*)(!|=.*)$/ ) {
$opt = $1;
$flag = $2;
my $flag = $rGetopt_flags->{$key};
my $value = $rOpts->{$key};
my $prefix = '--';
- my $suffix = "";
+ my $suffix = EMPTY_STRING;
if ($flag) {
if ( $flag =~ /^=/ ) {
if ( $value !~ /^\d+$/ ) { $value = '"' . $value . '"' }
$readable_options .= $prefix . $key . $suffix . "\n";
}
return $readable_options;
-}
+} ## end sub readable_options
sub show_version {
print STDOUT <<"EOM";
This is perltidy, v$VERSION
-Copyright 2000-2019, Steve Hancock
+Copyright 2000-2022, 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.
or on the internet at http://perltidy.sourceforge.net.
EOM
return;
-}
+} ## end sub show_version
sub usage {
-bext=s change default backup extension from 'bak' to s
-q deactivate error messages (for running under editor)
-w include non-critical warning messages in the .ERR error output
- -syn run perl -c to check syntax (default under unix systems)
-log save .LOG file, which has useful diagnostics
-f force perltidy to read a binary file
-g like -log but writes more detailed .LOG file, for debugging scripts
Basic Options:
-i=n use n columns per indentation level (default n=4)
- -t tabs: use one tab character per indentation level, not recommeded
+ -t tabs: use one tab character per indentation level, not recommended
-nt no tabs: use n spaces per indentation level (default)
-et=n entab leading whitespace n spaces per tab; not recommended
-io "indent only": just do indentation, no other formatting.
-wba=s want break after tokens in string; i.e. wba=': .'
-wbb=s want break before tokens in string
-wn weld nested: combines opening and closing tokens when both are adjacent
+ -wnxl=s weld nested exclusion list: provides some control over the types of
+ containers which can be welded
Following Old Breakpoints
-kis keep interior semicolons. Allows multiple statements per line.
EOF
return;
-}
+} ## end sub usage
sub process_this_file {
$formatter->write_line($line);
}
my $severe_error = $tokenizer->report_tokenization_errors();
- eval { $formatter->finish_formatting($severe_error) };
-
- return;
-}
-
-sub check_syntax {
-
- # Use 'perl -c' to make sure that we did not create bad syntax
- # This is a very good independent check for programming errors
- #
- # Given names of the input and output files, ($istream, $ostream),
- # we do the following:
- # - check syntax of the input file
- # - if bad, all done (could be an incomplete code snippet)
- # - if infile syntax ok, then check syntax of the output file;
- # - if outfile syntax bad, issue warning; this implies a code bug!
- # - set and return flag "infile_syntax_ok" : =-1 bad 0 unknown 1 good
-
- my ( $istream, $ostream, $logger_object, $rOpts ) = @_;
- my $infile_syntax_ok = 0;
- my $line_of_dashes = '-' x 42 . "\n";
-
- my $flags = $rOpts->{'perl-syntax-check-flags'};
-
- # be sure we invoke perl with -c
- # note: perl will accept repeated flags like '-c -c'. It is safest
- # to append another -c than try to find an interior bundled c, as
- # in -Tc, because such a 'c' might be in a quoted string, for example.
- if ( $flags !~ /(^-c|\s+-c)/ ) { $flags .= " -c" }
-
- # be sure we invoke perl with -x if requested
- # same comments about repeated parameters applies
- if ( $rOpts->{'look-for-hash-bang'} ) {
- if ( $flags !~ /(^-x|\s+-x)/ ) { $flags .= " -x" }
- }
-
- # this shouldn't happen unless a temporary file couldn't be made
- if ( $istream eq '-' ) {
- $logger_object->write_logfile_entry(
- "Cannot run perl -c on STDIN and STDOUT\n");
- return $infile_syntax_ok;
- }
-
- $logger_object->write_logfile_entry(
- "checking input file syntax with perl $flags\n");
-
- # Not all operating systems/shells support redirection of the standard
- # error output.
- my $error_redirection = ( $^O eq 'VMS' ) ? "" : '2>&1';
-
- my ( $istream_filename, $perl_output ) =
- do_syntax_check( $istream, $flags, $error_redirection );
- $logger_object->write_logfile_entry(
- "Input stream passed to Perl as file $istream_filename\n");
- $logger_object->write_logfile_entry($line_of_dashes);
- $logger_object->write_logfile_entry("$perl_output\n");
-
- if ( $perl_output =~ /syntax\s*OK/ ) {
- $infile_syntax_ok = 1;
- $logger_object->write_logfile_entry($line_of_dashes);
- $logger_object->write_logfile_entry(
- "checking output file syntax with perl $flags ...\n");
- my ( $ostream_filename, $perl_output ) =
- do_syntax_check( $ostream, $flags, $error_redirection );
- $logger_object->write_logfile_entry(
- "Output stream passed to Perl as file $ostream_filename\n");
- $logger_object->write_logfile_entry($line_of_dashes);
- $logger_object->write_logfile_entry("$perl_output\n");
-
- unless ( $perl_output =~ /syntax\s*OK/ ) {
- $logger_object->write_logfile_entry($line_of_dashes);
- $logger_object->warning(
-"The output file has a syntax error when tested with perl $flags $ostream !\n"
- );
- $logger_object->warning(
- "This implies an error in perltidy; the file $ostream is bad\n"
- );
- $logger_object->report_definite_bug();
- # the perl version number will be helpful for diagnosing the problem
- $logger_object->write_logfile_entry( $^V . "\n" );
- }
- }
- else {
+ # user-defined formatters are possible, and may not have a
+ # sub 'finish_formatting', so we have to check
+ $formatter->finish_formatting($severe_error)
+ if $formatter->can('finish_formatting');
- # Only warn of perl -c syntax errors. Other messages,
- # such as missing modules, are too common. They can be
- # seen by running with perltidy -w
- $logger_object->complain("A syntax check using perl $flags\n");
- $logger_object->complain(
- "for the output in file $istream_filename gives:\n");
- $logger_object->complain($line_of_dashes);
- $logger_object->complain("$perl_output\n");
- $logger_object->complain($line_of_dashes);
- $infile_syntax_ok = -1;
- $logger_object->write_logfile_entry($line_of_dashes);
- $logger_object->write_logfile_entry(
-"The output file will not be checked because of input file problems\n"
- );
- }
- return $infile_syntax_ok;
-}
-
-sub do_syntax_check {
-
- # This should not be called; the syntax check is deactivated
- Die("Unexpected call for syntax check-shouldn't happen\n");
return;
-}
-
-=pod
-sub do_syntax_check {
- my ( $stream, $flags, $error_redirection ) = @_;
-
- ############################################################
- # This code is not reachable because syntax check is deactivated,
- # but it is retained for reference.
- ############################################################
-
- # We need a named input file for executing perl
- my ( $stream_filename, $is_tmpfile ) = get_stream_as_named_file($stream);
-
- # TODO: Need to add name of file to log somewhere
- # otherwise Perl output is hard to read
- if ( !$stream_filename ) { return $stream_filename, "" }
-
- # We have to quote the filename in case it has unusual characters
- # or spaces. Example: this filename #CM11.pm# gives trouble.
- my $quoted_stream_filename = '"' . $stream_filename . '"';
-
- # Under VMS something like -T will become -t (and an error) so we
- # will put quotes around the flags. Double quotes seem to work on
- # Unix/Windows/VMS, but this may not work on all systems. (Single
- # quotes do not work under Windows). It could become necessary to
- # put double quotes around each flag, such as: -"c" -"T"
- # We may eventually need some system-dependent coding here.
- $flags = '"' . $flags . '"';
-
- # now wish for luck...
- my $msg = qx/perl $flags $quoted_stream_filename $error_redirection/;
-
- if ($is_tmpfile) {
- unlink $stream_filename
- or Perl::Tidy::Die("couldn't unlink stream $stream_filename: $!\n");
- }
- return $stream_filename, $msg;
-}
-=cut
-
+} ## end sub process_this_file
1;
-
projects / perltidy.git / blobdiff