1#!/usr/bin/perl -w
2use strict;
3
4# This program reads .perltidyrc files and writes them back out
5# into a standard format (but comments will be lost).
6#
7# It also demonstrates how to use the perltidy 'options-dump' and related call
8# parameters to read a .perltidyrc file, convert to long names, put it in a
9# hash, and write back to standard output in sorted order.  Requires
10# Perl::Tidy.
11#
12# Steve Hancock, June 2006
13#
14my $usage = <<EOM;
15 usage:
16 perltidyrc_dump.pl [-d -s -q -h] [ filename ]
17  filename is the name of a .perltidyrc config file to dump, or
18   if no filename is given, find and dump the system default .perltidyrc.
19  -d delete options which are the same as Perl::Tidy defaults
20     (default is to keep them)
21  -s write short parameter names
22     (default is long names with short name in side comment)
23  -q quiet: no comments
24  -h help
25EOM
26use Getopt::Std;
27my %my_opts;
28my $cmdline = $0 . " " . join " ", @ARGV;
29getopts( 'hdsq', \%my_opts ) or die "$usage";
30if ( $my_opts{h} ) { die "$usage" }
31if ( @ARGV > 1 )   { die "$usage" }
32
33my $config_file = $ARGV[0];
34my (
35    $error_message, $rOpts,          $rGetopt_flags,
36    $rsections,     $rabbreviations, $rOpts_default,
37    $rabbreviations_default,
38
39) = read_perltidyrc($config_file);
40
41# always check the error message first
42if ($error_message) {
43    die "$error_message\n";
44}
45
46# make a list of perltidyrc options which are same as default
47my %equals_default;
48foreach my $long_name ( keys %{$rOpts} ) {
49    my $val = $rOpts->{$long_name};
50    if ( defined( $rOpts_default->{$long_name} ) ) {
51        my $val2 = $rOpts_default->{$long_name};
52        if ( defined($val2) && defined($val) ) {
53            $equals_default{$long_name} = ( $val2 eq $val );
54        }
55    }
56}
57
58# Optional: minimize the perltidyrc file length by deleting long_names
59# in $rOpts which are also in $rOpts_default and have the same value.
60# This would be useful if a perltidyrc file has been constructed from a
61# full parameter dump, for example.
62if ( $my_opts{d} ) {
63    foreach my $long_name ( keys %{$rOpts} ) {
64        delete $rOpts->{$long_name} if $equals_default{$long_name};
65    }
66}
67
68# find user-defined abbreviations
69my %abbreviations_user;
70foreach my $key ( keys %$rabbreviations ) {
71    unless ( $rabbreviations_default->{$key} ) {
72        $abbreviations_user{$key} = $rabbreviations->{$key};
73    }
74}
75
76# dump the options, if any
77if ( %$rOpts || %abbreviations_user ) {
78    dump_options( $cmdline, \%my_opts, $rOpts, $rGetopt_flags, $rsections,
79        $rabbreviations, \%equals_default, \%abbreviations_user );
80}
81else {
82    if ($config_file) {
83        print STDERR <<EOM;
84No configuration parameters seen in file: $config_file
85EOM
86    }
87    else {
88        print STDERR <<EOM;
89No .perltidyrc file found, use perltidy -dpro to see locations checked.
90EOM
91    }
92}
93
94sub dump_options {
95
96    # write the options back out as a valid .perltidyrc file
97    # This version writes long names by sections
98    my ( $cmdline, $rmy_opts, $rOpts, $rGetopt_flags, $rsections,
99        $rabbreviations, $requals_default, $rabbreviations_user )
100      = @_;
101
102    # $rOpts is a reference to the hash returned by Getopt::Long
103    # $rGetopt_flags are the flags passed to Getopt::Long
104    # $rsections is a hash giving manual section {long_name}
105
106    # build a hash giving section->long_name->parameter_value
107    # so that we can write parameters by section
108    my %section_and_name;
109    my $rsection_name_value = \%section_and_name;
110    my %saw_section;
111    foreach my $long_name ( keys %{$rOpts} ) {
112        my $section = $rsections->{$long_name};
113        $section = "UNKNOWN" unless ($section);    # shouldn't happen
114
115        # build a hash giving section->long_name->parameter_value
116        $rsection_name_value->{$section}->{$long_name} = $rOpts->{$long_name};
117
118        # remember what sections are in this hash
119        $saw_section{$section}++;
120    }
121
122    # build a table for long_name->short_name abbreviations
123    my %short_name;
124    foreach my $abbrev ( keys %{$rabbreviations} ) {
125        foreach my $abbrev ( sort keys %$rabbreviations ) {
126            my @list = @{ $$rabbreviations{$abbrev} };
127
128            # an abbreviation may expand into one or more other words,
129            # but only those that expand to a single word (which must be
130            # one of the long names) are the short names that we want
131            # here.
132            next unless @list == 1;
133            my $long_name = $list[0];
134            $short_name{$long_name} = $abbrev;
135        }
136    }
137
138    unless ( $rmy_opts->{q} ) {
139        my $date = localtime();
140        print "# perltidy configuration file created $date\n";
141        print "# using: $cmdline\n";
142    }
143
144    # loop to write section-by-section
145    foreach my $section ( sort keys %saw_section ) {
146        unless ( $rmy_opts->{q} ) {
147            print "\n";
148
149            # remove leading section number, which is there
150            # for sorting, i.e.,
151            # 1. Basic formatting options -> Basic formatting options
152            my $trimmed_section = $section;
153            $trimmed_section =~ s/^\d+\. //;
154            print "# $trimmed_section\n";
155        }
156
157        # loop over all long names for this section
158        my $rname_value = $rsection_name_value->{$section};
159        foreach my $long_name ( sort keys %{$rname_value} ) {
160
161            # pull out getopt flag and actual parameter value
162            my $flag  = $rGetopt_flags->{$long_name};
163            my $value = $rname_value->{$long_name};
164
165            # turn this it back into a parameter
166            my $prefix       = '--';
167            my $short_prefix = '-';
168            my $suffix       = "";
169            if ($flag) {
170                if ( $flag =~ /^=/ ) {
171                    if ( $value !~ /^\d+$/ ) { $value = '"' . $value . '"' }
172                    $suffix = "=" . $value;
173                }
174                elsif ( $flag =~ /^!/ ) {
175                    $prefix       .= "no" unless ($value);
176                    $short_prefix .= "n"  unless ($value);
177                }
178                elsif ( $flag =~ /^:/ ) {
179                    if ( $value !~ /^\d+$/ ) { $value = '"' . $value . '"' }
180                    $suffix = "=" . $value;
181                }
182                else {
183
184                    # shouldn't happen
185                    print
186"# ERROR in dump_options: unrecognized flag $flag for $long_name\n";
187                }
188            }
189
190            # print the long version of the parameter
191            # with the short version as a side comment
192            my $short_name   = $short_name{$long_name};
193            my $short_option = $short_prefix . $short_name . $suffix;
194            my $long_option  = $prefix . $long_name . $suffix;
195            my $note = $requals_default->{$long_name} ? "  [=default]" : "";
196            if ( $rmy_opts->{s} ) {
197                print $short_option. "\n";
198            }
199            else {
200                my $side_comment = "";
201                unless ( $rmy_opts->{q} ) {
202                    my $spaces = 40 - length($long_option);
203                    $spaces = 2 if ( $spaces < 2 );
204                    $side_comment =
205                      ' ' x $spaces . '# ' . $short_option . $note;
206                }
207                print $long_option . $side_comment . "\n";
208            }
209        }
210    }
211
212    if ( %{$rabbreviations_user} ) {
213        unless ( $rmy_opts->{q} ) {
214            print "\n";
215            print "# Abbreviations\n";
216        }
217        foreach my $key ( keys %$rabbreviations_user ) {
218            my @vals = @{ $rabbreviations_user->{$key} };
219            print $key. ' {' . join( ' ', @vals ) . '}' . "\n";
220        }
221    }
222}
223
224sub read_perltidyrc {
225
226    # Example routine to have Perl::Tidy read and validate perltidyrc
227    # file, and return related flags and abbreviations.
228    #
229    # input parameter -
230    #   $config_file is the name of a .perltidyrc file we want to read
231    #   or a reference to a string or array containing the .perltidyrc file
232    #   if not defined, Perl::Tidy will try to find the user's .perltidyrc
233    # output parameters -
234    #   $error_message will be blank unless an error occurs
235    #   $rOpts - reference to the hash of options in the .perlticyrc
236    # NOTE:
237    #   Perl::Tidy will croak or die on certain severe errors
238
239    my ($config_file) = @_;
240    my $error_message = "";
241    my %Opts;    # any options found will be put here
242
243    # the module must be installed for this to work
244    eval "use Perl::Tidy";
245    if ($@) {
246        $error_message = "Perl::Tidy not installed\n";
247        return ( $error_message, \%Opts );
248    }
249
250    # be sure this version supports this
251    my $version = $Perl::Tidy::VERSION;
252    if ( $version < 20060528 ) {
253        $error_message = "perltidy version $version cannot read options\n";
254        return ( $error_message, \%Opts );
255    }
256
257    my $stderr = "";    # try to capture error messages
258    my $argv   = "";    # do not let perltidy see our @ARGV
259
260    # we are going to make two calls to perltidy...
261    # first with an empty .perltidyrc to get the default parameters
262    my $empty_file = "";    # this will be our .perltidyrc file
263    my %Opts_default;       # this will receive the default options hash
264    my %abbreviations_default;
265    my $err = Perl::Tidy::perltidy(
266        perltidyrc         => \$empty_file,
267        dump_options       => \%Opts_default,
268        dump_options_type  => 'full',                  # 'full' gives everything
269        dump_abbreviations => \%abbreviations_default,
270        stderr             => \$stderr,
271        argv               => \$argv,
272    );
273    if ($err) {
274        die "Error calling perltidy\n";
275    }
276
277    # now we call with a .perltidyrc file to get its parameters
278    my %Getopt_flags;
279    my %sections;
280    my %abbreviations;
281    Perl::Tidy::perltidy(
282        perltidyrc            => $config_file,
283        dump_options          => \%Opts,
284        dump_options_type     => 'perltidyrc',      # default is 'perltidyrc'
285        dump_getopt_flags     => \%Getopt_flags,
286        dump_options_category => \%sections,
287        dump_abbreviations    => \%abbreviations,
288        stderr                => \$stderr,
289        argv                  => \$argv,
290    );
291
292    # try to capture any errors generated by perltidy call
293    # but for severe errors it will typically croak
294    $error_message .= $stderr;
295
296    # debug: show how everything is stored by printing it out
297    my $DEBUG = 0;
298    if ($DEBUG) {
299        print "---Getopt Parameters---\n";
300        foreach my $key ( sort keys %Getopt_flags ) {
301            print "$key$Getopt_flags{$key}\n";
302        }
303        print "---Manual Sections---\n";
304        foreach my $key ( sort keys %sections ) {
305            print "$key -> $sections{$key}\n";
306        }
307        print "---Abbreviations---\n";
308        foreach my $key ( sort keys %abbreviations ) {
309            my @names = @{ $abbreviations{$key} };
310            print "$key -> {@names}\n";
311            unless ( $abbreviations_default{$key} ) {
312                print "NOTE: $key is user defined\n";
313            }
314        }
315    }
316
317    return ( $error_message, \%Opts, \%Getopt_flags, \%sections,
318        \%abbreviations, \%Opts_default, \%abbreviations_default, );
319}
320