#!/usr/bin/env perl

=head1 NAME

fixcomments.pl

=head1 SYNOPSIS

fixcomments.pl [options] [infile]

=head1 OPTIONS

=over 4

=item B<infile>

Input file to process (uses stdin if not specified)

=item B<--help|-h>

A little help

=item B<--verbose|-v>

Output debug messages (to stderr), repeat for even more output

=back

=head1 DESCRIPTION

This script will read a Fortran file and attempt to add doxify comments
to both FUNCTIONs and SUBROUTINEs.

=cut

use strict;
use warnings;
use open qw(:std :utf8);
use FindBin;
use lib "$FindBin::RealBin/lib";
use Pod::Usage qw(pod2usage);
use Getopt::Long;

my $verbose = 0;
my $help = 0;

GetOptions(
    'verbose+' => \$verbose,
    'help|?' => \$help) or pod2usage(2);
pod2usage(1) if $help;

sub print_debug {
    print(STDERR "DEBUG: @_\n") if ($verbose > 0);
}

# Regular expressions for matching
my $DOXYGEN_HEADER = "^!>";

# The empty string
my $EMPTY = q{};

# Toggle variables to keep track of which doxygen item is being processed
# in the current header.
my ($hasParam,
    $hasBrief,
    $hasPar,
    $hasDate,
    $hasVersion,
    $hasAuthor,
    $hasNote,
    $hasRetVal,
    $hasReturn,
    $hasRandom,
    $hasRemainder);

# Variables with s at the end contains the actual text read in from
# existing doxygen header
my (%params,
    $briefs,
    $dates,
    $versions,
    $pars,
    $authors,
    $notes,
    $retVals,
    $returns,
    $randoms,
    $remainders);

# If currently in INTERFACE block
my $insideInterface = 0;

# Whether the SUBROUTINE/FUNCTION definition contains an & line continuation
my $hasAmpersand = 0;

# Whether when processing subroutine definition we are in brackets
my $inParentheses = 0;

# Whether the procedure definition contains the RETURN value
my $hasReturnAsArg = 0;

# Keeps track of which parameters in the current procedure have
# a matching doxygen header
my %matched;

# Buffer for lines
my $buffer = $EMPTY;

# The old doxygen header as read from file
my $oldheader = $EMPTY;

# Any unprocessed lines
my $leftoverlines = $EMPTY;

# The name of the procedure being processed
my $procedureName = $EMPTY;

# Whether the procedure is a function
my $isFunction;

initVariables();

