MooseX-CoverableModifiers
view release on metacpan or search on metacpan
inc/Perl/Tidy.pm view on Meta::CPAN
#
# VerticalAligner collects groups of lines together and tries to line up
# certain tokens, such as '=>', '#', and '=' by adding whitespace.
#
# FileWriter simply writes lines to the output stream.
#
# The Logger package, not shown, records significant events and warning
# messages. It writes a .LOG file, which may be saved with a
# '-log' or a '-g' flag.
{
# variables needed by interrupt handler:
my $tokenizer;
my $input_file;
# this routine may be called to give a status report if interrupted. If a
# parameter is given, it will call exit with that parameter. This is no
# longer used because it works under Unix but not under Windows.
sub interrupt_handler {
my $exit_flag = shift;
print STDERR "perltidy interrupted";
if ($tokenizer) {
my $input_line_number =
Perl::Tidy::Tokenizer::get_input_line_number();
print STDERR " at line $input_line_number";
}
if ($input_file) {
if ( ref $input_file ) { print STDERR " of reference to:" }
else { print STDERR " of file:" }
print STDERR " $input_file";
}
print STDERR "\n";
exit $exit_flag if defined($exit_flag);
}
sub perltidy {
my %defaults = (
argv => undef,
destination => undef,
formatter => undef,
logfile => undef,
errorfile => undef,
perltidyrc => undef,
source => undef,
stderr => undef,
dump_options => undef,
dump_options_type => undef,
dump_getopt_flags => undef,
dump_options_category => undef,
dump_options_range => undef,
dump_abbreviations => undef,
prefilter => undef,
postfilter => undef,
);
# don't overwrite callers ARGV
local @ARGV = @ARGV;
my %input_hash = @_;
if ( my @bad_keys = grep { !exists $defaults{$_} } keys %input_hash ) {
local $" = ')(';
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) = @_;
my $hash_ref = $input_hash{$key};
if ( defined($hash_ref) ) {
unless ( ref($hash_ref) eq '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;
};
%input_hash = ( %defaults, %input_hash );
my $argv = $input_hash{'argv'};
my $destination_stream = $input_hash{'destination'};
my $errorfile_stream = $input_hash{'errorfile'};
my $logfile_stream = $input_hash{'logfile'};
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'};
# various dump parameters
my $dump_options_type = $input_hash{'dump_options_type'};
my $dump_options = $get_hash_ref->('dump_options');
my $dump_getopt_flags = $get_hash_ref->('dump_getopt_flags');
my $dump_options_category = $get_hash_ref->('dump_options_category');
my $dump_abbreviations = $get_hash_ref->('dump_abbreviations');
my $dump_options_range = $get_hash_ref->('dump_options_range');
# validate dump_options_type
if ( defined($dump_options) ) {
unless ( defined($dump_options_type) ) {
$dump_options_type = 'perltidyrc';
}
inc/Perl/Tidy.pm view on Meta::CPAN
maximum-consecutive-blank-lines=0
maximum-line-length=1
noadd-semicolons
noadd-whitespace
noblanks-before-blocks
noblanks-before-subs
nofuzzy-line-length
notabs
norecombine
)
],
# this style tries to follow the GNU Coding Standards (which do
# not really apply to perl but which are followed by some perl
# programmers).
'gnu-style' => [
qw(
lp bl noll pt=2 bt=2 sbt=2 cpi=1 csbi=1 cbi=1
)
],
# Style suggested in Damian Conway's Perl Best Practices
'perl-best-practices' => [
qw(l=78 i=4 ci=4 st se vt=2 cti=0 pt=1 bt=1 sbt=1 bbt=1 nsfs nolq),
q(wbb=% + - * / x != == >= <= =~ !~ < > | & = **= += *= &= <<= &&= -= /= |= >>= ||= //= .= %= ^= x=)
],
# Additional styles can be added here
);
Perl::Tidy::HtmlWriter->make_abbreviated_names( \%expansion );
# Uncomment next line to dump all expansions for debugging:
# dump_short_names(\%expansion);
return (
\@option_string, \@defaults, \%expansion,
\%option_category, \%option_range
);
} # end of generate_options
sub process_command_line {
my (
$perltidyrc_stream, $is_Windows, $Windows_type,
$rpending_complaint, $dump_options_type
) = @_;
use Getopt::Long;
my (
$roption_string, $rdefaults, $rexpansion,
$roption_category, $roption_range
) = generate_options();
#---------------------------------------------------------------
# set the defaults by passing the above list through GetOptions
#---------------------------------------------------------------
my %Opts = ();
{
local @ARGV;
my $i;
# do not load the defaults if we are just dumping perltidyrc
unless ( $dump_options_type eq 'perltidyrc' ) {
for $i (@$rdefaults) { push @ARGV, "--" . $i }
}
# Patch to save users Getopt::Long configuration
# and set to Getopt::Long defaults. Use eval to avoid
# breaking old versions of Perl without these routines.
my $glc;
eval { $glc = Getopt::Long::Configure() };
unless ($@) {
eval { Getopt::Long::ConfigDefaults() };
}
else { $glc = undef }
if ( !GetOptions( \%Opts, @$roption_string ) ) {
die "Programming Bug: error in setting default options";
}
# Patch to put the previous Getopt::Long configuration back
eval { Getopt::Long::Configure($glc) } if defined $glc;
}
my $word;
my @raw_options = ();
my $config_file = "";
my $saw_ignore_profile = 0;
my $saw_extrude = 0;
my $saw_dump_profile = 0;
my $i;
#---------------------------------------------------------------
# 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 $i (@ARGV) {
$i =~ s/^--/-/;
if ( $i =~ /^-(npro|noprofile|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 ($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{^(.*)\.\.\./(.*)$} ) )
inc/Perl/Tidy.pm view on Meta::CPAN
}
#---------------------------------------------------------------
# read any .perltidyrc configuration file
#---------------------------------------------------------------
unless ($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 ($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 = "";
$config_file =
find_config_file( $is_Windows, $Windows_type, $rconfig_file_chatter,
$rpending_complaint )
unless $config_file;
# open any config file
my $fh_config;
if ($config_file) {
( $fh_config, $config_file ) =
Perl::Tidy::streamhandle( $config_file, 'r' );
unless ($fh_config) {
$$rconfig_file_chatter .=
"# $config_file exists but cannot be opened\n";
}
}
if ($saw_dump_profile) {
if ($saw_dump_profile) {
dump_config_file( $fh_config, $config_file,
$rconfig_file_chatter );
exit 1;
}
}
if ($fh_config) {
my ( $rconfig_list, $death_message ) =
read_config_file( $fh_config, $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 );
if ( !GetOptions( \%Opts, @$roption_string ) ) {
die
"Error in this config file: $config_file \nUse -npro to ignore this file, -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 = "\'" . pop(@ARGV) . "\'";
while ( my $param = pop(@ARGV) ) {
if ( length($str) < 70 ) {
$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.
foreach (
qw{
dump-defaults
dump-long-names
dump-options
dump-profile
dump-short-names
dump-token-types
dump-want-left-space
dump-want-right-space
help
stylesheet
version
}
)
{
if ( defined( $Opts{$_} ) ) {
delete $Opts{$_};
warn "ignoring --$_ in config file: $config_file\n";
}
}
}
}
}
#---------------------------------------------------------------
# now process the command line parameters
#---------------------------------------------------------------
expand_command_abbreviations( $rexpansion, \@raw_options, $config_file );
if ( !GetOptions( \%Opts, @$roption_string ) ) {
die "Error on command line; for help try 'perltidy -h'\n";
}
( run in 1.657 second using v1.01-cache-2.11-cpan-5b529ec07f3 )