#!/usr/bin/env perl
#
# David Bateman Feb 02 2003
# 
# Extracts the help in texinfo format from *.cc and *.m files for use
# in documentation. Based on make_index script from octave_forge.

use strict;
use File::Find;
use File::Basename;
use FileHandle;

my $docdir = ".";
if (@ARGV) {
  $docdir = @ARGV[0];
}

# locate all C++ and m-files in current directory
my @m_files = ();
my @C_files = ();
find(\&cc_and_m_files, $docdir);

sub cc_and_m_files { # {{{1 populates global array @files
    return unless -f and /\.(m|cc)$/;  # .m and .cc files
    my $path = "$File::Find::dir/$_";
    $path =~ s|^[.]/||;
    if (/\.m$/) {
        push @m_files, $path;
    } else {
        push @C_files, $path;
    }
} # 1}}}

# grab help from C++ files
foreach my $f ( @C_files ) {
  # XXX FIXME XXX. Should run the preprocessor over the file first, since 
  # the help might include defines that are compile dependent.
    if ( open(IN,$f) ) {
	while (<IN>) {
	    # skip to the next function
	    next unless /^DEFUN_DLD/;

	    # extract function name to pattern space
	    /\((\w*)\s*,/;
	    # remember function name
	    my $function = $1;
	    # skip to next line if comment doesn't start on this line
	    # XXX FIXME XXX maybe we want a loop here?
	    $_ = <IN> unless /\"/;
	    # skip to the beginning of the comment string by
	    # chopping everything up to opening "
	    my $desc = $_;
            $desc =~ s/^[^\"]*\"//;
	    # join lines until you get the end of the comment string
	    # plus a bit more.  You need the "plus a bit more" because
	    # C compilers allow implicitly concatenated string constants
	    # "A" "B" ==> "AB".
	    while ($desc !~ /[^\\]\"\s*\S/ && $desc !~ /^\"/) {
		# if line ends in '\', chop it and the following '\n'
		$desc =~ s/\\\s*\n//;
		# join with the next line
		$desc .= <IN>;
		# eliminate consecutive quotes, being careful to ignore
		# preceding slashes. XXX FIXME XXX what about \\" ?
		$desc =~ s/([^\\])\"\s*\"/$1/;
	    }
	    $desc = "" if $desc =~ /^\"/; # chop everything if it was ""
	    $desc =~ s/\\n/\n/g;          # insert fake line ends
	    $desc =~ s/([^\"])\".*$/$1/;  # chop everything after final '"'
	    $desc =~ s/\\\"/\"/;          # convert \"; XXX FIXME XXX \\"
	    $desc =~ s/$//g;		  # chop trailing ...

	    if (!($desc =~ /^\s*-[*]- texinfo -[*]-/)) {
		my $err = sprintf("Function %s, does not contain texinfo help\n",
				$function);
		print STDERR "$err";
	    }
	    my $entry = sprintf("\037%s\n%s", $function, $desc);
	    print "$entry", "\n";
	}
	close (IN);
    } else {
	print STDERR "Could not open file ($f): $!\n";
    }
}

# grab help from m-files
foreach my $f ( @m_files ) {
    my $desc     = extract_description($f);
    my $function = basename($f, ('.m'));
    die "Null function?? [$f]\n" unless $function;
    if (!($desc =~ /^\s*-[*]- texinfo -[*]-/)) {
	my $err = sprintf("Function %s, does not contain texinfo help\n",
				$function);
	print STDERR "$err";
    }
    my $entry = sprintf("\037%s\n%s", $function, $desc);
    print "$entry", "\n";
}

sub extract_description { # {{{1
# grab the entire documentation comment from an m-file
    my ($file) = @_;
    my $retval = '';

    if( open( IN, "$file")) {
	# skip leading blank lines
	while (<IN>) {
	    last if /\S/;
	}
	if( m/\s*[%\#][\s\#%]* Copyright/) {
	    # next block is copyright statement, skip it
	    while (<IN>) {
		last unless /^\s*[%\#]/;
	    }
	}
	# Skip everything until the next comment block
	while ( !/^\s*[\#%]/ ) {
	    $_ = <IN>;
	    last if not defined $_;
	}
        # Return the next comment block as the documentation
        while (/^\s*[\#%]/) {
	    s/^[\s%\#]*//;    # strip leading comment characters
            s/[\cM\s]*$//;   # strip trailing spaces.
	    s/[\.*]$//;
	    $retval .= "$_\n";
	    $_ = <IN>;
	    last if not defined $_;
	}
        close(IN);
	return $retval;
    }
    else {
	print STDERR "Could not open file ($file): $!\n";
    }
} # 1}}}