# While there are still lines to read in our INPUT file
while (<>) {
    # Get the line we've just read in
    my $currline = $_;

    # If an existing doxygen header is encountered then process
    if (matchDoxygenHeaderDefinition($currline)) {
        print_debug("Matched doxygen header");
        $currline = processDoxygenHeader($currline);
    }

    # Are we inside an interface block?
    # If so we don't want to add any comments here
    if ( $currline =~ m/^\s*INTERFACE\s*\n/xms ) {
        print_debug("Start of INTERFACE encountered");
        $insideInterface = 1;
    }
    if ( $currline =~ m/^\s*END\s+INTERFACE\s*\n/xms ) {
        print_debug("End of INTERFACE encountered");
        $insideInterface = 0;
    }

    # Look for procedure (SUBROUTINE/FUNCTION definitions)
    # These can be the initial definition line, or a continuation line
    # We don't add comments to code inside an interface block
    if ((matchSubroutineDefinition($currline) || $hasAmpersand)
        && !($insideInterface)) {
        print_debug("Matched subroutine definition");
        processSubroutineDefinition($currline);
    } else {
        print_debug("Subroutine definition not matched");
        if ($oldheader eq $EMPTY) {
            # No header remaining so just print out line as read
            print_debug("Empty old header, writing out line:");
            print_debug($currline);
            print $currline;
        } else {
            # Header has been processed, need to do something with remaining lines
            print_debug("Non-empty old header for line:");
            print_debug($currline);
            if (($currline =~ m/^\s*$/xms) ||
                ($currline =~ m/\#if/xms)) {
                # Blank line or #if line, so store for printing later
                print_debug("Empty line or #if, storing for later");
                $leftoverlines = $leftoverlines . $currline;
            } elsif ($currline =~ m/^\s*!\s*/xms) {
                # Have a comment so add to header
                print_debug("Inline comment, adding to header");
                $oldheader = $oldheader . $currline;
            } else {
                # If it was a MODULE or TYPE header we still need to write
                # it back out to file.
                print_debug("Writing existing non FUNCTION/SUBROUTINE header to file");
                print $oldheader;
                print $leftoverlines;
                print $currline;
                # Reset variables after output
                initVariables();
            }
        }
    } # End of the if (($currline is SUBROUTINE or FUNCTION ) block
} # End of main while loop

# Perhaps do a second pass to remove any double occurrences of !> *** type lines

sub initToggles {
    $hasParam = 0;
    $hasBrief = 0;
    $hasPar = 0;
    $hasDate = 0;
    $hasVersion = 0;
    $hasAuthor = 0;
    $hasNote = 0;
    $hasRetVal = 0;
    $hasRandom = 0;
    $hasRemainder = 0;
    return;
}

sub initVariables {
    initToggles();
    undef %params;
    undef %matched;
    $briefs = $EMPTY;
    $dates = $EMPTY;
    $versions = $EMPTY;
    $pars = $EMPTY;
    $authors = $EMPTY;
    $notes = $EMPTY;
    $retVals = $EMPTY;
    $returns = $EMPTY;
    $randoms = $EMPTY;
    $remainders = $EMPTY;
    $buffer = $EMPTY;
    $oldheader = $EMPTY;
    $leftoverlines = $EMPTY;
    $procedureName = $EMPTY;
    $isFunction = 0;
    $inParentheses = 0;
    return;
}

# Look for a doxygen header definition in an input line.
sub matchDoxygenHeaderDefinition {
    my ($lineToProcess) = @_;

    print_debug("Trying to match doxygen header $DOXYGEN_HEADER against line");
    print_debug($lineToProcess);

    my $match = 0;

    if ($lineToProcess =~ m/$DOXYGEN_HEADER/xms) {
        $match = 1;
    }

    print_debug("Doxygen header match value: $match");
    return $match;
}

# Look for SUBROUTINE or FUNCTION definitions.
sub matchSubroutineDefinition {
    my ($lineToProcess) = @_;

    print_debug("Trying to match subroutine definition against line:");
    print_debug($lineToProcess);

    # Immediately discount lines with comments at the start
    my $commentPattern = '^\!';
    if ($lineToProcess =~ m/$commentPattern/xms) {
        print_debug("Matched comment");
        return 0;
    }
    # Assume that lines contain SUBROUTINE or FUNCTION followed by space
    # and then the name of the procedure which may have a space before the (
    my $patternProcWithBrackets = '(SUBROUTINE|FUNCTION)'    # Subroutine or function
                                 .'\s+'                      # followed by one or more whitespace characters
                                 .'(\w|\[|\])+'              # followed by one or more of (word or [ or ])
                                 .'\s*'                      # followed by zero or more whitespace characters
                                 .'\(';                      # followed by open bracket.

    # Need to allow for SUBROUTINE without any arguments or brackets too
    my $patternSubNoBracketsAtStartOfLine = '^\s*'           # Start with zero or more whitespace
                                           .'SUBROUTINE'     # then subroutine
                                           .'\s*'            # then zero or more whitespace
                                           .'(\w|\[|\])+'    # then one or more of (word or [ or ])
                                           .'\s*.*';         # then zero or more whitespace

    # We also protect against adding comments to commented out SUBROUTINE/FUNCTION calls
    my $patternCommentedOut = '!\s*(SUBROUTINE|FUNCTION)';

    # Protect against definitions inside quotes
    my $patternInQuotes = '"\s*(SUBROUTINE|FUNCTION)';

    my $match1 = 0;
    my $match2 = 0;
    my $match3 = 0;
    my $match4 = 0;

    if ($lineToProcess =~ m/$patternProcWithBrackets/xms) {
        $match1 = 1;
    }
    if ($lineToProcess =~ m/$patternSubNoBracketsAtStartOfLine/xms) {
        $match2 = 1;
    }
    if ($lineToProcess =~ m/$patternCommentedOut/xms) {
        $match3 = 1;
    }
    if ($lineToProcess =~ m/$patternInQuotes/xms) {
        $match4 = 1;
    }

    my $match = (($match1 || $match2) && !($match3) && !($match4));
    print_debug("Subroutine definition match value: $match");
    return $match
}

sub processDoxygenHeader {

    my ($currline) = @_;

    print_debug("Processing Doxygen Header");

    # Each time we find a header we need to reset toggles and their data
    initVariables();
    my $paramName = $EMPTY;

    # Start of do-while over match on ($currline =~ m/^\s*!/i)
    do {
        print_debug("Processing header line:");
        print_debug($currline);
        # Keep the headers safe, may need them! We use the oldheader variable to
        # keep the complete headers for MODULE and TYPE intact such that we
        # can just dump them straight back out without making any changes.
        $oldheader = $oldheader . $currline;
        # Pick up parameters - matches the word param separated by spaces
        if (($currline =~ m/!>\s\\param\s+(\S+)\s*/xms) ||
            ($currline =~ m/!>\s\\param\[.*\]\s+(\S+)\s*/xms)) {

            # Get the param name
            $paramName = $1;

            print_debug("Got header for parameter $paramName");

            # Cover the case where two arguments have the same name
            if (exists $params{$paramName}) {
                $paramName = $paramName . "new";
            }
            # Store the param into a hash indexed by its name
            $params{$paramName} = $currline;
            # Set matched for this param to zero as we don't
            # yet have a match in the argument list
            $matched{$paramName} = 0;
            initToggles();
            $hasParam = 1;
        } elsif ($currline =~ m/!>\s\\brief\s*/xms) {
            print_debug("Got briefs header");
            $briefs = $briefs . $currline;
            initToggles();
            $hasBrief = 1;
        } elsif ($currline =~ m/!>\s\\date*/xms) {
            print_debug("Got dates header");
            $dates = $dates . $currline;
            initToggles();
            $hasDate = 1;
        } elsif ($currline =~ m/!>\s\\version\s*/xms) {
            print_debug("Got version header");
            $versions = $versions . $currline;
            initToggles();
            $hasVersion = 1;
        } elsif ($currline =~ m/!>\s\\par\s*/xms) {
            print_debug("Got par header");
            $pars = $pars . $currline;
            initToggles();
            $hasPar = 1;
        } elsif ($currline =~ m/!>\s\\author\s*/xms) {
            print_debug("Got author header");
            $authors = $authors . $currline;
            initToggles();
            $hasAuthor= 1;
        } elsif ($currline =~ m/!>\s\\note\s*/xms) {
            print_debug("Got note header");
            $notes = $notes . $currline;
            initToggles();
            $hasNote = 1;
        } elsif ($currline =~ m/!>\s\\retval\s*/xms) {
            print_debug("Got retval header");
            $retVals = $retVals . $currline;
            initToggles();
            $hasRetVal = 1;
        } elsif ($currline =~ m/!>\s\\returns\s*/xms) {
            print_debug("Got return header");
            $returns = $returns . $currline;
            initToggles();
            $hasReturn = 1;
        } elsif ($currline =~ m/!>\s\\return\s*/xms) {
            print_debug("Got return header");
            $returns = $returns . $currline;
            initToggles();
            $hasReturn = 1;
        } elsif ($currline =~ m/!>\s\\\S+/xms) {
            # Randoms contains anything else that looks
            # like a DOXYGEN header. with a \whatever
            # Must check to see if line has already been commented.
            # We also avoid commenting a blank \param line
            print_debug("Got random header");
            if (($currline !~ m/UNKNOWN_DOXYGEN_COMMENT/xms) &&
                ($currline !~ m/UNKNOWN_COMMENT/xms) &&
                ($currline !~ m/!>\s*\\param\s*\n/xms)) {
                $randoms = $randoms . $currline;
                chomp($randoms);
                # Add on text for output
                $randoms = $randoms . " UNKNOWN_DOXYGEN_COMMENT\n";
            } else {
                # Otherwise just add to randoms
                $randoms = $randoms . $currline;
            }
            initToggles();
            $hasRandom = 1;
        } elsif ($currline =~ m/^!>\s*/xms) {
            # Handle multi line entries. Append what you find onto the
            # previous one read in until you get to another \
            # The \brief, \param, \par, \author, random and remainder
            # entries can all be multi-line.
            # The \version and \date entries should be single line and
            # thus we don't have an elsif for them.
            print_debug("Got line continuation");
            if ($hasParam) {
                $params{$paramName} = $params{$paramName} . $currline;
            } elsif ($hasBrief) {
                $briefs = $briefs . $currline;
            } elsif ($hasPar) {
                $pars = $pars . $currline;
            } elsif ($hasAuthor) {
                $authors = $authors . $currline;
            } elsif ($hasNote){
                $notes = $notes . $currline;
            } elsif ($hasRetVal) {
                $retVals = $retVals . $currline;
            } elsif ($hasReturn) {
                $returns = $returns . $currline;
            } elsif ($hasRandom) {
                # Must check to see if line has already been commented
                if (($currline !~ m/UNKNOWN_DOXYGEN_COMMENT/xms) &&
                    ($currline !~ m/UNKNOWN_COMMENT/xms)) {
                    $randoms = $randoms . $currline;
                    chomp($randoms);
                    # Add on text for output
                    $randoms = $randoms . " UNKNOWN_DOXYGEN_COMMENT\n";
                } else {
                    $randoms = $randoms . $currline;
                }
            } else {
                # Get any header lines beginning with "!> some text but
                # no \ thus not in DOXYGEN format
                $hasRemainder = 1;
                # Must check to see if the line has already been
                # commented and also that it's not empty
                if (($currline !~ m/UNKNOWN_COMMENT/xms) &&
                    ($currline !~ m/!>\s*\n/xms)) {
                    # Add on text for output
                    $currline =~ s/!>/!> \\note UNKNOWN_COMMENT /gx;
                    $remainders = $remainders . $currline;
                } else {
                    $remainders = $remainders . $currline;
                }
            }
        } elsif ($currline !~ m/^!\s*\*/xms) {
            # Any other header line that's not "***..." or a Doxygen
            # comment, ie "! some comment or other"
            print_debug("Got non-doxygen line");
            if ($hasBrief) {
                # Put comment in brief, replacing ! with !>
                $currline =~ s/!/!>/xms;
                $briefs = $briefs . $currline;
            } else {
                $currline =~ s/^\s+//;
                # Must check to see if line has already been commented
                if ($currline !~ m/UNKNOWN_COMMENT/xms) {
                    # Add on text for output, changing ! for !>
                    $currline =~ s/!/!> \\note UNKNOWN_COMMENT /gx;
                    $remainders = $remainders . $currline;
                } else {
                    $remainders = $remainders . $currline;
                }
            }
        }
        # Get the next line in the header block
        $currline = <>;
    } while ($currline =~ m/^\s*!/xms); # Rule as to when you have finished a header. Currently Anything beginning with !
    return $currline;
} # End of header processing subroutine

sub processSubroutineDefinition {

    my ($currline) = @_;

    print_debug("Processing Subroutine line:");
    print_debug($currline);
    # functionLine will contain the procedure definition with any
    # unrequired text stripped off, $currline will still contain the actual code
    my $functionLine = $EMPTY;
    if (!($hasAmpersand)) {
        # Remove anything preceding the SUBROUTINE or FUNCTION definition
        # e.g. RECURSIVE, REAL, INTEGER, (KIND=dp), ELEMENTAL etc etc.
        $currline =~ /((\bFUNCTION\b|\bSUBROUTINE\b).+)/x;
        # $1 contains whatever remains after removing anything before the
        # word SUBROUTINE or FUNCTION
        $functionLine = $1;
    } else {
        $functionLine = $currline;
    }
    # Remove BIND(*) from the definition
    my $tmp = $functionLine;
    $tmp =~ s/\bBIND\b\(\w+\W*\w*\W*\w*\W*\)//x;
    $functionLine = $tmp;

    # Strip the newline char from the end
    chomp($functionLine);

    $hasAmpersand = 0;
    $hasReturnAsArg = 0;
    my $lelement = $EMPTY;

    # Split the subroutine or function definition by space or comma
    my @string = split(/([,\(\)\s+]+)/x, $functionLine);

    for (my $idx = 0; $idx < scalar(@string); $idx++) {
        my $p = $string[$idx];
        defined $p or next;  # continue with the next item if $p is undefined

        $p =~ s/^\s+|\s+$//gx;

        $p ne $EMPTY or next;  # continue with the next item if empty
        $p ne "," or next;  # or simply the ','

        print_debug("Processing item $p");
        if ($p eq "&") {
            # If we encounter an & as the last element in this line it starts a line continuation,
            # otherwise it is the continuation point of a previous one and we can ignore it
            $idx == $#string or next;
            print_debug("Got & line continuation");
            $hasAmpersand = 1;
            # Buffer the line details as we can't print out yet
            $buffer = "$buffer$currline";
        } elsif ($p eq "(") {
            print_debug("Entered parentheses");
            $inParentheses = 1;
        } elsif ($p eq ")") {
            print_debug("Left parentheses");
            $inParentheses = 0;
        } elsif ($p eq ",") {
            print_debug("Comma");
        } else {
            if ($inParentheses) {
                print_debug("In parentheses, parameter: $p, previous parameter: $lelement");
                # Must have either a parameter of a function return value
                if (($lelement =~ m/RESULT/ixms) && ($hasReturnAsArg)) {
                    print_debug("Got return parameter $p");
                    if ($returns eq $EMPTY) {
                        # If the previous element was RESULT outside of
                        # parantheses then this element must be whatever
                        # gets returned by the procedure.
                        # if no return data is available print out the ...
                        # to header
                        # Only stored for now so it is always printed
                        # in the same place (after the \params)
                        $returns = "!> \\return ...\n";
                    }
                } else {
                    # Must be parameter
                    # Update the matched hash table so that all arguments
                    # in subroutine/function header are set as true
                    print_debug("Processing parameter $p");
                    $matched{$p} = 1;
                    if (!(exists($params{$p})) || !(defined($params{$p})) || ($params{$p} eq $EMPTY)) {
                        # If the entry for this parameter is missing we use
                        # the standard text for a missing entry
                        print_debug("Missing entry for parameter $p, creating blank");
                        print "!> \\param $p ...\n";
                    } else {
                        print_debug("Using existing entry for parameter $p");
                        if ($params{$p} !~ m/\\param\s*(\w+|\[.*\]\s+\w+)\s*\n/xms ) {
                            # Entry must contain some text after the parameter name
                            print_debug("Using entry unchanged");
                            print $params{$p};
                        } else {
                            if ($params{$p} =~ m/!>\s*\n$/x) {
                                # We need to guard against \param entries which have
                                # no text but have a blank line "!>" line appended
                                # Need to split this parameter into it's individual lines
                                my @tmpString = split(/\n/x, $params{$p});
                                # Find out how many lines we have in this entry
                                my $tmpLen = scalar(@tmpString);
                                # Append on the ... to the first line
                                $tmpString[0] = $tmpString[0] . " ...";
                                for (my $i = 0; $i < $tmpLen; $i++) {
                                    # Re-add the carriage return to each line
                                    print "$tmpString[$i]\n";
                                }
                            } else {
                                chomp($params{$p});
                                print $params{$p}," ...\n";
                            }
                        }
                    }
                }
            } else {
                print_debug("Processing element not in parentheses: $p");
                if ($lelement =~ m/(SUBROUTINE|FUNCTION)/ixms) {
                    # Previous element is FUNCTION or SUBROUTINE so this must be name
                    $procedureName = $p;
                    print_debug("Got procedure name $procedureName");
                    if ($lelement =~ m/FUNCTION/ixms) {
                        $isFunction = 1;
                    }
                    if (($briefs eq $EMPTY) or ($briefs eq "!> \\brief\n")) {
                        # \brief does not exist or is present but empty - add text
                        print "! **************************************************************************************************\n";
                        print "!> \\brief ...\n";
                    } else {
                        # \brief exists and contains text
                        print $briefs;
                    }
                } elsif ($p =~ m/RESULT/ixms) {
                    # Check to see if parameter is RESULT for a FUNCTION
                    print_debug("Need to get function result parameter");
                    $hasReturnAsArg = 1;
                }
            }
            $lelement = $p; # Take a note of the array element for comparison, ignoring & and ()
        }
    } # End of for loop over @string

    # Code to loop over all the elements of matched hash table. If any
    # remain that were not in the function/subroutine header we want to
    # make sure we keep this data in the header. It could be a comment
    # or it could refer to old arguments that no longer exist.
    # However, we don't want to throw the text away. We only print out
    # if the argument doesn't match one of the arguments *and* there is
    # no more of the procedure definition left to read, i.e. hasAmpersand is false
    foreach my $paramName (sort keys %params) {
        # We need to sort the keys otherwise the output order of the hash
        # is given in internal order
        if (!($matched{$paramName}) && !($hasAmpersand)) {
            if ($params{$paramName} eq '!> \param '.$paramName." ...\n") {
                # there was no comment, just drop parameter
            } elsif ($params{$paramName} !~ m/UNMATCHED_PROCEDURE_ARGUMENT/) {
                # Must protect against updating an existing comment
                # Get rid of \n so UNMATCHED* text can be appended on.
                chomp($params{$paramName});
                print $params{$paramName} . " UNMATCHED_PROCEDURE_ARGUMENT: please check \n";
            } else {
                print $params{$paramName};
            }
        }
    }

    # If after looping through the elements there is no ampersand
    # we close off the comment and write out the procedure definition
    if (!($hasAmpersand)) {
        if ($returns ne $EMPTY) {
            # Print RESULT value first so that it should come straight after the \param definitions
            print $returns;
        } else {
            # Get return value from function name
            if ($isFunction) {
                print "!> \\return ...\n";
            }
        }
        if ($retVals ne $EMPTY) {
            # Print return values definitions second so that they come after any \return definitions
            print $retVals;
        }
        if (($dates eq $EMPTY) || ($dates eq "!> \\date\n")) {
            # dates entry empty or exists and contains no text
###            print "!> \\date MISSING_COMMENT: Unknown\n";  # Use this line if you want to add text to the entry
            print $dates;
        } else {
            print $dates;
        }
        if (($pars eq $EMPTY) || ($pars eq "!> \\par History\n")) {
            # pars entry empty or exists but contains no text
###            print "!> \\par History\n"; # Use this line if you want to add text to the entry
###            print "!>     MISSING_COMMENT: Unknown\n"; # Use this line if you want to add text to the entry
            print $pars;
        } else {
            print $pars;
        }
        if (($authors eq $EMPTY) || ($authors eq "!> \\author\n")) {
            # authors empty or exists but contains no text
###            print "!> \\author MISSING_COMMENT: Unknown\n"; # Use this line if you want to add text to the entry
            print $authors;
        } else {
            print $authors;
        }
        if ($versions ne $EMPTY) {
            print $versions;
        }
        if ($randoms ne $EMPTY) {
            print $randoms;
        }
        if ($notes ne $EMPTY){
            print $notes;
        }
        if ($remainders ne $EMPTY) {
            # Dumps out whatever else remainded in the header (e.g. stuff beginning !> without a \ or stuff beginning with just a !) for the SUBROUTINE/FUNCTION at the end
            print $remainders;
        }
        print "! **************************************************************************************************\n";
        print "$leftoverlines$buffer$currline";
        # Reset all the variables after writing out the header
        initVariables();
        return;
    }
}