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 eacy 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     perltidy(
  64         'formatter' => $formatter,    # callback object
  65         'source'    => $fh,
  66         'argv'        => "-npro -se",   # dont need .perltidyrc
  67                                         # errors to STDOUT
  68     );
  69     $fh->close();
  70 }
  71
  72 #####################################################################
  73 #
  74 # The CommentFormatter object has a write_line() method which receives
  75 # tokenized lines from perltidy
  76 #
  77 #####################################################################
  78
  79 package CommentFormatter;
  80
  81 sub new {
  82     my ( $class, $line_length ) = @_;
  83     my $comment_block = "";
  84     bless {
  85         _rcomment_block          => \$comment_block,
  86         _maximum_comment_length  => 0,
  87         _line_length             => $line_length,
  88         _in_hanging_side_comment => 0,
  89       },
  90       $class;
  91 }
  92
  93 sub write_line {
  94
  95     # This is called from perltidy line-by-line
  96     # Comments will be treated specially (reformatted)
  97     # Other lines go to stdout immediately
  98     my $self           = shift;
  99     my $line_of_tokens = shift;
 100     my $line_type      = $line_of_tokens->{_line_type};
 101     ## my $input_line_number = $line_of_tokens->{_line_number};
 102     my $input_line  = $line_of_tokens->{_line_text};  # the orignal line
 103     my $rtoken_type = $line_of_tokens->{_rtoken_type}; # type of tokens
 104     my $rtokens     = $line_of_tokens->{_rtokens}; # text of tokens
 105
 106     # Just print non-code, non-comment lines
 107     if (
 108         $line_type ne 'CODE'    # if it's not code,
 109         || !@$rtokens           # or is a blank line
 110         || $$rtoken_type[-1] ne '#'    # or the last token isn't a comment
 111       )
 112     {
 113         $self->print($input_line);
 114         $self->{_in_hanging_side_comment} = 0;
 115         return;
 116     }
 117
 118     # Now we either have:
 119     # - a line with a side comment (@$rtokens >1), or
 120     # - a full line comment (@$rtokens==1)
 121
 122     # Output a line with a side comment, but remember it
 123     if (@$rtokens > 1) {
 124         $self->print($input_line);
 125         $self->{_in_hanging_side_comment} = 1;
 126         return;
 127     }
 128
 129     # A hanging side comment is a full-line comment immediately
 130     # following a side comment or another hanging side comment.
 131     # Output a hanging side comment directly
 132     if ($self->{_in_hanging_side_comment}) {
 133         $self->print($input_line);
 134         return;
 135     }
 136
 137     # Now we know we have a full-line, non-hanging, comment
 138     # Decide what to do --
 139
 140     # output comment without any words directly, since these don't get
 141     # handled well by autoformat yet.  For example, a box of stars.
 142     # TODO: we could truncate obvious separator lines to the desired
 143     # line length
 144     if ( $$rtokens[-1] !~ /\w/ ) {
 145         $self->print($input_line);
 146     }
 147
 148     # otherwise, append this comment to the group we are collecting
 149     else {
 150         $self->append_comment($input_line);
 151     }
 152     return;
 153 }
 154
 155 sub print {
 156     my ( $self, $input_line ) = @_;
 157     $self->flush_comments();
 158     print $input_line;
 159 }
 160
 161 sub append_comment {
 162     my ( $self, $input_line ) = @_;
 163     my $rcomment_block = $self->{_rcomment_block};
 164     my $maximum_comment_length = $self->{_maximum_comment_length};
 165     $$rcomment_block .= $input_line;
 166     if (length($input_line) > $maximum_comment_length) {
 167         $self->{_maximum_comment_length}=length($input_line);
 168     }
 169 }
 170
 171 {
 172     my ( $separator1, $separator2, $separator3 );
 173
 174     BEGIN {
 175         $separator1 = '-' x 2 . ' Original ' . '-' x 60 . "\n";
 176         $separator2 = '-' x 2 . ' Modified ' . '-' x 60 . "\n";
 177         $separator3 = '-' x 72 . "\n";
 178     }
 179
 180     sub flush_comments {
 181
 182         my ($self)         = @_;
 183         my $rcomment_block = $self->{_rcomment_block};
 184         my $line_length    = $self->{_line_length};
 185         my $maximum_comment_length = $self->{_maximum_comment_length};
 186         if ($$rcomment_block) {
 187             my $comments           = $$rcomment_block;
 188
 189             # we will just reformat lines longer than the desired length for now
 190             # TODO: this can be changed
 191             if ( $maximum_comment_length > $line_length ) {
 192                 my $formatted_comments =
 193                   Text::Autoformat::autoformat( $comments,
 194                     { right => $line_length, all => 1 } );
 195
 196                 if ( $formatted_comments ne $comments ) {
 197                     print STDERR $separator1;
 198                     print STDERR $$rcomment_block;
 199                     print STDERR $separator2;
 200                     print STDERR $formatted_comments;
 201                     print STDERR $separator3;
 202                     if ( ifyes("Accept Changes? [Y/N]") ) {
 203                         $comments = $formatted_comments;
 204                     }
 205                 }
 206             }
 207             print $comments;
 208             $$rcomment_block = "";
 209             $self->{_maximum_comment_length}=0;
 210         }
 211     }
 212 }
 213
 214 sub query {
 215     my ($msg) = @_;
 216     print STDERR $msg;
 217     my $ans = <STDIN>;
 218     chomp $ans;
 219     return $ans;
 220 }
 221
 222 sub queryu {
 223     return uc query(@_);
 224 }
 225
 226 sub ifyes {
 227     my $ans   = queryu(@_);
 228     my $count = 0;
 229   ASK:
 230     if    ( $ans =~ /^Y/ ) { return 1 }
 231     elsif ( $ans =~ /^N/ ) { return 0 }
 232     else {
 233         $count++;
 234         if ( $count > 6 ) { die "error count exceeded in ifyes\n" }
 235         print STDERR "Please answer 'Y' or 'N'\n";
 236         goto ASK;
 237     }
 238 }
 239
 240 # called once after the last line of a file
 241 sub finish_formatting {
 242     my $self = shift;
 243     $self->flush_comments();
 244 }