#!/usr/bin/perl

=pod
=begin reST
=begin Id
$Id: perlsynopsis.prl 768 2006-01-28 03:33:28Z marknodine $
Copyright (C) 2002-2005 Freescale Semiconductor, Inc.
Distributed under terms of the GNU General Public License (GPL).
=end Id

=begin Description
Description: Produces reStructuredText documentation for the
subroutines or other internal documentation in a Perl program or module.
It has two modes of operation: subroutine extraction and internal
documentation extraction from comments (using "-c" flag).

When doing subroutine extraction, the program processes package
definitions and subroutine declarations.  To find the argument list
for a subroutine, the program looks for the first executable line of
the subroutine to have the form ::

  ... (<argument_list>) = @_

The comments immediately preceding the sub declaration is processed as
the subroutine's description.  If the "-p" flag is specified, the
description can contain definitions that will be turned into a
definition list in the output.  A definition is recognized as being a
term followed by the definition separator followed by the definition
text (on the same line).  The definition separator defaults to
"${opt_d}", but can be set using the "-d" option.  A long definition
can be specified by having continuation lines indented relative to the
indentation of the definition term; the indentation of the first
continuation line will be subtracted from all succeeding lines to form
the definition.  Definitions may themselves contain definition lists.
For example, using the default separator and "-" processes this comment::

  # Computes the transitive closure to the given depth.
  # Arguments: Integer depth, reference to an object
  #            hash with the following keys:
  #              line:  the line number
  #                     where the object
  #                     occurred
  #              file:  the file containing the
  #                     object
  #              type:  the object's type
  # Returns: transitive closure object
  sub ComputeTC {
    my ($depth, $object) = @_;
    # Does something
  }

to produce::

${\scalar(`perl -ne 'print if /^\\s*# Computes/ .. /^\$/' $0 | $0 -p | perl -pe 's/^/  /'`)}
If the "-c <tag>" option is specified, then instead of generating a list of
subroutines, the program looks for a comment of the form ::

  # <tag>:

and prints out all the succeeding lines to the end of the comment
block (the line preceding the next uncommented line).  If the "-p"
flag is specified, it also does definition list processing.  For
example, running with "-c 'Globals' -p" on the following
code segment ::

  # Globals:
  # @F:   Array of reference to file objects, where each file
  #       object is a hash with the following keys:
  #         name:       File name
  #         access:     Reference to an array
  #                     of users with access
  #                     to the file
  # $ERRORS:  The number of error messages generated

results in the following output

${\scalar(qx(perl -ne 'print if /^\\s*# Globals:/ .. /^\$/' $0 | $0 -p -c 'Globals' | perl -pe 's/^/  /'))}
=end Description

=begin Usage
Usage: ${PROG_NAME} [options] perl-file(s)

Options:
  -h             Print usage help
  -c <tag>       Parse comments starting at <tag> instead of subroutines
  -d <re>        Regular expression separating definition term from entry
                 (default "${opt_d}")
  -l             Print line numbers where definitions occur
  -m             Use reStructuredText inline markup
  -p             Parse comments
  -s <char>      Create sections for each file with <char> as the underline
  -A <str>       Sprintf string for argument string inline markup when -m 
                 is used (default "${opt_A}")
  -Q <re>=<str>  Quote strings in parsed comments that match regular
                 expression <re> using sprintf string <str>
  -R <str>       Sprintf string for routine name inline markup when -m 
                 is used (default "${opt_R}")
  -T <str>       Sprintf string for definition term inline markup when -m 
                 is used (default "${opt_T}")
  -V             Print version info
=end Usage
=end reST
=cut

use strict;

use vars qw($PROG_NAME $FILE $LAST_FILE);
use vars qw($opt_c $opt_d $opt_h $opt_l $opt_m $opt_p $opt_s
	    $opt_A $opt_Q @opt_Q $opt_R $opt_T $opt_V);

$0 =~ m|([^/]+)$|;
$PROG_NAME = $1;

