Perl-Tidy
view release on metacpan or search on metacpan
lib/Perl/Tidy.pm view on Meta::CPAN
# 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 )
$rstatus = {
file_count => 0,
opt_format => EMPTY_STRING,
opt_encoding => EMPTY_STRING,
opt_encode_output => EMPTY_STRING,
opt_max_iterations => EMPTY_STRING,
input_name => '(unknown)',
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,
num_files => 0,
line_range_clipped => 0,
};
# Fix for issue git #57
$Warn_count = 0;
$nag_message = EMPTY_STRING;
# don't overwrite callers ARGV
# Localization of @ARGV could be avoided by calling GetOptionsFromArray
# instead of GetOptions, but that is not available before perl 5.10
local @ARGV = @ARGV;
local *STDERR = *STDERR;
if ( my @bad_keys = grep { !exists $defaults{$_} } keys %input_hash ) {
local $LIST_SEPARATOR = ')(';
my @good_keys = sort keys %defaults;
@bad_keys = sort @bad_keys;
confess <<EOM;
------------------------------------------------------------------------
Unknown perltidy parameter : (@bad_keys)
perltidy only understands : (@good_keys)
------------------------------------------------------------------------
EOM
}
my $get_hash_ref = sub {
my ($key) = @_;
# Get and check a parameter from the input hash
my $hash_ref = $input_hash{$key};
if ( defined($hash_ref) ) {
if ( ref($hash_ref) ne 'HASH' ) {
my $what = ref($hash_ref);
my $but_is =
$what ? "but is ref to $what" : "but is not a reference";
croak <<EOM;
------------------------------------------------------------------------
error in call to perltidy:
-$key must be reference to HASH $but_is
------------------------------------------------------------------------
EOM
}
}
return $hash_ref;
}; ## end $get_hash_ref = sub
%input_hash = ( %defaults, %input_hash );
my $argv = $input_hash{'argv'};
my $destination_stream = $input_hash{'destination'};
my $perltidyrc_stream = $input_hash{'perltidyrc'};
my $source_stream = $input_hash{'source'};
my $stderr_stream = $input_hash{'stderr'};
my $user_formatter = $input_hash{'formatter'};
my $prefilter = $input_hash{'prefilter'};
my $postfilter = $input_hash{'postfilter'};
if ($stderr_stream) {
$fh_stderr = Perl::Tidy::streamhandle( $stderr_stream, 'w' );
if ( !$fh_stderr ) {
croak <<EOM;
------------------------------------------------------------------------
Unable to redirect STDERR to $stderr_stream
Please check value of -stderr in call to perltidy
------------------------------------------------------------------------
EOM
}
}
else {
lib/Perl/Tidy.pm view on Meta::CPAN
$perltidyrc_stream, $is_Windows_uu, $Windows_type_uu,
$rpending_complaint_uu, $dump_options_type
) = @q;
my $use_cache = !defined($perltidyrc_stream) && !$dump_options_type;
if ($use_cache) {
my $cache_key = join( chr(28), @ARGV );
if ( my $result = $process_command_line_cache{$cache_key} ) {
my ( $argv, @retvals ) = @{$result};
@ARGV = @{$argv};
return @retvals;
}
else {
my @retvals = _process_command_line(@q);
$process_command_line_cache{$cache_key} = [ \@ARGV, @retvals ]
if ( $retvals[0]->{'memoize'} );
return @retvals;
}
}
else {
return _process_command_line(@q);
}
} ## end sub process_command_line
} ## end closure process_command_line
# (note the underscore here)
sub _process_command_line {
my (
$perltidyrc_stream, $is_Windows, $Windows_type,
$rpending_complaint, $dump_options_type
) = @_;
# Use Getopt::Long to scan the command line for input parameters.
# This is the inner sub which actually processes the command line
use Getopt::Long;
# Save any current Getopt::Long configuration
# and set to Getopt::Long defaults. Use eval to avoid
# breaking old versions of Perl without these routines.
# Previous configuration is reset at the exit of this routine.
my $glc;
if ( eval { $glc = Getopt::Long::Configure(); 1 } ) {
my $ok = eval { Getopt::Long::ConfigDefaults(); 1 };
if ( !$ok && DEVEL_MODE ) {
Fault("Failed call to Getopt::Long::ConfigDefaults: $EVAL_ERROR\n");
}
}
else { $glc = undef }
my ( $roption_string, $rdefaults, $rexpansion,
$roption_category, $rinteger_option_range, $ris_string_option )
= generate_options();
#--------------------------------------------------------------
# set the defaults by passing the above list through GetOptions
#--------------------------------------------------------------
my %Opts = ();
{
local @ARGV = ();
# do not load the defaults if we are just dumping perltidyrc
if ( $dump_options_type ne 'perltidyrc' ) {
for my $i ( @{$rdefaults} ) { push @ARGV, "--" . $i }
}
if ( !GetOptions( \%Opts, @{$roption_string} ) ) {
Die(
"Programming Bug reported by 'GetOptions': error in setting default options"
);
}
}
my @raw_options = ();
my $saw_ignore_profile = 0;
my $saw_dump_profile = 0;
my $config_file;
#--------------------------------------------------------------
# Take a first look at the command-line parameters. Do as many
# immediate dumps as possible, which can avoid confusion if the
# perltidyrc file has an error.
#--------------------------------------------------------------
foreach my $i (@ARGV) {
$i =~ s/^--/-/;
if ( $i =~ /^-(npro|noprofile|nopro|no-profile)$/ ) {
$saw_ignore_profile = 1;
}
# note: this must come before -pro and -profile, below:
elsif ( $i =~ /^-(dump-profile|dpro)$/ ) {
$saw_dump_profile = 1;
}
elsif ( $i =~ /^-(pro|profile)=(.+)/ ) {
if ( defined($config_file) ) {
Warn(
"Only one -pro=filename allowed, using '$2' instead of '$config_file'\n"
);
}
$config_file = $2;
# resolve <dir>/.../<file>, meaning look upwards from directory
if ( defined($config_file) ) {
if ( my ( $start_dir, $search_file ) =
( $config_file =~ m{^(.*)\.\.\./(.*)$} ) )
{
$start_dir = '.' if ( !$start_dir );
$start_dir = Cwd::realpath($start_dir);
my $found_file =
find_file_upwards( $start_dir, $search_file );
if ( defined($found_file) ) {
$config_file = $found_file;
}
}
}
if ( !-e $config_file ) {
Die(
"cannot find file given with -pro=$config_file: $OS_ERROR\n"
);
}
lib/Perl/Tidy.pm view on Meta::CPAN
#----------------------------------------
# read any .perltidyrc configuration file
#----------------------------------------
if ( !$saw_ignore_profile ) {
# resolve possible conflict between $perltidyrc_stream passed
# as call parameter to perltidy and -pro=filename on command
# line.
if ($perltidyrc_stream) {
if ( defined($config_file) ) {
Warn(<<EOM);
Conflict: a perltidyrc configuration file was specified both as this
perltidy call parameter: $perltidyrc_stream
and with this -profile=$config_file.
Using -profile=$config_file.
EOM
}
else {
$config_file = $perltidyrc_stream;
}
}
# look for a config file if we don't have one yet
my $rconfig_file_chatter;
${$rconfig_file_chatter} = EMPTY_STRING;
if ( !defined($config_file) ) {
$config_file =
find_config_file( $is_Windows, $Windows_type,
$rconfig_file_chatter, $rpending_complaint );
}
# open any config file
my $rconfig_string;
if ( defined($config_file) ) {
$rconfig_string = stream_slurp($config_file);
if ( !defined($rconfig_string) ) {
Die(
"exiting because profile '$config_file' could not be opened\n"
);
}
filter_unknown_options(
$rconfig_string, $roption_category,
$rexpansion, $rconfig_file_chatter
);
}
if ($saw_dump_profile) {
dump_config_file( $rconfig_string, $config_file,
$rconfig_file_chatter );
Exit(0);
}
if ( defined($rconfig_string) ) {
my ( $rconfig_list, $death_message ) =
read_config_file( $rconfig_string, $config_file, $rexpansion );
Die($death_message) if ($death_message);
# process any .perltidyrc parameters right now so we can
# localize errors
if ( @{$rconfig_list} ) {
local @ARGV = @{$rconfig_list};
expand_command_abbreviations( $rexpansion, \@raw_options,
$config_file );
check_for_missing_string_options( $ris_string_option,
$config_file );
if ( !GetOptions( \%Opts, @{$roption_string} ) ) {
Die(
"Error in this config file: $config_file \nUse -npro to ignore this file, -dpro to dump it, -h for help'\n"
);
}
# Anything left in this local @ARGV is an error and must be
# invalid bare words from the configuration file. We cannot
# check this earlier because bare words may have been valid
# values for parameters. We had to wait for GetOptions to have
# a look at @ARGV.
if (@ARGV) {
my $count = @ARGV;
my $str = EMPTY_STRING;
foreach my $param (@ARGV) {
if ( length($str) < 70 ) {
if ($str) { $str .= ', ' }
$str .= "'$param'";
}
else {
$str .= ", ...";
last;
}
}
Die(<<EOM);
There are $count unrecognized values in the configuration file '$config_file':
$str
Use leading dashes for parameters. Use -npro to ignore this file.
EOM
}
# Undo any options which cause premature exit. They are not
# appropriate for a config file, and it could be hard to
# diagnose the cause of the premature exit.
# These are options include dump switches of the form
# '--dump-xxx-xxx!'.
my @dump_commands =
grep { /^(dump-.*)!$/ } @{$roption_string};
foreach (@dump_commands) { s/!$// }
# Here is a current list of these @dump_commands:
# dump-block-summary
# dump-cuddled-block-list
# dump-defaults
# dump-integer-option-range
# dump-long-names
# dump-mismatched-args
# dump-mismatched-returns
# dump-mixed-call-parens
# dump-options
# dump-profile
# dump-short-names
# dump-token-types
# dump-unusual-variables
# dump-want-left-space
# dump-want-right-space
# dump-keyword-usage
# dump-label-usage
# The following dump configuration parameters which
# take =i or =s would still be allowed:
# dump-block-minimum-lines, 'dbl', '=i' );
# dump-block-types, 'dbt', '=s' );
# dump-keyword-usage-list, 'dkul', '=s' );
foreach my $cmd (
lib/Perl/Tidy.pm view on Meta::CPAN
# make sure we are not in an infinite loop
if ( $pass_count == $max_passes ) {
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;
(rraw_options)
EOM
my $num = @new_argv;
if ( $num < 50 ) {
Warn(<<EOM);
After $max_passes passes here is ARGV
(@new_argv)
EOM
}
else {
Warn(<<EOM);
After $max_passes passes ARGV has $num entries
EOM
}
if ( defined($config_file) ) {
Die(<<"DIE");
Please check your configuration file $config_file for circular-references.
To deactivate it, use -npro.
DIE
}
else {
Die(<<'DIE');
Program bug - circular-references in the %expansion hash, probably due to
a recent program change.
DIE
}
} ## end of check for circular references
} ## end of loop over all passes
return;
} ## end sub expand_command_abbreviations
sub check_for_missing_string_options {
my ( $ris_string_option, ($config_file) ) = @_;
# Given:
# $ris_string_option = hash with keys are options of type '=s'
# ($config_file) = optional parameter:
# - name of config file if processing config file
# - undef if processing command line args
# Task:
# Look through @ARGV for string options which are not immediately followed
# by '=string'. If the next word looks like another --option, then it may
# get gobbled up as the string arg. In that case, exit with an error
# message. The user can always force a string arg which looks like an
# option by using the '=string' input form.
# Example of the type of error this sub checks for:
# perltidy -lpil -l=9 filename
# In this sub, any short option forms have already been expanded into their
# long forms, so this will appear here in the local copy of @ARGV as three
# list items:
# @ARGV = qw(
# --line-up-parentheses-inclusion-list
# --maximum-line-length=9
# filename
# );
# Then, since -lpil wants a string value, it will be set equal to
# '--line-up-parentheses=9' by sub GetOptions, which is probably not the
# desired value.
# This sub will catch most errors of this type at the earliest possible
# stage. One exception is if the user enters just part of an option name
# and relies on name completion by sub GetOptions. Another exception is if
# a filename follows the missing string option on the command line. In
# those cases we have to rely on later checks.
my $arg_seeking_string_last;
my $error_message = EMPTY_STRING;
foreach my $arg (@ARGV) {
my $arg_seeking_string;
# something like --option ?
if ( substr( $arg, 0, 2 ) eq '--' && length($arg) > 2 ) {
# Will the previous string without arg try to grab this option?
if ( $arg_seeking_string_last && $arg =~ /^\-\-[A-Za-z]/ ) {
$error_message .= <<EOM;
'$arg_seeking_string_last' may be missing its string parameter.
EOM
}
# Is this a string option without a following '=value' ?
if ( index( $arg, '=' ) < 0
&& $ris_string_option->{ substr( $arg, 2 ) } )
{
$arg_seeking_string = $arg;
}
}
$arg_seeking_string_last = $arg_seeking_string;
}
if ($error_message) {
my $pre_note = "Possible error ";
$pre_note .=
defined($config_file)
? "in config file '$config_file':\n"
: "on the command line:\n";
my $post_note =
"Use the equals form '--option=string' to avoid this message.\n";
Die( $pre_note . $error_message . $post_note );
}
return;
} ## end sub check_for_missing_string_options
sub dump_short_names {
( run in 2.453 seconds using v1.01-cache-2.11-cpan-364913b4093 )