#
# perltidy - a perl script indenter and formatter
#
-# Copyright (c) 2000-2021 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;
-# this can be turned on for extra checking during development
-use constant DEVEL_MODE => 0;
+# DEVEL_MODE can be turned on for extra checking during development
+use constant DEVEL_MODE => 0;
+use constant EMPTY_STRING => q{};
+use constant SPACE => q{ };
use vars qw{
$VERSION
# Release version must be bumped, and it is probably past time for a
# release anyway.
- $VERSION = '20210717';
+ $VERSION = '20220613';
}
sub DESTROY {
======================================================================
EOM
exit 1;
-}
+} ## end sub AUTOLOAD
sub streamhandle {
$New = sub { undef };
confess <<EOM;
------------------------------------------------------------------------
-No 'getline' method is defined for object of class $ref
+No 'getline' method is defined for object of class '$ref'
Please check your call to Perl::Tidy::perltidy. Trace follows.
------------------------------------------------------------------------
EOM
$New = sub { undef };
confess <<EOM;
------------------------------------------------------------------------
-No 'print' method is defined for object of class $ref
+No 'print' method is defined for object of class '$ref'
Please check your call to Perl::Tidy::perltidy. Trace follows.
------------------------------------------------------------------------
EOM
$fh = $New->( $filename, $mode );
if ( !$fh ) {
- Warn("Couldn't open file:$filename in mode:$mode : $!\n");
+ Warn("Couldn't open file:$filename in mode:$mode : $ERRNO\n");
}
else {
elsif ( $filename eq '-' ) {
binmode STDOUT, ":raw:encoding(UTF-8)";
}
+ else {
+ # shouldn't happen
+ }
}
# Case 2: handle unencoded data
else {
if ( ref($fh) eq 'IO::File' ) { binmode $fh }
elsif ( $filename eq '-' ) { binmode STDOUT }
+ else { } # shouldn't happen
}
}
return $fh, ( $ref or $filename );
-}
+} ## end sub streamhandle
sub find_input_line_ending {
binmode $fh;
my $buf;
read( $fh, $buf, 1024 );
- close $fh;
+ close $fh || return $ending;
if ( $buf && $buf =~ /([\012\015]+)/ ) {
my $test = $1;
else { }
return $ending;
-}
+} ## end sub find_input_line_ending
{ ## begin closure for sub catfile
BEGIN {
eval { require File::Spec };
- $missing_file_spec = $@;
+ $missing_file_spec = $EVAL_ERROR;
}
sub catfile {
my $test_file = $path . $name;
my ( $test_name, $test_path ) = fileparse($test_file);
return $test_file if ( $test_name eq $name );
- return if ( $^O eq 'VMS' );
+ return if ( $OSNAME eq 'VMS' );
# this should work at least for Windows and Unix:
$test_file = $path . '/' . $name;
( $test_name, $test_path ) = fileparse($test_file);
return $test_file if ( $test_name eq $name );
return;
- }
+ } ## end sub catfile
} ## end closure for sub catfile
# Here is a map of the flow of data from the input source to the output
# Output Warn message and bump Warn count
sub Warn { my $msg = shift; $fh_stderr->print($msg); $Warn_count++; return }
+sub is_char_mode {
+
+ my ($string) = @_;
+
+ # Returns:
+ # true if $string is in Perl's internal character mode
+ # (also called the 'upgraded form', or UTF8=1)
+ # false if $string is in Perl's internal byte mode
+
+ # This function isolates the call to Perl's internal function
+ # utf8::is_utf8() which is true for strings represented in an 'upgraded
+ # form'. It is available after Perl version 5.8.
+ # See https://perldoc.perl.org/Encode.
+ # See also comments in Carp.pm and other modules using this function
+
+ return 1 if ( utf8::is_utf8($string) );
+ return;
+} ## end sub is_char_mode
+
sub perltidy {
my %input_hash = @_;
postfilter => undef,
);
+ # Status information which can be returned for diagnostic purposes.
+ # This is intended for testing and subject to change.
+
+ # List of "key => value" hash entries:
+
+ # Some relevant user input parameters for convenience:
+ # opt_format => value of --format: 'tidy', 'html', or 'user'
+ # opt_encoding => value of -enc flag: 'utf8', 'none', or 'guess'
+ # opt_encode_output => value of -eos flag: 'eos' or 'neos'
+ # opt_max_iterations => value of --iterations=n
+
+ # file_count => number of files processed in this call
+
+ # If multiple files are processed, then the following values will be for
+ # the last file only:
+
+ # input_name => name of the input stream
+ # output_name => name of the output stream
+
+ # The following two variables refer to Perl's two internal string modes,
+ # and have the values 0 for 'byte' mode and 1 for 'char' mode:
+ # char_mode_source => true if source is in 'char' mode. Will be false
+ # unless we received a source string ref with utf8::is_utf8() set.
+ # char_mode_used => true if text processed by perltidy in 'char' mode.
+ # Normally true for text identified as utf8, otherwise false.
+
+ # This tells if Unicode::GCString was used
+ # gcs_used => true if -gcs and Unicode::GCString found & used
+
+ # These variables tell what utf8 decoding/encoding was done:
+ # input_decoded_as => non-blank if perltidy decoded the source text
+ # output_encoded_as => non-blank if perltidy encoded before return
+
+ # These variables are related to iterations and convergence testing:
+ # iteration_count => number of iterations done
+ # ( can be from 1 to opt_max_iterations )
+ # converged => true if stopped on convergence
+ # ( can only happen if opt_max_iterations > 1 )
+ # blinking => true if stopped on blinking states
+ # ( i.e., unstable formatting, should not happen )
+
+ my $rstatus = {
+
+ file_count => 0,
+ opt_format => EMPTY_STRING,
+ opt_encoding => EMPTY_STRING,
+ opt_encode_output => EMPTY_STRING,
+ opt_max_iterations => EMPTY_STRING,
+
+ input_name => EMPTY_STRING,
+ output_name => EMPTY_STRING,
+ char_mode_source => 0,
+ char_mode_used => 0,
+ input_decoded_as => EMPTY_STRING,
+ output_encoded_as => EMPTY_STRING,
+ gcs_used => 0,
+ iteration_count => 0,
+ converged => 0,
+ blinking => 0,
+ };
+
# Fix for issue git #57
$Warn_count = 0;
local *STDERR = *STDERR;
if ( my @bad_keys = grep { !exists $defaults{$_} } keys %input_hash ) {
- local $" = ')(';
+ local $LIST_SEPARATOR = ')(';
my @good_keys = sort keys %defaults;
@bad_keys = sort @bad_keys;
confess <<EOM;
unless ( defined($dump_options_type) ) {
$dump_options_type = 'perltidyrc';
}
- unless ( $dump_options_type =~ /^(perltidyrc|full)$/ ) {
+ if ( $dump_options_type ne 'perltidyrc'
+ && $dump_options_type ne 'full' )
+ {
croak <<EOM;
------------------------------------------------------------------------
Please check value of -dump_options_type in call to perltidy;
}
}
else {
- $dump_options_type = "";
+ $dump_options_type = EMPTY_STRING;
}
if ($user_formatter) {
# string
else {
- my ( $rargv, $msg ) = parse_args($argv);
+ my ( $rargv_str, $msg ) = parse_args($argv);
if ($msg) {
Die(<<EOM);
Error parsing this string passed to to perltidy with 'argv':
$msg
EOM
}
- @ARGV = @{$rargv};
+ @ARGV = @{$rargv_str};
}
}
my $rpending_complaint;
- ${$rpending_complaint} = "";
+ ${$rpending_complaint} = EMPTY_STRING;
my $rpending_logfile_message;
- ${$rpending_logfile_message} = "";
+ ${$rpending_logfile_message} = EMPTY_STRING;
my ( $is_Windows, $Windows_type ) = look_for_Windows($rpending_complaint);
# instead of .tdy, etc. (but see also sub check_vms_filename)
my $dot;
my $dot_pattern;
- if ( $^O eq 'VMS' ) {
+ if ( $OSNAME eq 'VMS' ) {
$dot = '_';
$dot_pattern = '_';
}
$rpending_complaint, $dump_options_type,
);
- my $saw_extrude = ( grep { m/^-extrude$/ } @{$rraw_options} ) ? 1 : 0;
my $saw_pbp =
- ( grep { m/^-(pbp|perl-best-practices)$/ } @{$rraw_options} ) ? 1 : 0;
+ grep { $_ eq '-pbp' || $_ eq '-perl-best-practices' } @{$rraw_options};
#---------------------------------------------------------------
# Handle requests to dump information
$quit_now = 1;
foreach my $op ( @{$roption_string} ) {
my $opt = $op;
- my $flag = "";
+ my $flag = EMPTY_STRING;
# Examples:
# some-option=s
my %default_file_extension = (
tidy => 'tdy',
html => 'html',
- user => '',
+ user => EMPTY_STRING,
);
+ $rstatus->{'opt_format'} = $rOpts->{'format'};
+ $rstatus->{'opt_max_iterations'} = $rOpts->{'iterations'};
+ $rstatus->{'opt_encode_output'} =
+ $rOpts->{'encode-output-strings'} ? 'eos' : 'neos';
+
# be sure we have a valid output format
unless ( exists $default_file_extension{ $rOpts->{'format'} } ) {
- my $formats = join ' ',
+ my $formats = join SPACE,
sort map { "'" . $_ . "'" } keys %default_file_extension;
my $fmt = $rOpts->{'format'};
Die("-format='$fmt' but must be one of: $formats\n");
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);
}
my $dh;
if ( opendir( $dh, './' ) ) {
my @files =
- grep { /$pattern/ && !-d $_ } readdir($dh);
+ grep { /$pattern/ && !-d } readdir($dh);
+ ##grep { /$pattern/ && !-d $_ } readdir($dh);
closedir($dh);
if (@files) {
unshift @ARGV, @files;
$fileroot = $input_file;
@input_file_stat = stat($input_file);
- if ( $^O eq 'VMS' ) {
+ if ( $OSNAME eq 'VMS' ) {
( $fileroot, $dot ) = check_vms_filename($fileroot);
}
my $new_path = $rOpts->{'output-path'};
unless ( -d $new_path ) {
unless ( mkdir $new_path, 0777 ) {
- Die("unable to create directory $new_path: $!\n");
+ Die("unable to create directory $new_path: $ERRNO\n");
}
}
my $path = $new_path;
my %saw_md5;
my $digest_input = 0;
- my $buf = '';
+ my $buf = EMPTY_STRING;
while ( my $line = $source_object->get_line() ) {
$buf .= $line;
}
my $remove_terminal_newline =
!$rOpts->{'add-terminal-newline'} && substr( $buf, -1, 1 ) !~ /\n/;
- # Decode the input stream if necessary requested
- my $encoding_in = "";
+ # Decode the input stream if necessary or requested
+ my $encoding_in = EMPTY_STRING;
my $rOpts_character_encoding = $rOpts->{'character-encoding'};
my $encoding_log_message;
-
- # Case 1. See if we already have an encoded string. In that
- # case, we have to ignore any encoding flag.
- if ( utf8::is_utf8($buf) ) {
+ my $decoded_input_as = EMPTY_STRING;
+ $rstatus->{'char_mode_source'} = 0;
+
+ # Case 1: If Perl is already in a character-oriented mode for this
+ # string rather than a byte-oriented mode. Normally, this happens if
+ # the caller has decoded a utf8 string before calling perltidy. But it
+ # could also happen if the user has done some unusual manipulations of
+ # the source. In any case, we will not attempt to decode it because
+ # that could result in an output string in a different mode.
+ if ( is_char_mode($buf) ) {
$encoding_in = "utf8";
+ $rstatus->{'char_mode_source'} = 1;
}
# Case 2. No input stream encoding requested. This is appropriate
}
# Case 3. guess input stream encoding if requested
- elsif ( $rOpts_character_encoding =~ /^guess$/i ) {
+ elsif ( lc($rOpts_character_encoding) eq 'guess' ) {
# The guessing strategy is simple: use Encode::Guess to guess
# an encoding. If and only if the guess is utf8, try decoding and
my $decoder = guess_encoding( $buf_in, 'utf8' );
if ( ref($decoder) ) {
$encoding_in = $decoder->name;
- if ( $encoding_in !~ /^(UTF-8|utf8)$/ ) {
- $encoding_in = "";
+ if ( $encoding_in ne 'UTF-8' && $encoding_in ne 'utf8' ) {
+ $encoding_in = EMPTY_STRING;
$buf = $buf_in;
$encoding_log_message .= <<EOM;
Guessed encoding '$encoding_in' is not utf8; no encoding will be used
else {
eval { $buf = $decoder->decode($buf_in); };
- if ($@) {
+ if ($EVAL_ERROR) {
$encoding_log_message .= <<EOM;
Guessed encoding '$encoding_in' but decoding was unsuccessful; no encoding is used
Warn(
"file: $input_file: bad guess to decode source as $encoding_in\n"
);
- $encoding_in = "";
+ $encoding_in = EMPTY_STRING;
$buf = $buf_in;
}
else {
$encoding_log_message .= <<EOM;
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
+ }
}
# Case 4. Decode with a specific encoding
$buf = Encode::decode( $encoding_in, $buf,
Encode::FB_CROAK | Encode::LEAVE_SRC );
};
- if ($@) {
+ if ($EVAL_ERROR) {
# Quit if we cannot decode by the requested encoding;
# Something is not right.
$encoding_log_message .= <<EOM;
Specified encoding '$encoding_in' successfully decoded
EOM
+ $decoded_input_as = $encoding_in;
}
}
# read and write it as encoded data, and we will normalize these
# operations with utf8. If we have not decoded the data, then
# we must not treat it as encoded data.
- my $is_encoded_data = $encoding_in ? 'utf8' : "";
+ my $is_encoded_data = $encoding_in ? 'utf8' : EMPTY_STRING;
- # Define the function to determine the display width of character strings
+ $rstatus->{'input_name'} = $display_name;
+ $rstatus->{'opt_encoding'} = $rOpts_character_encoding;
+ $rstatus->{'char_mode_used'} = $encoding_in ? 1 : 0;
+ $rstatus->{'input_decoded_as'} = $decoded_input_as;
+
+ # Define the function to determine the display width of character
+ # strings
my $length_function = sub { return length( $_[0] ) };
if ($is_encoded_data) {
# requested, when the first encoded file is encountered
if ( !defined($loaded_unicode_gcstring) ) {
eval { require Unicode::GCString };
- $loaded_unicode_gcstring = !$@;
- if ( $@ && $rOpts->{'use-unicode-gcstring'} ) {
+ $loaded_unicode_gcstring = !$EVAL_ERROR;
+ if ( $EVAL_ERROR && $rOpts->{'use-unicode-gcstring'} ) {
Warn(<<EOM);
----------------------
-Unable to load Unicode::GCString: $@
+Unable to load Unicode::GCString: $EVAL_ERROR
Processing continues but some vertical alignment may be poor
To prevent this warning message, you can either:
- install module Unicode::GCString, or
$length_function = sub {
return Unicode::GCString->new( $_[0] )->columns;
};
+ $encoding_log_message .= <<EOM;
+Using 'Unicode::GCString' to measure horizontal character widths
+EOM
+ $rstatus->{'gcs_used'} = 1;
}
}
# prepare the output stream
#---------------------------------------------------------------
my $output_file = undef;
+ my $output_name = EMPTY_STRING;
my $actual_output_extension;
if ( $rOpts->{'outfile'} ) {
Die("You may not specify -o and -oext together\n");
}
$output_file = $rOpts->{outfile};
+ $output_name = $output_file;
# make sure user gives a file name after -o
if ( $output_file =~ /^-/ ) {
Die("$msg\n");
}
$output_file = '-';
+ $output_name = "<stdout>";
if ( $number_of_files <= 1 ) {
}
}
}
elsif ($destination_stream) {
+
$output_file = $destination_stream;
+ $output_name = "<destination_stream>";
}
elsif ($source_stream) { # source but no destination goes to stdout
$output_file = '-';
+ $output_name = "<stdout>";
}
elsif ( $input_file eq '-' ) {
$output_file = '-';
+ $output_name = "<stdout>";
}
else {
if ($in_place_modify) {
$output_file = IO::File->new_tmpfile()
- or Die("cannot open temp file for -b option: $!\n");
+ or Die("cannot open temp file for -b option: $ERRNO\n");
+ $output_name = $display_name;
}
else {
$actual_output_extension = $output_extension;
$output_file = $fileroot . $output_extension;
+ $output_name = $output_file;
}
}
+ $rstatus->{'file_count'} += 1;
+ $rstatus->{'output_name'} = $output_name;
+ $rstatus->{'iteration_count'} = 0;
+ $rstatus->{'converged'} = 0;
+
my $fh_tee;
my $tee_file = $fileroot . $dot . "TEE";
if ($teefile_stream) { $tee_file = $teefile_stream }
( $fh_tee, my $tee_filename ) =
Perl::Tidy::streamhandle( $tee_file, 'w', $is_encoded_data );
if ( !$fh_tee ) {
- Warn("couldn't open TEE file $tee_file: $!\n");
+ Warn("couldn't open TEE file $tee_file: $ERRNO\n");
}
}
|| $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,
log_file => $log_file,
warning_file => $warning_file,
fh_stderr => $fh_stderr,
- saw_extruce => $saw_extrude,
display_name => $display_name,
is_encoded_data => $is_encoded_data,
);
foreach my $iter ( 1 .. $max_iterations ) {
+ $rstatus->{'iteration_count'} += 1;
+
# send output stream to temp buffers until last iteration
my $sink_buffer;
if ( $iter < $max_iterations ) {
{
if ( $formatter->get_convergence_check() ) {
$iteration_of_formatter_convergence = $iter;
+ $rstatus->{'converged'} = 1;
}
}
# with extreme parameter values, such as very short
# maximum line lengths. We want to catch and fix
# them when they happen.
+ $rstatus->{'blinking'} = 1;
$convergence_log_message = <<EOM;
BLINKER. Output for iteration $iter same as for $saw_md5{$digest}.
EOM
$diagnostics_object->write_diagnostics(
$convergence_log_message)
if $diagnostics_object && $iterm > 2;
+ $rstatus->{'converged'} = 1;
}
}
} ## end if ($do_convergence_test)
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
is_encoded_data => $is_encoded_data,
);
- my $buf =
+ my $buf_post =
$postfilter
? $postfilter->($postfilter_buffer)
: $postfilter_buffer;
# Check if file changed if requested, but only after any postfilter
if ( $rOpts->{'assert-tidy'} ) {
- my $digest_output = $md5_hex->($buf);
+ my $digest_output = $md5_hex->($buf_post);
if ( $digest_output ne $digest_input ) {
my $diff_msg =
- compare_string_buffers( $saved_input_buf, $buf,
+ compare_string_buffers( $saved_input_buf, $buf_post,
$is_encoded_data );
$logger_object->warning(<<EOM);
assertion failure: '--assert-tidy' is set but output differs from input
}
}
if ( $rOpts->{'assert-untidy'} ) {
- my $digest_output = $md5_hex->($buf);
+ my $digest_output = $md5_hex->($buf_post);
if ( $digest_output eq $digest_input ) {
$logger_object->warning(
"assertion failure: '--assert-untidy' is set but output equals input\n"
}
$source_object = Perl::Tidy::LineSource->new(
- input_file => \$buf,
+ input_file => \$buf_post,
rOpts => $rOpts,
rpending_logfile_message => $rpending_logfile_message,
);
$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");
+ or
+ Die("unable to rewind a temporary file for -b option: $ERRNO\n");
my ( $fout, $iname ) =
Perl::Tidy::streamhandle( $input_file, 'w', $is_encoded_data );
if ( !$fout ) {
Die(
-"problem re-opening $input_file for write for -b option; check file and directory permissions: $!\n"
+"problem re-opening $input_file for write for -b option; check file and directory permissions: $ERRNO\n"
);
}
}
}
- #---------------------------------------------------------------
- # Do syntax check if requested and possible
- # This is permanently deactivated but the code remains for reference
- #---------------------------------------------------------------
- my $infile_syntax_ok = 0; # -1 no 0=don't know 1 yes
- if ( 0
- && $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
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
NORMAL_EXIT:
my $ret = $Warn_count ? 2 : 0;
- return $ret;
+ return wantarray ? ( $ret, $rstatus ) : $ret;
ERROR_EXIT:
- return 1;
-} ## end of main program perltidy
+ return wantarray ? ( 1, $rstatus ) : 1;
+
+} ## end sub perltidy
} ## end of closure for sub perltidy
sub line_diff {
# have same common characters so non-null characters indicate character
# differences.
my ( $s1, $s2 ) = @_;
- my $diff_marker = "";
+ my $diff_marker = EMPTY_STRING;
my $pos = -1;
my $pos1 = $pos;
if ( defined($s1) && defined($s2) ) {
while ( $mask =~ /[^\0]/g ) {
$count++;
my $pos_last = $pos;
- $pos = $-[0];
+ $pos = $LAST_MATCH_START[0];
if ( $count == 1 ) { $pos1 = $pos; }
- $diff_marker .= ' ' x ( $pos - $pos_last - 1 ) . '^';
+ $diff_marker .= SPACE x ( $pos - $pos_last - 1 ) . '^';
# we could continue to mark all differences, but there is no point
last;
}
}
return wantarray ? ( $diff_marker, $pos1 ) : $diff_marker;
-}
+} ## end sub line_diff
sub compare_string_buffers {
my ( $fhi, $fnamei ) = streamhandle( \$bufi, 'r', $is_encoded_data );
my ( $fho, $fnameo ) = streamhandle( \$bufo, 'r', $is_encoded_data );
return $msg unless ( $fho && $fhi ); # for safety, shouldn't happen
- my ( $linei, $lineo );
- my ( $counti, $counto ) = ( 0, 0 );
- my ( $last_nonblank_line, $last_nonblank_count ) = ( "", 0 );
+ my ( $linei, $lineo );
+ my ( $counti, $counto ) = ( 0, 0 );
+ my ( $last_nonblank_line, $last_nonblank_count ) = ( EMPTY_STRING, 0 );
my $truncate = sub {
my ( $str, $lenmax ) = @_;
if ( length($str) > $lenmax ) {
my ( $line_diff, $pos1 ) = line_diff( $linei, $lineo );
my $reason = "Files first differ at character $pos1 of line $counti";
- my ( $leading_ws_i, $leading_ws_o ) = ( "", "" );
+ my ( $leading_ws_i, $leading_ws_o ) = ( EMPTY_STRING, EMPTY_STRING );
if ( $linei =~ /^(\s+)/ ) { $leading_ws_i = $1; }
if ( $lineo =~ /^(\s+)/ ) { $leading_ws_o = $1; }
if ( $leading_ws_i ne $leading_ws_o ) {
}
}
else {
- my ( $trailing_ws_i, $trailing_ws_o ) = ( "", "" );
+ my ( $trailing_ws_i, $trailing_ws_o ) =
+ ( EMPTY_STRING, EMPTY_STRING );
if ( $linei =~ /(\s+)$/ ) { $trailing_ws_i = $1; }
if ( $lineo =~ /(\s+)$/ ) { $trailing_ws_o = $1; }
if ( $trailing_ws_i ne $trailing_ws_o ) {
# limit string display length
if ( $pos1 > 60 ) {
my $drop = $pos1 - 40;
- $linei = "..." . substr( $linei, $drop );
- $lineo = "..." . substr( $lineo, $drop );
- $line_diff = " " . substr( $line_diff, $drop );
+ $linei = "..." . substr( $linei, $drop );
+ $lineo = "..." . substr( $lineo, $drop );
+ $line_diff = SPACE x 3 . substr( $line_diff, $drop );
}
$linei = $truncate->( $linei, 72 );
$lineo = $truncate->( $lineo, 72 );
$last_nonblank_count:$last_nonblank_line
EOM
}
- $line_diff = ' ' x ( 2 + length($counto) ) . $line_diff;
+ $line_diff = SPACE x ( 2 + length($counto) ) . $line_diff;
$msg .= <<EOM;
<$counti:$linei
>$counto:$lineo
EOM
}
return $msg;
-}
+} ## end sub compare_string_buffers
sub get_stream_as_named_file {
# $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->( '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->( 'extended-continuation-indentation', 'xci', '!' );
- $add_option->( 'line-up-parentheses', 'lp', '!' );
- $add_option->( 'line-up-parentheses-exclusion-list', 'lpxl', '=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->( '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->( '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->( '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->( 'dump-want-left-space', 'dwls', '!' );
$add_option->( 'dump-want-right-space', 'dwrs', '!' );
$add_option->( 'fuzzy-line-length', 'fll', '!' );
- $add_option->( 'help', 'h', '' );
+ $add_option->( 'help', 'h', EMPTY_STRING );
$add_option->( 'short-concatenation-item-length', 'scl', '=i' );
$add_option->( 'show-options', 'opt', '!' );
$add_option->( 'timestamp', 'ts', '!' );
- $add_option->( 'version', 'v', '' );
+ $add_option->( 'version', 'v', EMPTY_STRING );
$add_option->( 'memoize', 'mem', '!' );
$add_option->( 'file-size-order', 'fso', '!' );
$add_option->( 'maximum-file-size-mb', 'maxfs', '=i' );
'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.
#---------------------------------------------------------------
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
delete-old-newlines
delete-semicolons
extended-syntax
+ encode-output-strings
function-paren-vertical-alignment
fuzzy-line-length
hanging-side-comments
noweld-nested-containers
recombine
nouse-unicode-gcstring
- valign
+ valign-code
+ valign-block-comments
+ valign-side-comments
short-concatenation-item-length=8
space-for-semicolon
space-backslash-quote=1
'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)],
'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# ],
\%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->{$key} = 100;
}
}
+ return;
};
# check for reasonable number of blank lines and fix to avoid problems
}
}
- # -bli flag implies -bl
- if ( $rOpts->{'brace-left-and-indent'} ) {
- $rOpts->{'opening-brace-on-new-line'} = 1;
- }
-
# it simplifies things if -bl is 0 rather than undefined
if ( !defined( $rOpts->{'opening-brace-on-new-line'} ) ) {
$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
}
}
}
- my $joined_words = join ' ', @filtered_word_list;
- $rOpts->{'sub-alias-list'} = join ' ', @filtered_word_list;
+ $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'} ) {
: $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
# If $os is undefined, the above code is out of date. Suggested updates
# are welcome.
unless ( defined $os ) {
- $os = "";
+ $os = EMPTY_STRING;
# Deactivated this message 20180322 because it was needlessly
# causing some test scripts to fail. Need help from someone
# Unfortunately the logic used for the various versions isn't so clever..
# so we have to handle an outside case.
return ( $os eq "2000" && $major != 5 ) ? "NT4" : $os;
-}
+} ## end sub Win_OS_Type
sub is_unix {
return
- ( $^O !~ /win32|dos/i )
- && ( $^O ne 'VMS' )
- && ( $^O ne 'OS2' )
- && ( $^O ne 'MacOS' );
+ ( $OSNAME !~ /win32|dos/i )
+ && ( $OSNAME ne 'VMS' )
+ && ( $OSNAME ne 'OS2' )
+ && ( $OSNAME ne 'MacOS' );
}
sub look_for_Windows {
# determine Windows sub-type and location of
# system-wide configuration files
my $rpending_complaint = shift;
- my $is_Windows = ( $^O =~ /win32|dos/i );
+ my $is_Windows = ( $OSNAME =~ /win32|dos/i );
my $Windows_type;
$Windows_type = Win_OS_Type($rpending_complaint) if $is_Windows;
return ( $is_Windows, $Windows_type );
-}
+} ## end sub look_for_Windows
sub find_config_file {
${$rconfig_file_chatter} .= "Windows $Windows_type\n";
}
else {
- ${$rconfig_file_chatter} .= " $^O\n";
+ ${$rconfig_file_chatter} .= " $OSNAME\n";
}
# sub to check file existence and record all tests
# Check the NT/2k/XP locations, first a local machine def, then a
# network def
- push @envs, qw(USERPROFILE HOMESHARE) if $^O =~ /win32/i;
+ push @envs, qw(USERPROFILE HOMESHARE) if $OSNAME =~ /win32/i;
# Now go through the environment ...
foreach my $var (@envs) {
}
# Place to add customization code for other systems
- elsif ( $^O eq 'OS2' ) {
+ elsif ( $OSNAME eq 'OS2' ) {
}
- elsif ( $^O eq 'MacOS' ) {
+ elsif ( $OSNAME eq 'MacOS' ) {
}
- elsif ( $^O eq 'VMS' ) {
+ elsif ( $OSNAME eq 'VMS' ) {
}
# Assume some kind of Unix
# Couldn't find a config file
return;
-}
+} ## end sub find_config_file
sub Win_Config_Locs {
return unless $os;
- my $system = "";
- my $allusers = "";
+ my $system = EMPTY_STRING;
+ my $allusers = EMPTY_STRING;
if ( $os =~ /9[58]|Me/ ) {
$system = "C:/Windows";
return;
}
return wantarray ? ( $os, $system, $allusers ) : $os;
-}
+} ## end sub Win_Config_Locs
sub dump_config_file {
my ( $fh, $config_file, $rconfig_file_chatter ) = @_;
print STDOUT "# ...no config file found\n";
}
return;
-}
+} ## end sub dump_config_file
sub read_config_file {
my @config_list = ();
# file is bad if non-empty $death_message is returned
- my $death_message = "";
+ my $death_message = EMPTY_STRING;
my $name = undef;
my $line_no;
$opening_brace_line = $line_no unless ( $body && $body =~ s/\}$// );
# handle a new alias definition
- if ( ${$rexpansion}{$name} ) {
- local $" = ')(';
- my @names = sort keys %$rexpansion;
+ if ( $rexpansion->{$name} ) {
+ local $LIST_SEPARATOR = ')(';
+ my @names = sort keys %{$rexpansion};
$death_message =
"Here is a list of all installed aliases\n(@names)\n"
- . "Attempting to redefine alias ($name) in config file $config_file line $.\n";
+ . "Attempting to redefine alias ($name) in config file $config_file line $INPUT_LINE_NUMBER\n";
last;
}
- ${$rexpansion}{$name} = [];
+ $rexpansion->{$name} = [];
}
# leading opening braces not allowed
# remove leading dashes if this is an alias
foreach ( @{$rbody_parts} ) { s/^\-+//; }
- push @{ ${$rexpansion}{$name} }, @{$rbody_parts};
+ push @{ $rexpansion->{$name} }, @{$rbody_parts};
}
else {
push( @config_list, @{$rbody_parts} );
}
eval { $fh->close() };
return ( \@config_list, $death_message );
-}
+} ## end sub read_config_file
sub strip_comment {
# Strip any comment from a command line
my ( $instr, $config_file, $line_no ) = @_;
- my $msg = "";
+ my $msg = EMPTY_STRING;
# check for full-line comment
if ( $instr =~ /^\s*#/ ) {
- return ( "", $msg );
+ return ( EMPTY_STRING, $msg );
}
# nothing to do if no comments
}
# handle comments and quotes
- my $outstr = "";
- my $quote_char = "";
+ my $outstr = EMPTY_STRING;
+ my $quote_char = EMPTY_STRING;
while (1) {
# looking for ending quote character
if ($quote_char) {
if ( $instr =~ /\G($quote_char)/gc ) {
- $quote_char = "";
+ $quote_char = EMPTY_STRING;
$outstr .= $1;
}
elsif ( $instr =~ /\G(.)/gc ) {
}
}
return ( $outstr, $msg );
-}
+} ## end sub strip_comment
sub parse_args {
my ($body) = @_;
my @body_parts = ();
- my $quote_char = "";
- my $part = "";
- my $msg = "";
+ my $quote_char = EMPTY_STRING;
+ my $part = EMPTY_STRING;
+ my $msg = EMPTY_STRING;
+
+ # Check for external call with undefined $body - added to fix
+ # github issue Perl-Tidy-Sweetened issue #23
+ if ( !defined($body) ) { $body = EMPTY_STRING }
+
while (1) {
# looking for ending quote character
if ($quote_char) {
if ( $body =~ /\G($quote_char)/gc ) {
- $quote_char = "";
+ $quote_char = EMPTY_STRING;
}
elsif ( $body =~ /\G(.)/gc ) {
$part .= $1;
}
elsif ( $body =~ /\G(\s+)/gc ) {
if ( length($part) ) { push @body_parts, $part; }
- $part = "";
+ $part = EMPTY_STRING;
}
elsif ( $body =~ /\G(.)/gc ) {
$part .= $1;
}
}
return ( \@body_parts, $msg );
-}
+} ## end sub parse_args
sub dump_long_names {
foreach my $name ( sort @names ) { print STDOUT "$name\n" }
return;
-}
+} ## end sub dump_long_names
sub dump_defaults {
my @defaults = @_;
$readable_options .=
"# See utility 'perltidyrc_dump.pl' for nicer formatting.\n";
foreach my $opt ( @{$roption_string} ) {
- my $flag = "";
+ my $flag = EMPTY_STRING;
if ( $opt =~ /(.*)(!|=.*)$/ ) {
$opt = $1;
$flag = $2;
my $flag = $rGetopt_flags->{$key};
my $value = $rOpts->{$key};
my $prefix = '--';
- my $suffix = "";
+ my $suffix = EMPTY_STRING;
if ($flag) {
if ( $flag =~ /^=/ ) {
if ( $value !~ /^\d+$/ ) { $value = '"' . $value . '"' }
$readable_options .= $prefix . $key . $suffix . "\n";
}
return $readable_options;
-}
+} ## end sub readable_options
sub show_version {
print STDOUT <<"EOM";
This is perltidy, v$VERSION
-Copyright 2000-2021, 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
EOF
return;
-}
+} ## end sub usage
sub process_this_file {
if $formatter->can('finish_formatting');
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 {
-
- # 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;
-}
-
+} ## end sub process_this_file
1;
projects / perltidy.git / blobdiff