examples/perltidyrc_dump.pl

   1 #!/usr/bin/perl -w
   2 use 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 #
  14 my $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
  25 EOM
  26 use Getopt::Std;
  27 my %my_opts;
  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" }
  32
  33 my $config_file = $ARGV[0];
  34 my (
  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
  42 if ($error_message) {
  43     die "$error_message\n";
  44 }
  45
  46 # make a list of perltidyrc options which are same as default
  47 my %equals_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 );
  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.
  62 if ( $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
  69 my %abbreviations_user;
  70 foreach my $key ( keys %$rabbreviations ) {
  71     unless ( $rabbreviations_default->{$key} ) {
  72         $abbreviations_user{$key} = $rabbreviations->{$key};
  73     }
  74 }
  75
  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 );
  80 }
  81 else {
  82     if ($config_file) {
  83         print STDERR <<EOM;
  84 No configuration parameters seen in file: $config_file
  85 EOM
  86     }
  87     else {
  88         print STDERR <<EOM;
  89 No .perltidyrc file found, use perltidy -dpro to see locations checked.
  90 EOM
  91     }
  92 }
  93
  94 sub 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
 224 sub 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     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
 274     # now we call with a .perltidyrc file to get its parameters
 275     my %Getopt_flags;
 276     my %sections;
 277     my %abbreviations;
 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,
 285         stderr                => \$stderr,
 286         argv                  => \$argv,
 287     );
 288
 289     # try to capture any errors generated by perltidy call
 290     # but for severe errors it will typically croak
 291     $error_message .= $stderr;
 292
 293     # debug: show how everything is stored by printing it out
 294     my $DEBUG = 0;
 295     if ($DEBUG) {
 296         print "---Getopt Parameters---\n";
 297         foreach my $key ( sort keys %Getopt_flags ) {
 298             print "$key$Getopt_flags{$key}\n";
 299         }
 300         print "---Manual Sections---\n";
 301         foreach my $key ( sort keys %sections ) {
 302             print "$key -> $sections{$key}\n";
 303         }
 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";
 310             }
 311         }
 312     }
 313
 314     return ( $error_message, \%Opts, \%Getopt_flags, \%sections,
 315         \%abbreviations, \%Opts_default, \%abbreviations_default, );
 316 }