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