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