+#!/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 $short_option = $short_prefix . $short_name . $suffix;
+ my $long_option = $prefix . $long_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;
+ 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,
+ );
+
+ # 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, );
+}
projects / perltidy.git / commitdiff