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;
$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 {
binmode $fh;
my $buf;
read( $fh, $buf, 1024 );
- close $fh;
+ close $fh || return $ending;
if ( $buf && $buf =~ /([\012\015]+)/ ) {
my $test = $1;
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;
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;
# 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 = '_';
}
$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;
}
# Case 3. guess input stream encoding if requested
- elsif ($rOpts_character_encoding eq 'guess'
- || $rOpts_character_encoding eq 'GUESS' )
- {
+ 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
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
$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.
# 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
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 {
( $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");
}
}
Encode::encode( "UTF-8", $destination_buffer,
Encode::FB_CROAK | Encode::LEAVE_SRC );
};
- if ($@) {
+ if ($EVAL_ERROR) {
Warn(
"Error attempting to encode output string ref; encoding not done\n"
if ( -f $backup_name ) {
unlink($backup_name)
or Die(
-"unable to remove previous '$backup_name' for -b option; check permissions: $!\n"
+"unable to remove previous '$backup_name' for -b option; check permissions: $ERRNO\n"
);
}
# we use copy for symlinks, move for regular files
if ( -l $input_file ) {
File::Copy::copy( $input_file, $backup_name )
- or Die("File::Copy failed trying to backup source: $!");
+ or Die("File::Copy failed trying to backup source: $ERRNO");
}
else {
rename( $input_file, $backup_name )
or Die(
-"problem renaming $input_file to $backup_name for -b option: $!\n"
+"problem renaming $input_file to $backup_name for -b option: $ERRNO\n"
);
}
$ifname = $backup_name;
# handle of an open nameless temporary file so we would lose
# everything if we closed it.
seek( $output_file, 0, 0 )
- or Die("unable to rewind a temporary file for -b option: $!\n");
+ or
+ Die("unable to rewind a temporary file for -b option: $ERRNO\n");
my ( $fout, $iname ) =
Perl::Tidy::streamhandle( $input_file, 'w', $is_encoded_data );
if ( !$fout ) {
Die(
-"problem re-opening $input_file for write for -b option; check file and directory permissions: $!\n"
+"problem re-opening $input_file for write for -b option; check file and directory permissions: $ERRNO\n"
);
}
else {
unlink($ifname)
or Die(
-"unable to remove previous '$ifname' for -b option; check permissions: $!\n"
+"unable to remove previous '$ifname' for -b option; check permissions: $ERRNO\n"
);
}
}
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 ) . '^';
$rraw_options, $Windows_type, $readable_options
) = @_;
$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=$OLD_PERL_VERSION\n"
);
if ($Windows_type) {
$logger_object->write_logfile_entry("Windows type is $Windows_type\n");
# 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 }
}
}
unless ( -e $config_file ) {
- Warn("cannot find file given with -pro=$config_file: $!\n");
+ Warn("cannot find file given with -pro=$config_file: $ERRNO\n");
$config_file = "";
}
}
# 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;
my $rpending_complaint = shift;
my $os = "";
- return $os unless $^O =~ /win32|dos/i; # is it a MS box?
+ 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
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 );
${$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
# handle a new alias definition
if ( $rexpansion->{$name} ) {
- local $" = ')(';
+ 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} = [];
package Perl::Tidy::Debugger;
use strict;
use warnings;
+use English qw( -no_match_vars );
our $VERSION = '20220217.04';
sub new {
my ( $fh, $filename ) =
Perl::Tidy::streamhandle( $debug_file, 'w', $is_encoded_data );
if ( !$fh ) {
- Perl::Tidy::Warn("can't open $debug_file: $!\n");
+ Perl::Tidy::Warn("can't open $debug_file: $ERRNO\n");
}
$self->{_debug_file_opened} = 1;
$self->{_fh} = $fh;
package Perl::Tidy::Diagnostics;
use strict;
use warnings;
+use English qw( -no_match_vars );
our $VERSION = '20220217.04';
sub AUTOLOAD {
unless ( $self->{_write_diagnostics_count} ) {
open( $self->{_fh}, ">", "DIAGNOSTICS" )
- or Perl::Tidy::Die("couldn't open DIAGNOSTICS: $!\n");
+ or Perl::Tidy::Die("couldn't open DIAGNOSTICS: $ERRNO\n");
}
my $fh = $self->{_fh};
{ #<<< A non-indenting brace to contain all lexical variables
use Carp;
+use English qw( -no_match_vars );
our $VERSION = '20220217.04';
# The Tokenizer will be loaded with the Formatter
%is_if_unless_while_until_for_foreach,
%is_last_next_redo_return,
%is_if_unless,
+ %is_if_elsif,
%is_if_unless_elsif,
%is_if_unless_elsif_else,
+ %is_elsif_else,
%is_and_or,
%is_chain_operator,
%is_block_without_semicolon,
%is_opening_sequence_token,
%is_closing_sequence_token,
%is_container_label_type,
+ %is_die_confess_croak_warn,
+ %is_my_our_local,
@all_operators,
use constant WS_NO => -1;
# Token bond strengths.
- use constant NO_BREAK => 10000;
+ use constant NO_BREAK => 10_000;
use constant VERY_STRONG => 100;
use constant STRONG => 2.1;
use constant NOMINAL => 1.1;
@q = qw(if unless);
@is_if_unless{@q} = (1) x scalar(@q);
+ @q = qw(if elsif);
+ @is_if_elsif{@q} = (1) x scalar(@q);
+
@q = qw(if unless elsif);
@is_if_unless_elsif{@q} = (1) x scalar(@q);
@q = qw(if unless elsif else);
@is_if_unless_elsif_else{@q} = (1) x scalar(@q);
+ @q = qw(elsif else);
+ @is_elsif_else{@q} = (1) x scalar(@q);
+
@q = qw(and or err);
@is_and_or{@q} = (1) x scalar(@q);
@q = qw( k => && || ? : . );
@is_container_label_type{@q} = (1) x scalar(@q);
+ @q = qw( die confess croak warn );
+ @is_die_confess_croak_warn{@q} = (1) x scalar(@q);
+
+ @q = qw( my our local );
+ @is_my_our_local{@q} = (1) x scalar(@q);
+
# Braces -bbht etc must follow these. Note: experimentation with
# including a simple comma shows that it adds little and can lead
# to poor formatting in complex lists.
my $error = @unknown_keys;
if ($exact_match) { $error ||= @missing_keys }
if ($error) {
- local $" = ')(';
+ local $LIST_SEPARATOR = ')(';
my @expected_keys = sort keys %{$rvalid};
@unknown_keys = sort @unknown_keys;
Fault(<<EOM);
if ( $rOpts->{'delete-closing-side-comments'} ) {
$rOpts->{'delete-closing-side-comments'} = 0;
$rOpts->{'closing-side-comments'} = 1;
- $rOpts->{'closing-side-comment-interval'} = 100000000;
+ $rOpts->{'closing-side-comment-interval'} = 100_000_000;
}
}
# make -l=0 equal to -l=infinite
if ( !$rOpts->{'maximum-line-length'} ) {
- $rOpts->{'maximum-line-length'} = 1000000;
+ $rOpts->{'maximum-line-length'} = 1_000_000;
}
# make -lbl=0 equal to -lbl=infinite
if ( !$rOpts->{'long-block-line-count'} ) {
- $rOpts->{'long-block-line-count'} = 1000000;
+ $rOpts->{'long-block-line-count'} = 1_000_000;
}
my $ole = $rOpts->{'output-line-ending'};
my %flags = ();
my @list = split_words($str);
if ( DEBUG_KB && @list ) {
- local $" = ' ';
+ local $LIST_SEPARATOR = ' ';
print <<EOM;
DEBUG_KB entering for '$short_name' with str=$str\n";
list is: @list;
if (@unknown_types) {
my $num = @unknown_types;
- local $" = ' ';
+ local $LIST_SEPARATOR = ' ';
Warn(<<EOM);
$num unrecognized token types were input with --$short_name :
@unknown_types
if ( DEBUG_KB && @list ) {
my @tmp = %flags;
- local $" = ' ';
+ local $LIST_SEPARATOR = ' ';
print <<EOM;
DEBUG_KB -$short_name flag: $str
sub dump_want_left_space {
my $fh = shift;
- local $" = "\n";
+ local $LIST_SEPARATOR = "\n";
$fh->print(<<EOM);
These values are the main control of whitespace to the left of a token type;
They may be altered with the -wls parameter.
sub dump_want_right_space {
my $fh = shift;
- local $" = "\n";
+ local $LIST_SEPARATOR = "\n";
$fh->print(<<EOM);
These values are the main control of whitespace to the right of a token type;
They may be altered with the -wrs parameter.
# In any case if the user places a break at either the = or the ||
# it should remain there.
if ( $type eq '||' || $type eq 'k' && $token eq 'or' ) {
- if ( $next_nonblank_token =~ /^(die|confess|croak|warn)$/ ) {
+
+ # /^(die|confess|croak|warn)$/
+ if ( $is_die_confess_croak_warn{$next_nonblank_token} ) {
if ( $want_break_before{$token} && $i > 0 ) {
$rbond_strength_to_go->[ $i - 1 ] -= $delta_bias;
# by this program.
my ($pattern) = @_;
eval "'##'=~/$pattern/";
- return $@;
+ return $EVAL_ERROR;
}
{ ## begin closure prepare_cuddled_block_types
my @keyword_list;
my @comment_list;
foreach my $word (@words) {
- if ( $word =~ /^(BC|SBC)$/ ) {
+ if ( $word eq 'BC' || $word eq 'SBC' ) {
push @comment_list, $word;
if ( $word eq 'SBC' ) { push @comment_list, 'SBCX' }
}
&& $next_nonblank_token =~ /^[; \)\}]$/
# scalar is not declared
- && !( $type_0 eq 'k' && $token_0 =~ /^(my|our|local)$/ )
+ ## =~ /^(my|our|local)$/
+ && !( $type_0 eq 'k' && $is_my_our_local{$token_0} )
)
{
my $lno = 1 + $rLL_new->[$Kp]->[_LINE_INDEX_];
$block_type =~ s/\s+$//;
# Try to filter out parenless sub calls
- my ( $Knn1, $Knn2 );
- my ( $type_nn1, $type_nn2 ) = ( 'b', 'b' );
- $Knn1 = $self->K_next_nonblank( $K_opening, $rLL_new );
- $Knn2 = $self->K_next_nonblank( $Knn1, $rLL_new ) if defined($Knn1);
- $type_nn1 = $rLL_new->[$Knn1]->[_TYPE_] if ( defined($Knn1) );
- $type_nn2 = $rLL_new->[$Knn2]->[_TYPE_] if ( defined($Knn2) );
+ my $Knn1 = $self->K_next_nonblank( $K_opening, $rLL_new );
+ my $Knn2;
+ if ( defined($Knn1) ) {
+ $Knn2 = $self->K_next_nonblank( $Knn1, $rLL_new );
+ }
+ my $type_nn1 = defined($Knn1) ? $rLL_new->[$Knn1]->[_TYPE_] : 'b';
+ my $type_nn2 = defined($Knn2) ? $rLL_new->[$Knn2]->[_TYPE_] : 'b';
# if ( $type_nn1 =~ /^[wU]$/ && $type_nn2 =~ /^[wiqQGCZ]$/ ) {
if ( $wU{$type_nn1} && $wiq{$type_nn2} ) {
# if we do not see another elseif or an else.
if ($looking_for_else) {
- unless ( $rLL->[$K_first_true]->[_TOKEN_] =~ /^(elsif|else)$/ ) {
+ ## /^(elsif|else)$/
+ if ( !$is_elsif_else{ $rLL->[$K_first_true]->[_TOKEN_] } ) {
write_logfile_entry("(No else block)\n");
}
$looking_for_else = 0;
$looking_for_else = 1; # ok, check on next line
}
else {
-
- unless ( $next_nonblank_token =~ /^(elsif|else)$/ ) {
+ ## /^(elsif|else)$/
+ if ( !$is_elsif_else{$next_nonblank_token} ) {
write_logfile_entry("No else block :(\n");
}
}
# ; # very long comment......
# so we do not need to include the length of the comment, which
# would break the block. Project 'bioperl' has coding like this.
- if ( $block_type !~ /^(if|else|elsif|unless)$/
+ ## !~ /^(if|else|elsif|unless)$/
+ if ( !$is_if_unless_elsif_else{$block_type}
|| $K_last == $Ki_nonblank )
{
$Ki_nonblank = $K_last;
$nesting_depth_to_go[$i_next_nonblank] )
&& (
$next_nonblank_type =~ /^(\.|\&\&|\|\|)$/
- || ( $next_nonblank_type eq 'k'
- && $next_nonblank_token =~ /^(and|or)$/ )
+ || (
+ $next_nonblank_type eq 'k'
+
+ ## /^(and|or)$/ # note: includes 'xor' now
+ && $is_and_or{$next_nonblank_token}
+ )
)
)
{
return unless (@candidates);
# sort by available whitespace so that we can remove whitespace
- # from the maximum available first
- @candidates = sort { $b->[1] <=> $a->[1] } @candidates;
+ # from the maximum available first.
+ @candidates =
+ sort { $b->[1] <=> $a->[1] || $a->[0] <=> $b->[0] } @candidates;
# keep removing whitespace until we are done or have no more
foreach my $candidate (@candidates) {
# save text after 'if' and 'elsif' to append after 'else'
if ($accumulating_text_for_block) {
- if ( $accumulating_text_for_block =~ /^(if|elsif)$/ ) {
+ ## ( $accumulating_text_for_block =~ /^(if|elsif)$/ ) {
+ if ( $is_if_elsif{$accumulating_text_for_block} ) {
push @{$rleading_block_if_elsif_text}, $leading_block_text;
}
}
use warnings;
our $VERSION = '20220217.04';
+use English qw( -no_match_vars );
use File::Basename;
# class variables
BEGIN {
if ( !eval { require HTML::Entities; 1 } ) {
- $missing_html_entities = $@ ? $@ : 1;
+ $missing_html_entities = $EVAL_ERROR ? $EVAL_ERROR : 1;
}
if ( !eval { require Pod::Html; 1 } ) {
- $missing_pod_html = $@ ? $@ : 1;
+ $missing_pod_html = $EVAL_ERROR ? $EVAL_ERROR : 1;
}
}
( $html_fh, my $html_filename ) =
Perl::Tidy::streamhandle( $html_file, 'w' );
unless ($html_fh) {
- Perl::Tidy::Warn("can't open $html_file: $!\n");
+ Perl::Tidy::Warn("can't open $html_file: $ERRNO\n");
return;
}
$html_file_opened = 1;
my $css_filename = shift;
my $fh;
unless ( $fh = IO::File->new("> $css_filename") ) {
- Perl::Tidy::Die("can't open $css_filename: $!\n");
+ Perl::Tidy::Die("can't open $css_filename: $ERRNO\n");
}
write_style_sheet_data($fh);
close_object($fh);
# because the tmpfile may be one of the names used for frames
if ( -e $tmpfile ) {
unless ( unlink($tmpfile) ) {
- Perl::Tidy::Warn("couldn't unlink temporary file $tmpfile: $!\n");
+ Perl::Tidy::Warn(
+ "couldn't unlink temporary file $tmpfile: $ERRNO\n");
$success_flag = 0;
}
}
# 2. The current .html filename is renamed to be the contents panel
rename( $html_filename, $src_filename )
- or Perl::Tidy::Die("Cannot rename $html_filename to $src_filename:$!\n");
+ or Perl::Tidy::Die(
+ "Cannot rename $html_filename to $src_filename: $ERRNO\n");
# 3. Then use the original html filename for the frame
write_frame_html(
# write a separate html table of contents file for frames
my ( $title, $toc_filename, $src_basename, $rtoc, $src_frame_name ) = @_;
my $fh = IO::File->new( $toc_filename, 'w' )
- or Perl::Tidy::Die("Cannot open $toc_filename:$!\n");
+ or Perl::Tidy::Die("Cannot open $toc_filename: $ERRNO\n");
$fh->print(<<EOM);
<html>
<head>
) = @_;
my $fh = IO::File->new( $frame_filename, 'w' )
- or Perl::Tidy::Die("Cannot open $toc_basename:$!\n");
+ or Perl::Tidy::Die("Cannot open $toc_basename: $ERRNO\n");
$fh->print(<<EOM);
<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Frameset//EN"
package Perl::Tidy::Logger;
use strict;
use warnings;
+use English qw( -no_match_vars );
our $VERSION = '20220217.04';
sub AUTOLOAD {
if ( -e $warning_file ) {
unlink($warning_file)
or Perl::Tidy::Die(
- "couldn't unlink warning file $warning_file: $!\n");
+ "couldn't unlink warning file $warning_file: $ERRNO\n");
}
}
my $warning_file = $self->{_warning_file};
( $fh_warnings, my $filename ) =
Perl::Tidy::streamhandle( $warning_file, 'w', $is_encoded_data );
- $fh_warnings or Perl::Tidy::Die("couldn't open $filename $!\n");
+ $fh_warnings
+ or Perl::Tidy::Die("couldn't open $filename: $ERRNO\n");
Perl::Tidy::Warn_msg("## Please see file $filename\n")
unless ref($warning_file);
$self->{_fh_warnings} = $fh_warnings;
package Perl::Tidy::Tokenizer;
use strict;
use warnings;
+use English qw( -no_match_vars );
+
our $VERSION = '20220217.04';
# this can be turned on for extra checking during development
%is_keyword
%is_code_block_token
%is_sort_map_grep_eval_do
+ %is_sort_map_grep
%is_grep_alias
%really_want_term
@opening_brace_names
%is_keyword_taking_optional_arg
%is_keyword_rejecting_slash_as_pattern_delimiter
%is_keyword_rejecting_question_as_pattern_delimiter
+ %is_q_qq_qx_qr_s_y_tr_m
%is_q_qq_qw_qx_qr_s_y_tr_m
%is_sub
%is_package
%is_comma_question_colon
+ %is_if_elsif_unless
+ %is_if_elsif_unless_case_when
%other_line_endings
$code_skipping_pattern_begin
$code_skipping_pattern_end
# by this program.
my ($pattern) = @_;
eval "'##'=~/$pattern/";
- return $@;
+ return $EVAL_ERROR;
}
sub make_code_skipping_pattern {
@{ $tokenizer_self->[_rlower_case_labels_at_] };
write_logfile_entry(
"Suggest using upper case characters in label(s)\n");
- local $" = ')(';
+ local $LIST_SEPARATOR = ')(';
write_logfile_entry(" defined at line(s): (@lower_case_labels_at)\n");
}
return $severe_error;
# Find and remove what characters terminate this line, including any
# control r
my $input_line_separator = "";
- if ( chomp($input_line) ) { $input_line_separator = $/ }
+ if ( chomp($input_line) ) {
+ $input_line_separator = $INPUT_RECORD_SEPARATOR;
+ }
# The first test here very significantly speeds things up, but be sure to
# keep the regex and hash %other_line_endings the same.
$next_type = $rtoken_type->[ $i + 1 ];
DEBUG_TOKENIZE && do {
- local $" = ')(';
+ local $LIST_SEPARATOR = ')(';
my @debug_list = (
$last_nonblank_token, $tok,
$next_tok, $brace_depth,
$brace_type[$brace_depth], $paren_depth,
- $paren_type[$paren_depth]
+ $paren_type[$paren_depth],
);
print STDOUT "TOKENIZE:(@debug_list)\n";
};
# else or elsif blocks to be formatted. This is indicated
# by a last noblank token of ';'
elsif ( $tok eq 'elsif' ) {
- if ( $last_nonblank_token ne ';'
- && $last_nonblank_block_type !~
- /^(if|elsif|unless)$/ )
+ if (
+ $last_nonblank_token ne ';'
+
+ ## !~ /^(if|elsif|unless)$/
+ && !$is_if_elsif_unless{$last_nonblank_block_type}
+ )
{
warning(
"expecting '$tok' to follow one of 'if|elsif|unless'\n"
# patched for SWITCH/CASE
if (
- $last_nonblank_token ne ';'
- && $last_nonblank_block_type !~
- /^(if|elsif|unless|case|when)$/
+ $last_nonblank_token ne ';'
+
+ ## !~ /^(if|elsif|unless|case|when)$/
+ && !$is_if_elsif_unless_case_when{
+ $last_nonblank_block_type}
# patch to avoid an unwanted error message for
# the case of a parenless 'case' (RT 105484):
# switch ( 1 ) { case x { 2 } else { } }
- && $statement_type !~
- /^(if|elsif|unless|case|when)$/
+ ## !~ /^(if|elsif|unless|case|when)$/
+ && !$is_if_elsif_unless_case_when{$statement_type}
)
{
warning(
# print 'hi' if { x => 1, }->{x};
# We can identify this situation because the last nonblank type
# will be a keyword (instead of a closing peren)
- if ( $last_nonblank_token =~ /^(if|unless)$/
- && $last_nonblank_type eq 'k' )
+ if (
+ $last_nonblank_type eq 'k'
+ && ( $last_nonblank_token eq 'if'
+ || $last_nonblank_token eq 'unless' )
+ )
{
return "";
}
# Check for a code block within a parenthesized function call
elsif ( $last_nonblank_token eq '(' ) {
my $paren_type = $paren_type[$paren_depth];
- if ( $paren_type && $paren_type =~ /^(map|grep|sort)$/ ) {
+
+ # /^(map|grep|sort)$/
+ if ( $paren_type && $is_sort_map_grep{$paren_type} ) {
# We will mark this as a code block but use type 't' instead
# of the name of the contining function. This will allow for
# it is a comma which is not a pattern delimeter except for qw
(
- $pre_types[$j] eq ','
- && $pre_tokens[$jbeg] !~ /^(s|m|y|tr|qr|q|qq|qx)$/
+ $pre_types[$j] eq ','
+ ## !~ /^(s|m|y|tr|qr|q|qq|qx)$/
+ && !$is_q_qq_qx_qr_s_y_tr_m{ $pre_tokens[$jbeg] }
)
# or a =>
# In something like '$${' we have type '$$' (and only
# part of an identifier)
&& !( $identifier =~ /\$$/ && $tok eq '{' )
- && ( $identifier !~ /^(sub |package )$/ )
+
+ ## && ( $identifier !~ /^(sub |package )$/ )
+ && $identifier ne 'sub '
+ && $identifier ne 'package '
)
{
$type = 'i';
@q = qw( sort map grep eval do );
@is_sort_map_grep_eval_do{@q} = (1) x scalar(@q);
+ @q = qw( sort map grep );
+ @is_sort_map_grep{@q} = (1) x scalar(@q);
+
%is_grep_alias = ();
# I'll build the list of keywords incrementally
delete $really_want_term{'F'}; # file test works on $_ if no following term
delete $really_want_term{'Y'}; # indirect object, too risky to check syntax;
# let perl do it
+ @q = qw(q qq qx qr s y tr m);
+ @is_q_qq_qx_qr_s_y_tr_m{@q} = (1) x scalar(@q);
+ # Note added 'qw' here
@q = qw(q qq qw qx qr s y tr m);
@is_q_qq_qw_qx_qr_s_y_tr_m{@q} = (1) x scalar(@q);
push @q, ',';
@is_comma_question_colon{@q} = (1) x scalar(@q);
+ @q = qw( if elsif unless );
+ @is_if_elsif_unless{@q} = (1) x scalar(@q);
+
+ @q = qw( if elsif unless case when );
+ @is_if_elsif_unless_case_when{@q} = (1) x scalar(@q);
+
# Hash of other possible line endings which may occur.
# Keep these coordinated with the regex where this is used.
# Note: chr(13) = chr(015)="\r".
use strict;
use warnings;
use Carp;
+use English qw( -no_match_vars );
our $VERSION = '20220217.04';
use Perl::Tidy::VerticalAligner::Alignment;
use Perl::Tidy::VerticalAligner::Line;
my @field_lengths = @{$rfield_lengths};
EXPLAIN_TERNARY && do {
- local $" = '><';
+ local $LIST_SEPARATOR = '><';
print STDOUT "CURRENT FIELDS=<@{$rfields_old}>\n";
print STDOUT "CURRENT TOKENS=<@{$rtokens_old}>\n";
print STDOUT "CURRENT PATTERNS=<@{$rpatterns_old}>\n";
}
EXPLAIN_TERNARY && do {
- local $" = '><';
+ local $LIST_SEPARATOR = '><';
print STDOUT "MODIFIED TOKENS=<@tokens>\n";
print STDOUT "MODIFIED PATTERNS=<@patterns>\n";
print STDOUT "MODIFIED FIELDS=<@fields>\n";
sub dump_array {
# debug routine to dump array contents
- local $" = ')(';
+ local $LIST_SEPARATOR = ')(';
print STDOUT "(@_)\n";
return;
}
use constant EXPLAIN_DELETE_SELECTED => 0;
- local $" = '> <';
+ local $LIST_SEPARATOR = '> <';
EXPLAIN_DELETE_SELECTED && print <<EOM;
delete indexes: <@{$ridel}>
old jmax: $jmax_old
# debug
0 && do {
- local $" = ')(';
+ local $LIST_SEPARATOR = ')(';
print "lev_min=$lev_min, lev_max=$lev_max, levels=(@levs)\n";
foreach my $key ( sort keys %{$rtoken_patterns} ) {
print "$key => $rtoken_patterns->{$key}\n";
sub Dump_tree_groups {
my ( $rgroup, $msg ) = @_;
print "$msg\n";
- local $" = ')(';
+ local $LIST_SEPARATOR = ')(';
foreach my $item ( @{$rgroup} ) {
my @fix = @{$item};
foreach (@fix) { $_ = "undef" unless defined $_; }
projects / perltidy.git / commitdiff