X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=examples%2Fperltidyrc_dump.pl;fp=examples%2Fperltidyrc_dump.pl;h=4ec2115a9a8da44b9076519d333e9e42449944e2;hb=b2d8cef8551aa63c2718732e53392e7ebdd6c75f;hp=0000000000000000000000000000000000000000;hpb=6db2d2d637f1770091b91e756590864baa1ad366;p=perltidy.git

diff --git a/examples/perltidyrc_dump.pl b/examples/perltidyrc_dump.pl
new file mode 100644
index 0000000..4ec2115
--- /dev/null
+++ b/examples/perltidyrc_dump.pl
@@ -0,0 +1,316 @@
+#!/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, );
+}