#!/store/bin/perl

##
# Lager en tekstlig oppsummering over mange perl-skript basert på
# kommentarer i filene.
# Kjenner igjen følgende variabler: @project, @module, @status,
# @author, @version, @made, @params, @param, @return og @see.
#
# @author  Petter Reinholdtsen <pere@td.org.uit.no>
# @made    1996-07-17
# @version $Id: extract-comments,v 1.1 2003/06/02 13:01:37 pere Exp $
# @project Origo
# @params  [-p <project>] [-m <module>] <files>
# @return  Oppsummering for alle filene
# @module  Utviklingsverktøy
sub about {}

# require "getopts.pl";  # GNU getopts lib

use Getopt::Std;

$debug = "1";

format HEAD =
~~  ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
    $intro
.

format SUBROUTINE =
@<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
$subroutine
.
format VERSION =
  Versjon:     @<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
               $version
.
format PARAMS =
  Parametre:   @<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
               $params
.
format PARAM =
    @<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
    $paramline
.
format RETVAL =
  Returnerer:  @<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
               $retval
.
format AUTHOR =
  Forfatter(e):^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
$author
~              ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
$author
.
format DESCRIPTION = 
~~   ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
     $intro
.

format HEADER = 
========================================================================

Fil: @<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
     $file
  Prosjekt: @<<<<<<<<<<<<<<<<<<<< Modul: @<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
            $project,                   $module
   Require: @<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
            $require
      Uses: @<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
            $use
.

# &Getopts("pm");
getopts('p:m:f');

@files = @ARGV;

if ($opt_p) {
    $def_project = $opt_p;
}
if ($opt_m) {
    $def_module = $opt_m;
}


undef %info;
foreach $file (@files) {
    if (-f $file && !( $file =~ m%CVS/%)) {
	$exec = &parse_perl_file($file);
	$exec_status{$file} = $exec;
    }
}
&output_info();

##
# Skriver ut alle filene sortert alfabetisk på prosjekt, modul og
# metode.
sub output_info {
    foreach $subroutine (sort keys %info) {
	($project, $module, $file, $method) = split(/;/, $subroutine);
	if ($project ne $lastproject || $module ne $lastmodule ||
	    $file ne $lastfile) {

	    $lastfile = $file;
	    $lastproject = $project;
	    $lastmodule = $module;

	    $use = $use{$file};
	    $use =~ s/;/, /g;
	    $require = $require{$file};
	    $require =~ s/;/, /g;
	    $exec = $exec_status{$file};
	    $file .= " ($exec)" if ($exec);
	    $~ = "HEADER";
	    write;
	    $file = $lastfile;

	    if ($info{"$project;$module;$file;about"}) {
		($intro, $authors, $version, $params, $param, $retval)
		    =split("\t", delete $info{"$project;$module;$file;about"});
		$~ = "AUTHOR"; # XXX skriver ikke ut noenting
		write if ($authors);
		
		$~ = "VERSION";
		write if ($version);
		
		print "\n";
		$~ = "HEAD";
		write;
		
	    }
	    print "\n";
	}
	next if ( $opt_f || $subroutine =~ m/about$/ );
	($intro, $authors, $version, $params, $param, $retval) 
	    = split("\t", $info{$subroutine});
	$subroutine = "$method()";
	@authorlist = split(";", $authors);
	@author = ();
	foreach (@authorlist) {
	    push(@author, m/([^,]+)/);
	     }
	$author = join(", ", @author);

	$~ = "SUBROUTINE";
	write;

	$~ = "VERSION";
	write if ($version);

	$~ = "AUTHOR";
	write if ($author);

	$~ = "DESCRIPTION";
	write if ($intro);

	$~ = "PARAMS";
	write if ($params);

	$~ = "PARAM";
	foreach $paramline (split(/;/, $param)) {
	    write;
	}

	$~ = "RETVAL";
	write if ($retval);
	print "\n";
    }

}

##
# Leser gjennom en perl-fil og leser ut info fra kommentarene om hver
# enkelt subrutine.  Returnerer %info der nøkkel er
# "prosjekt;modul;subrutinene" og innhold er intro,
# forfatterliste(;-delt) og versjon.
# @return "X" if script is executable - "" if not.

sub parse_perl_file {
    &clear_parse_vars();
    $project = ($def_project? $def_project: "");
    $module  = ($def_module? $def_module: "");
    ($file) = @_;
    open(FILE, "<$file");
    undef $first_line;
    undef $subs;
    while (<FILE>) {
	$first_line = $_ unless ($first_line);
	if ( /^##+\s*/ || $running_descrtiption ) {
	    $running_descrtiption = "1";
	    if ( ! /^##*\s*\@[^\s,.:]+\s+/  && /^#/ ) {
		($text) = m/^#+\s*([^#\s]+.*)$/;
		$text =~ s/\t/ /g;
		$intro .= $text." ";
	    } else {
		$running_descrtiption = "";
	    }
	}
	if (! /^#/ ) {
	    if (/^\s*sub\s+([^\{ ]*)\s*\{*/) {
		$subroutine = $1;
		$subs++;
		if ($intro =~ m/^\s+$/) {
		    undef $intro;
		}
		$info{"$project;$module;$file;$subroutine"}
		 = join("\t", $intro, join(";",@authors),
			$version,$params,$param,$retval);
		&clear_parse_vars();
	    }
	    if (/^\s*require\s+(.*);.*$/) {
		$require{$file} = ($require{$file} ? "$require{$file};$1" : $1);
	    }
	    if (/^\s*use\s+(.*);.*$/) {
		$use{$file} = ($use{$file} ? "$use{$file};$1" : $1);
	    }
	    next;
	}
	# Look in all the comments
	if (/^#\s*\@author\s+(.*)$/) {
	    push(@authors, $1);
	}
	if (/^#\s*\@version\s+(.*)$/) {
	    $version =  $1;
	}
	if (/^#\s*\@params\s+(.*)$/) {
	    $params =  $1;
	}
	if (/^#\s*\@param\s+(.*)$/) {
	    $param = ($param ? "$param;$1" : "$1");
	}
	if (/^#\s*\@return\s*(.*)$/) {
	    $retval =  $1;
	}
	if (/^#\s*\@module\s+(.*)$/) {
	    $module =  $1;
	}
	if (/^#\s*\@project\s+(.*)$/) {
	    $project =  $1;
	}

		 
    }
    if (! $subs) {
	$info{"$project;$module;$file;about"} = "\t";

    }
    return ($first_line =~ m%#!/.*/bin/perl%) ? "X" : "";
}
##
# Blanker ut alle nødvendige variabler mellom hver subrutine.  Kalles
# fra parse_perl_file()
# @see parse_perl_file
sub clear_parse_vars {
    undef @authors;
    undef $intro;
    undef $version;
    undef $params;
    undef $param;
    undef $retval;
    undef $running_descrtiption;
}