$opt_d = ':[ \t]';
$opt_A = '``%s``';
$opt_R = '**_```%s```**\ ';
$opt_T = '*%s*';
use Getopt::Long;
Getopt::Long::config('no_ignore_case');
Usage() unless GetOptions qw(c=s d=s h l m p s=s A:s Q:s R:s T:s V);
Usage('Id') if $opt_V;
Usage('Description') if $opt_h;
$opt_s = substr($opt_s, 0, 1) if defined $opt_s;
if ($opt_Q =~ /(.+?)=(.*)/) {
    @opt_Q = ($1, $2);
}

my $package = 'main';
my ($comments, $method, $subline, $subname, $substart);
while (<>) {
    close ARGV if (eof);
    if (defined $opt_c) {
	if (/\# $opt_c:/o .. ! /^\s*\#/) {
	    if (! /^\s*\#/) {
		$comments = ParseComments($comments) if $opt_p;
		print "$comments\n";
		$comments = '';
	    }
	    elsif (! /^\s*\# $opt_c/o) {
		s/^\s*\# ?//;
		$comments .= $_;
	    }
	}
    }
    elsif (/^\s*\# ?(.*)/ && ! $substart) {
	/^\# ?(.*)/;
	$comments .= "$1\n";
    }
    elsif (/sub\s+(\w+)((?:\s*:\s*\S+)+)?/) {
	my $attr;
	($subname, $attr) = ($1, $2);
	$substart = 1;
	$FILE = $ARGV =~ m|.*/(.*)| ? $1 : $ARGV;
	$subline = "$FILE, $.";
	$method = $attr =~ /\bmethod\b/;
    }
    else {
	if ($substart) {
	    s/\#.*//;
	    next if /^\s*$/;
	    $substart = 0;
	    my $args = /(\(.*\))\s*=\s*\@_/ ? $1 : '()';
	    my $line = $opt_l ? " ($subline)" : '';
	    my $routine = "${package}::$subname";
	    $routine = sprintf $opt_R, $routine if $opt_m;
	    my $lit = $comments ne '' && ! $opt_p ? ' ::' : '';
	    my $nl = $opt_m ? "$lit\n\n" : "\n";
	    $args = sprintf $opt_A, $args if $opt_m;
	    if (defined $opt_s && $FILE ne $LAST_FILE) {
		print "$FILE\n",($opt_s x length($FILE)),"\n\n" ;
		$LAST_FILE = $FILE;
	    }
	    print "$routine$args:$line$nl";
	    $comments = "INSTANCE METHOD.\n$comments" if $method;
	    $comments = ParseComments($comments) if $opt_p;
	    print map("  $_\n",split(/\n/,$comments)),"\n";
	}
	elsif (/^\s*package\s+([\w:]+)/) {
	    $package = $1;
	    $comments = '';
	}
	$comments = '';
    }
}

# This subroutine attempts to parse comments in a smart way.
sub ParseComments {
    my ($str) = @_;
    $str =~ s|($opt_Q[0])|sprintf $opt_Q[1], $1|geo if @opt_Q;
    my $em = $opt_m ? $opt_T : '%s';
    while ($str =~ s/^( *)(\S.*?)$opt_d *(\S.*)((?:\n(?:\1 .*| *(?=\n)))*)/
	   my($s,$w,$d,$l) = ($1, $2, $3, $4);
	   if ($l =~ m|\n(\s+)|) {
	       my $spaces = ' ' x length($1);
	       $l =~ s|^$spaces|  $s|gm;
	   }
	   $w = sprintf $opt_T, $w if $opt_m;
	   "\n$s$w:\n  $s$d$l"/gemo) { }
    $str =~ s/^( *\n)+//;
    return $str;
}

# This subroutine extracts and prints usage information
sub Usage {
    my ($what) = @_;
    $what = "Usage" if ! $what;
    my $mark = $what eq 'Description' ? "($what|Usage)" : $what;
    if (open(ME,$0) == 1) {
	while (<ME>) {
	    if ((/^=begin $mark/ .. /^=end $mark/) &&
		! /^=(begin|end) $mark/) {
		s/(\$\{[^\}]+\})/eval($1)/ge;
		print;
	    }
	}
	close(ME);
    }
    else {
	print STDERR "Usage not available.\n";
    }
    exit (1);
}