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 31use strict; 32use Getopt::Std; 33use Text::Autoformat; 34$| = 1; 35use vars qw($opt_l $opt_h); 36 37my $usage = <<EOM; 38 usage: perlcomment [ -ln ] filename >outfile 39 where n=line length (default 72) 40EOM 41 42getopts('hl:') or die "$usage"; 43if ($opt_h) {die $usage} 44if ( !defined $opt_l ) { 45 $opt_l = 72; 46} 47else { 48 $opt_l =~ /^\d+$/ or die "$usage"; 49} 50 51unless ( @ARGV == 1 ) { die $usage } 52my $file = $ARGV[0]; 53autoformat_file( $file, $opt_l ); 54 55sub 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 82package CommentFormatter; 83 84sub 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 96sub 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 158sub print { 159 my ( $self, $input_line ) = @_; 160 $self->flush_comments(); 161 print $input_line; 162} 163 164sub 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 217sub query { 218 my ($msg) = @_; 219 print STDERR $msg; 220 my $ans = <STDIN>; 221 chomp $ans; 222 return $ans; 223} 224 225sub queryu { 226 return uc query(@_); 227} 228 229sub 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 244sub finish_formatting { 245 my $self = shift; 246 $self->flush_comments(); 247} 248