4 # This program reads .perltidyrc files and writes them back out
5 # into a standard format (but comments will be lost).
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
12 # Steve Hancock, June 2006
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)
28 my $cmdline = $0 . " " . join " ", @ARGV;
29 getopts( 'hdsq', \%my_opts ) or die "$usage";
30 if ( $my_opts{h} ) { die "$usage" }
31 if ( @ARGV > 1 ) { die "$usage" }
33 my $config_file = $ARGV[0];
35 $error_message, $rOpts, $rGetopt_flags,
36 $rsections, $rabbreviations, $rOpts_default,
37 $rabbreviations_default,
39 ) = read_perltidyrc($config_file);
41 # always check the error message first
43 die "$error_message\n";
46 # make a list of perltidyrc options which are same as default
48 foreach 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 );
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.
63 foreach my $long_name ( keys %{$rOpts} ) {
64 delete $rOpts->{$long_name} if $equals_default{$long_name};
68 # find user-defined abbreviations
69 my %abbreviations_user;
70 foreach my $key ( keys %$rabbreviations ) {
71 unless ( $rabbreviations_default->{$key} ) {
72 $abbreviations_user{$key} = $rabbreviations->{$key};
76 # dump the options, if any
77 if ( %$rOpts || %abbreviations_user ) {
78 dump_options( $cmdline, \%my_opts, $rOpts, $rGetopt_flags, $rsections,
79 $rabbreviations, \%equals_default, \%abbreviations_user );
84 No configuration parameters seen in file: $config_file
89 No .perltidyrc file found, use perltidy -dpro to see locations checked.
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 )
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}
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;
111 foreach my $long_name ( keys %{$rOpts} ) {
112 my $section = $rsections->{$long_name};
113 $section = "UNKNOWN" unless ($section); # shouldn't happen
115 # build a hash giving section->long_name->parameter_value
116 $rsection_name_value->{$section}->{$long_name} = $rOpts->{$long_name};
118 # remember what sections are in this hash
119 $saw_section{$section}++;
122 # build a table for long_name->short_name abbreviations
124 foreach my $abbrev ( keys %{$rabbreviations} ) {
125 foreach my $abbrev ( sort keys %$rabbreviations ) {
126 my @list = @{ $$rabbreviations{$abbrev} };
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
132 next unless @list == 1;
133 my $long_name = $list[0];
134 $short_name{$long_name} = $abbrev;
138 unless ( $rmy_opts->{q} ) {
139 my $date = localtime();
140 print "# perltidy configuration file created $date\n";
141 print "# using: $cmdline\n";
144 # loop to write section-by-section
145 foreach my $section ( sort keys %saw_section ) {
146 unless ( $rmy_opts->{q} ) {
149 # remove leading section number, which is there
151 # 1. Basic formatting options -> Basic formatting options
152 my $trimmed_section = $section;
153 $trimmed_section =~ s/^\d+\. //;
154 print "# $trimmed_section\n";
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} ) {
161 # pull out getopt flag and actual parameter value
162 my $flag = $rGetopt_flags->{$long_name};
163 my $value = $rname_value->{$long_name};
165 # turn this it back into a parameter
167 my $short_prefix = '-';
170 if ( $flag =~ /^=/ ) {
171 if ( $value !~ /^\d+$/ ) { $value = '"' . $value . '"' }
172 $suffix = "=" . $value;
174 elsif ( $flag =~ /^!/ ) {
175 $prefix .= "no" unless ($value);
176 $short_prefix .= "n" unless ($value);
178 elsif ( $flag =~ /^:/ ) {
179 if ( $value !~ /^\d+$/ ) { $value = '"' . $value . '"' }
180 $suffix = "=" . $value;
186 "# ERROR in dump_options: unrecognized flag $flag for $long_name\n";
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";
200 my $side_comment = "";
201 unless ( $rmy_opts->{q} ) {
202 my $spaces = 40 - length($long_option);
203 $spaces = 2 if ( $spaces < 2 );
205 ' ' x $spaces . '# ' . $short_option . $note;
207 print $long_option . $side_comment . "\n";
212 if ( %{$rabbreviations_user} ) {
213 unless ( $rmy_opts->{q} ) {
215 print "# Abbreviations\n";
217 foreach my $key ( keys %$rabbreviations_user ) {
218 my @vals = @{ $rabbreviations_user->{$key} };
219 print $key. ' {' . join( ' ', @vals ) . '}' . "\n";
224 sub read_perltidyrc {
226 # Example routine to have Perl::Tidy read and validate perltidyrc
227 # file, and return related flags and abbreviations.
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
237 # Perl::Tidy will croak or die on certain severe errors
239 my ($config_file) = @_;
240 my $error_message = "";
241 my %Opts; # any options found will be put here
243 # the module must be installed for this to work
244 eval "use Perl::Tidy";
246 $error_message = "Perl::Tidy not installed\n";
247 return ( $error_message, \%Opts );
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 );
257 my $stderr = ""; # try to capture error messages
258 my $argv = ""; # do not let perltidy see our @ARGV
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 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,
274 # now we call with a .perltidyrc file to get its parameters
278 Perl::Tidy::perltidy(
279 perltidyrc => $config_file,
280 dump_options => \%Opts,
281 dump_options_type => 'perltidyrc', # default is 'perltidyrc'
282 dump_getopt_flags => \%Getopt_flags,
283 dump_options_category => \%sections,
284 dump_abbreviations => \%abbreviations,
289 # try to capture any errors generated by perltidy call
290 # but for severe errors it will typically croak
291 $error_message .= $stderr;
293 # debug: show how everything is stored by printing it out
296 print "---Getopt Parameters---\n";
297 foreach my $key ( sort keys %Getopt_flags ) {
298 print "$key$Getopt_flags{$key}\n";
300 print "---Manual Sections---\n";
301 foreach my $key ( sort keys %sections ) {
302 print "$key -> $sections{$key}\n";
304 print "---Abbreviations---\n";
305 foreach my $key ( sort keys %abbreviations ) {
306 my @names = @{ $abbreviations{$key} };
307 print "$key -> {@names}\n";
308 unless ( $abbreviations_default{$key} ) {
309 print "NOTE: $key is user defined\n";
314 return ( $error_message, \%Opts, \%Getopt_flags, \%sections,
315 \%abbreviations, \%Opts_default, \%abbreviations_default, );