examples/perlcomment.pl

   1 #!/usr/bin/perl -w
   2 #
   3 # Walk through a perl script and reformat perl comments
   4 # using Text::Autoformat.
   5 #
   6 # usage:
   7 # perlcomment -l72 myfile.pl >myfile.new
   8 #
   9 # where -l specifies the maximum comment line length.
  10 #
  11 # You will be given an opportunity to accept or reject each proposed
  12 # change.
  13 #
  14 # This file demonstrates using Perl::Tidy to walk through a perl file
  15 # and find all of its comments.  It offers to reformat each group of
  16 # consecutive full-line comments with Text::Autoformat.
  17 #
  18 # This may or may not be useful, depending on your coding style.
  19 # Change it to suit your own purposes; see sub get_line().
  20 #
  21 # Uses: Text::Autoformat
  22 #       Perl::Tidy
  23 #
  24 # Steve Hancock, March 2003
  25 # Based on a suggestion by Tim Maher
  26 #
  27 # TODO: (just ideas that probably won't get done)
  28 # -Handle lines of stars, dashes, etc better
  29 # -Need flag to limit changes to lines greater than some minimum length
  30 # -reformat side and hanging side comments
  31 use strict;
  32 use Getopt::Std;
  33 use Text::Autoformat;
  34 $| = 1;
  35 use vars qw($opt_l $opt_h);
  36
  37 my $usage = <<EOM;
  38    usage: perlcomment [ -ln ] filename >outfile
  39           where n=line length (default 72)
  40 EOM
  41
  42 getopts('hl:') or die "$usage";
  43 if ($opt_h) {die $usage}
  44 if ( !defined $opt_l ) {
  45     $opt_l = 72;
  46 }
  47 else {
  48     $opt_l =~ /^\d+$/ or die "$usage";
  49 }
  50
  51 unless ( @ARGV == 1 ) { die $usage }
  52 my $file = $ARGV[0];
  53 autoformat_file( $file, $opt_l );
  54
  55 sub autoformat_file {
  56     my ( $file, $line_length ) = @_;
  57     use Perl::Tidy;
  58     use IO::File;
  59     my $fh = IO::File->new( $file, 'r' );
  60     unless ($fh) { die "cannot open '$file': $!\n" }
  61     my $formatter = CommentFormatter->new($line_length);
  62
  63     my $err=perltidy(
  64         'formatter' => $formatter,    # callback object
  65         'source'    => $fh,
  66         'argv'        => "-npro -se",   # dont need .perltidyrc
  67                                         # errors to STDOUT
  68     );
  69     if ($err) {
  70         die "Error calling perltidy\n";
  71     }
  72     $fh->close();
  73 }
  74
  75 #####################################################################
  76 #
  77 # The CommentFormatter object has a write_line() method which receives
  78 # tokenized lines from perltidy
  79 #
  80 #####################################################################
  81
  82 package CommentFormatter;
  83
  84 sub new {
  85     my ( $class, $line_length ) = @_;
  86     my $comment_block = "";
  87     bless {
  88         _rcomment_block          => \$comment_block,
  89         _maximum_comment_length  => 0,
  90         _line_length             => $line_length,
  91         _in_hanging_side_comment => 0,
  92       },
  93       $class;
  94 }
  95
  96 sub write_line {
  97
  98     # This is called from perltidy line-by-line
  99     # Comments will be treated specially (reformatted)
 100     # Other lines go to stdout immediately
 101     my $self           = shift;
 102     my $line_of_tokens = shift;
 103     my $line_type      = $line_of_tokens->{_line_type};
 104     ## my $input_line_number = $line_of_tokens->{_line_number};
 105     my $input_line  = $line_of_tokens->{_line_text};      # the original line
 106     my $rtoken_type = $line_of_tokens->{_rtoken_type};    # type of tokens
 107     my $rtokens     = $line_of_tokens->{_rtokens};        # text of tokens
 108
 109     # Just print non-code, non-comment lines
 110     if (
 111         $line_type ne 'CODE'    # if it's not code,
 112         || !@$rtokens           # or is a blank line
 113         || $$rtoken_type[-1] ne '#'    # or the last token isn't a comment
 114       )
 115     {
 116         $self->print($input_line);
 117         $self->{_in_hanging_side_comment} = 0;
 118         return;
 119     }
 120
 121     # Now we either have:
 122     # - a line with a side comment (@$rtokens >1), or
 123     # - a full line comment (@$rtokens==1)
 124
 125     # Output a line with a side comment, but remember it
 126     if (@$rtokens > 1) {
 127         $self->print($input_line);
 128         $self->{_in_hanging_side_comment} = 1;
 129         return;
 130     }
 131
 132     # A hanging side comment is a full-line comment immediately
 133     # following a side comment or another hanging side comment.
 134     # Output a hanging side comment directly
 135     if ($self->{_in_hanging_side_comment}) {
 136         $self->print($input_line);
 137         return;
 138     }
 139
 140     # Now we know we have a full-line, non-hanging, comment
 141     # Decide what to do --
 142
 143     # output comment without any words directly, since these don't get
 144     # handled well by autoformat yet.  For example, a box of stars.
 145     # TODO: we could truncate obvious separator lines to the desired
 146     # line length
 147     if ( $$rtokens[-1] !~ /\w/ ) {
 148         $self->print($input_line);
 149     }
 150
 151     # otherwise, append this comment to the group we are collecting
 152     else {
 153         $self->append_comment($input_line);
 154     }
 155     return;
 156 }
 157
 158 sub print {
 159     my ( $self, $input_line ) = @_;
 160     $self->flush_comments();
 161     print $input_line;
 162 }
 163
 164 sub append_comment {
 165     my ( $self, $input_line ) = @_;
 166     my $rcomment_block = $self->{_rcomment_block};
 167     my $maximum_comment_length = $self->{_maximum_comment_length};
 168     $$rcomment_block .= $input_line;
 169     if (length($input_line) > $maximum_comment_length) {
 170         $self->{_maximum_comment_length}=length($input_line);
 171     }
 172 }
 173
 174 {
 175     my ( $separator1, $separator2, $separator3 );
 176
 177     BEGIN {
 178         $separator1 = '-' x 2 . ' Original ' . '-' x 60 . "\n";
 179         $separator2 = '-' x 2 . ' Modified ' . '-' x 60 . "\n";
 180         $separator3 = '-' x 72 . "\n";
 181     }
 182
 183     sub flush_comments {
 184
 185         my ($self)         = @_;
 186         my $rcomment_block = $self->{_rcomment_block};
 187         my $line_length    = $self->{_line_length};
 188         my $maximum_comment_length = $self->{_maximum_comment_length};
 189         if ($$rcomment_block) {
 190             my $comments           = $$rcomment_block;
 191
 192             # we will just reformat lines longer than the desired length for now
 193             # TODO: this can be changed
 194             if ( $maximum_comment_length > $line_length ) {
 195                 my $formatted_comments =
 196                   Text::Autoformat::autoformat( $comments,
 197                     { right => $line_length, all => 1 } );
 198
 199                 if ( $formatted_comments ne $comments ) {
 200                     print STDERR $separator1;
 201                     print STDERR $$rcomment_block;
 202                     print STDERR $separator2;
 203                     print STDERR $formatted_comments;
 204                     print STDERR $separator3;
 205                     if ( ifyes("Accept Changes? [Y/N]") ) {
 206                         $comments = $formatted_comments;
 207                     }
 208                 }
 209             }
 210             print $comments;
 211             $$rcomment_block = "";
 212             $self->{_maximum_comment_length}=0;
 213         }
 214     }
 215 }
 216
 217 sub query {
 218     my ($msg) = @_;
 219     print STDERR $msg;
 220     my $ans = <STDIN>;
 221     chomp $ans;
 222     return $ans;
 223 }
 224
 225 sub queryu {
 226     return uc query(@_);
 227 }
 228
 229 sub ifyes {
 230     my $count = 0;
 231   ASK:
 232     my $ans   = queryu(@_);
 233     if    ( $ans =~ /^Y/ ) { return 1 }
 234     elsif ( $ans =~ /^N/ ) { return 0 }
 235     else {
 236         $count++;
 237         if ( $count > 6 ) { die "error count exceeded in ifyes\n" }
 238         print STDERR "Please answer 'Y' or 'N'\n";
 239         goto ASK;
 240     }
 241 }
 242
 243 # called once after the last line of a file
 244 sub finish_formatting {
 245     my $self = shift;
 246     $self->flush_comments();
 247 }