#!/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; } }
In reply to Perl script commenting assistant by Wafel
| For: | Use: | ||
| & | & | ||
| < | < | ||
| > | > | ||
| [ | [ | ||
| ] | ] |