#!/bin/perl -W
##
## Perl script commenting assistant
## Walter Flaat -- wafel@wafel.net (2003)
##
## PURPOSE:
## To assist commenting various tidbits of Perl code. Accounts for ind
+ents.
##
## Arguments:            filein [fileout]
## Expects on STDIN:     answers etc
## Returns to STDOUT:    questions and feedback
## Debug implementation: n/a
## --


# File to proces.. 2nd argument is fileout but defaults to filein
my ($filein, $fileout) = (@ARGV);
die("No file to process") unless $filein;
$fileout ||= $filein;

# Read the script into an array
open (INSCRIPT, "<". $filein) or die $!;
my @line = <INSCRIPT>;
close(INSCRIPT);


# Protect from data-loss.. buffer first
my $output;

# This ignoreNext toggle is needed so we don't comment 
# already commented items
my $ignoreNext;
my $i = 0;
for (@line) {

        # Houston.. we have encountered a perl bangline
        $bang = 1 if /^#!.*perl/;
        # Ignore the next trigger after a comment line.. 
        if (/^##\s+/) {
                $ignoreNext = 1;
                $bang = 0;
        }

        # We don't call the commentors when the trigger is in a commen
+t
        # or when it's been forced into ignorance
        unless ($ignoreNext || /^#/) {
                # Call the commentors
                $output .= scriptcom() if /^\s*$/ && $bang;
                $output .= subcom($i) if /sub\s*\b?\w*\b?\s*\{/;
                $output .= packagecom($i) if /package\s+\b\w+:*\w*\b\s
+*/;
        }
        # After a possible comment run we print out the original line 
+again
        $output .= $_;

        # Below are all the triggers we notice, when one is passed we 
+can 
        # toggle ignoreNext again.. as this was the next.. obviously
        $ignoreNext = 0 if /package|sub|## --/;
        
        $i++;
}

# We're still here... print the output
open (SCRIPT, ">". $fileout) or die $!;
print SCRIPT $output;
close SCRIPT;

## subcom() -- Assist commenting of subroutines
##   Arguments: line nr of infile [n/a]
##   Returns:   scalar comment block
##   Prints:    Max. 10 lines of the sub in question
sub subcom {
        my ($i) = (@_);         # Array item nr that was passed on
        my $ln = $line[$i];     # The scalar in there
        chomp($ln);
        my ($subnm)  = $ln =~ /\s*sub\s+(\w*)/; # Get the name of the 
+sub
        my ($spaces) = $ln =~ /^(\s*).*/;       # Get spaces 
        $subnm ||= "anonymous";
        my $level = 0;
        my $ic = $i;                                       # copy coun
+ter
        print "\n\nSUBROUTINE\n";
        # Show the sub, but no more than 10 lines of it..
        # and don't go past the end of the sub.. EVER
        while ( (@line > $ic) &&  ($i + 10 > $ic) ) {
                $level++ if $line[$ic] =~ /{/;
                $level-- if $line[$ic] =~ /}/;
                print 1+ $ic - $i, " -- ", $line[$ic];
                last unless $level;
                $ic++;
        }
        my $purpose = ask("Purpose of subroutine ". $subnm, 1);
        my $argman =  ask("Mandatory arguments");
        my $argopt =  ask("Optional arguments");
        my $retval =  ask("Return values");
        my $prints =  ask("Prints what");
        return <<EOSUBCOM;
$spaces## $subnm\(\) -- $purpose
$spaces##   Arguments: $argman [$argopt]
$spaces##   Returns:   $retval
$spaces##   Prints:    $prints
EOSUBCOM
}

## scriptcom() -- Assist commenting of Perl script files
##   Arguments: n/a [n/a]
##   Returns:   scalar comment block
##   Prints:    n/a
sub scriptcom {
        $bang = 0;
        my $scriptname = ask("What do you call this script", 1);
        my $purpose    = ask("What purpose does the script have", 1);
        my $argman     = ask("Needs mandatory arguments");
        my $argopt     = ask("Accepts optional arguments");
        my $stdin      = ask("Accepts what from STDIN");
        my $stdout     = ask("Sends what to STDOUT");
        my $debug      = ask("How is debug implemented");
        my $copy       = ask("Who has copyright");
        my $copyyear   = ask("Copyright year(range)");
        return <<EOSCRIPTCOM;
##
## $scriptname
## Copyright $copy ($copyyear)
##
## PURPOSE:
## $purpose
##
## Arguments:            $argman [$argopt]
## Expects on STDIN:     $stdin
## Returns to STDOUT:    $stdout
## Debug implementation: $debug
## --

EOSCRIPTCOM
}

sub packagecom {
        my ($i) = (@_);
        my $ln  = $line[$i];
        chomp($ln);

        my ($packnm) = $ln =~ /package\s+(.*);/;
        print "\n\nPACKAGE: ", $packnm, "\n";
        my $purpose = ask("Summary of purpose", 1);
        my $super   = ask("Superclasses (IS-A)");
        my $sub     = ask("Subclasses");
        my $respon  = ask("Module responsibilities");
        my $collab  = ask("Module collaborates with");
        return <<EOPACKCOM;
## PACKAGE: $packnm
## $purpose
##
## Superclasses (IS-A): $super
## Subclasses:          $sub
## Responsibilities:    $respon
## Collaborations:      $collab
EOPACKCOM
}

## ask() -- Ask questions
##   Arguments: scalar question [mandatory flag]
##   Returns:   scalar answer
##   Prints:    question
sub ask {
        # Question + flag
        my ($q, $mand) = (@_);
        # I hate blocks but they're so damn convenient
        {
                # Non mandatory questions default to [n/a]
                my $na = "";
                $na = " [n/a]" unless $mand;
                print $q, $na, "? ";  # Show me the money! uhh... ques
+tion
                my $ans = <STDIN>;    # Get answer
                chomp($ans);

                # Be annoying..  Re-ask question if no answer came in.
                redo if $mand && $ans =~ /^\s*$/;
                # Return the result
                return "n/a" if $ans =~ /^\s*$/;
                return $ans;
        }
}