#!/usr/bin/perl -w
use strict;
# This program reads .perltidyrc files and writes them back out
# into a standard format (but comments will be lost).
#
# It also demonstrates how to use the perltidy 'options-dump' and related call
# parameters to read a .perltidyrc file, convert to long names, put it in a
# hash, and write back to standard output in sorted order. Requires
# Perl::Tidy.
#
# Steve Hancock, June 2006
#
my $usage = <<EOM;
usage:
perltidyrc_dump.pl [-d -s -q -h] [ filename ]
filename is the name of a .perltidyrc config file to dump, or
if no filename is given, find and dump the system default .perltidyrc.
-d delete options which are the same as Perl::Tidy defaults
(default is to keep them)
-s write short parameter names
(default is long names with short name in side comment)
-q quiet: no comments
-h help
EOM
use Getopt::Std;
my %my_opts;
my $cmdline = $0 . " " . join " ", @ARGV;
getopts( 'hdsq', \%my_opts ) or die "$usage";
if ( $my_opts{h} ) { die "$usage" }
if ( @ARGV > 1 ) { die "$usage" }
my $config_file = $ARGV[0];
my (
$error_message, $rOpts, $rGetopt_flags,
$rsections, $rabbreviations, $rOpts_default,
$rabbreviations_default,
) = read_perltidyrc($config_file);
# always check the error message first
if ($error_message) {
die "$error_message\n";
}
# make a list of perltidyrc options which are same as default
my %equals_default;
foreach my $long_name ( keys %{$rOpts} ) {
my $val = $rOpts->{$long_name};
if ( defined( $rOpts_default->{$long_name} ) ) {
my $val2 = $rOpts_default->{$long_name};
if ( defined($val2) && defined($val) ) {
$equals_default{$long_name} = ( $val2 eq $val );
}
}
}
# Optional: minimize the perltidyrc file length by deleting long_names
# in $rOpts which are also in $rOpts_default and have the same value.
# This would be useful if a perltidyrc file has been constructed from a
# full parameter dump, for example.
if ( $my_opts{d} ) {
foreach my $long_name ( keys %{$rOpts} ) {
delete $rOpts->{$long_name} if $equals_default{$long_name};
}
}
# find user-defined abbreviations
my %abbreviations_user;
foreach my $key ( keys %$rabbreviations ) {
unless ( $rabbreviations_default->{$key} ) {
$abbreviations_user{$key} = $rabbreviations->{$key};
}
}
# dump the options, if any
if ( %$rOpts || %abbreviations_user ) {
dump_options( $cmdline, \%my_opts, $rOpts, $rGetopt_flags, $rsections,
$rabbreviations, \%equals_default, \%abbreviations_user );
}
else {
if ($config_file) {
print STDERR <<EOM;
No configuration parameters seen in file: $config_file
EOM
}
else {
print STDERR <<EOM;
No .perltidyrc file found, use perltidy -dpro to see locations checked.
EOM
}
}
sub dump_options {
# write the options back out as a valid .perltidyrc file
# This version writes long names by sections
my ( $cmdline, $rmy_opts, $rOpts, $rGetopt_flags, $rsections,
$rabbreviations, $requals_default, $rabbreviations_user )
= @_;
# $rOpts is a reference to the hash returned by Getopt::Long
# $rGetopt_flags are the flags passed to Getopt::Long
# $rsections is a hash giving manual section {long_name}
# build a hash giving section->long_name->parameter_value
# so that we can write parameters by section
my %section_and_name;
my $rsection_name_value = \%section_and_name;
my %saw_section;
foreach my $long_name ( keys %{$rOpts} ) {
my $section = $rsections->{$long_name};
$section = "UNKNOWN" unless ($section); # shouldn't happen
# build a hash giving section->long_name->parameter_value
$rsection_name_value->{$section}->{$long_name} = $rOpts->{$long_name};
# remember what sections are in this hash
$saw_section{$section}++;
}
# build a table for long_name->short_name abbreviations
my %short_name;
foreach my $abbrev ( keys %{$rabbreviations} ) {
foreach my $abbrev ( sort keys %$rabbreviations ) {
my @list = @{ $$rabbreviations{$abbrev} };
# an abbreviation may expand into one or more other words,
# but only those that expand to a single word (which must be
# one of the long names) are the short names that we want
# here.
next unless @list == 1;
my $long_name = $list[0];
$short_name{$long_name} = $abbrev;
}
}
unless ( $rmy_opts->{q} ) {
my $date = localtime();
print "# perltidy configuration file created $date\n";
print "# using: $cmdline\n";
}
# loop to write section-by-section
foreach my $section ( sort keys %saw_section ) {
unless ( $rmy_opts->{q} ) {
print "\n";
# remove leading section number, which is there
# for sorting, i.e.,
# 1. Basic formatting options -> Basic formatting options
my $trimmed_section = $section;
$trimmed_section =~ s/^\d+\. //;
print "# $trimmed_section\n";
}
# loop over all long names for this section
my $rname_value = $rsection_name_value->{$section};
foreach my $long_name ( sort keys %{$rname_value} ) {
# pull out getopt flag and actual parameter value
my $flag = $rGetopt_flags->{$long_name};
my $value = $rname_value->{$long_name};
# turn this it back into a parameter
my $prefix = '--';
my $short_prefix = '-';
my $suffix = "";
if ($flag) {
if ( $flag =~ /^=/ ) {
if ( $value !~ /^\d+$/ ) { $value = '"' . $value . '"' }
$suffix = "=" . $value;
}
elsif ( $flag =~ /^!/ ) {
$prefix .= "no" unless ($value);
$short_prefix .= "n" unless ($value);
}
elsif ( $flag =~ /^:/ ) {
if ( $value !~ /^\d+$/ ) { $value = '"' . $value . '"' }
$suffix = "=" . $value;
}
else {
# shouldn't happen
print
"# ERROR in dump_options: unrecognized flag $flag for $long_name\n";
}
}
# print the long version of the parameter
# with the short version as a side comment
my $short_name = $short_name{$long_name};
my $long_option = $prefix . $long_name . $suffix;
# A few options do not have a short abbreviation. These include
# 'recombine' and 'valign', which are mainly for debugging. As a
# workaround, we will make it the same as the long option. This
# will insure that the -s -q flags work.
my $short_option = $long_option;
if ($short_name) {
$short_option = $short_prefix . $short_name . $suffix;
}
my $note = $requals_default->{$long_name} ? " [=default]" : "";
if ( $rmy_opts->{s} ) {
print $short_option. "\n";
}
else {
my $side_comment = "";
unless ( $rmy_opts->{q} ) {
my $spaces = 40 - length($long_option);
$spaces = 2 if ( $spaces < 2 );
$side_comment =
' ' x $spaces . '# ' . $short_option . $note;
}
print $long_option . $side_comment . "\n";
}
}
}
if ( %{$rabbreviations_user} ) {
unless ( $rmy_opts->{q} ) {
print "\n";
print "# Abbreviations\n";
}
foreach my $key ( keys %$rabbreviations_user ) {
my @vals = @{ $rabbreviations_user->{$key} };
print $key. ' {' . join( ' ', @vals ) . '}' . "\n";
}
}
}
sub read_perltidyrc {
# Example routine to have Perl::Tidy read and validate perltidyrc
# file, and return related flags and abbreviations.
#
# input parameter -
# $config_file is the name of a .perltidyrc file we want to read
# or a reference to a string or array containing the .perltidyrc file
# if not defined, Perl::Tidy will try to find the user's .perltidyrc
# output parameters -
# $error_message will be blank unless an error occurs
# $rOpts - reference to the hash of options in the .perlticyrc
# NOTE:
# Perl::Tidy will croak or die on certain severe errors
my ($config_file) = @_;
my $error_message = "";
my %Opts; # any options found will be put here
# the module must be installed for this to work
eval "use Perl::Tidy";
if ($@) {
$error_message = "Perl::Tidy not installed\n";
return ( $error_message, \%Opts );
}
# be sure this version supports this
my $version = $Perl::Tidy::VERSION;
if ( $version < 20060528 ) {
$error_message = "perltidy version $version cannot read options\n";
return ( $error_message, \%Opts );
}
my $stderr = ""; # try to capture error messages
my $argv = ""; # do not let perltidy see our @ARGV
# we are going to make two calls to perltidy...
# first with an empty .perltidyrc to get the default parameters
my $empty_file = ""; # this will be our .perltidyrc file
my %Opts_default; # this will receive the default options hash
my %abbreviations_default;
my $err = Perl::Tidy::perltidy(
perltidyrc => \$empty_file,
dump_options => \%Opts_default,
dump_options_type => 'full', # 'full' gives everything
dump_abbreviations => \%abbreviations_default,
stderr => \$stderr,
argv => \$argv,
);
if ($err) {
die "Error calling perltidy\n";
}
# now we call with a .perltidyrc file to get its parameters
my %Getopt_flags;
my %sections;
my %abbreviations;
Perl::Tidy::perltidy(
perltidyrc => $config_file,
dump_options => \%Opts,
dump_options_type => 'perltidyrc', # default is 'perltidyrc'
dump_getopt_flags => \%Getopt_flags,
dump_options_category => \%sections,
dump_abbreviations => \%abbreviations,
stderr => \$stderr,
argv => \$argv,
);
# try to capture any errors generated by perltidy call
# but for severe errors it will typically croak
$error_message .= $stderr;
# debug: show how everything is stored by printing it out
my $DEBUG = 0;
if ($DEBUG) {
print "---Getopt Parameters---\n";
foreach my $key ( sort keys %Getopt_flags ) {
print "$key$Getopt_flags{$key}\n";
}
print "---Manual Sections---\n";
foreach my $key ( sort keys %sections ) {
print "$key -> $sections{$key}\n";
}
print "---Abbreviations---\n";
foreach my $key ( sort keys %abbreviations ) {
my @names = @{ $abbreviations{$key} };
print "$key -> {@names}\n";
unless ( $abbreviations_default{$key} ) {
print "NOTE: $key is user defined\n";
}
}
}
return ( $error_message, \%Opts, \%Getopt_flags, \%sections,
\%abbreviations, \%Opts_default, \%abbreviations_default, );
}
|