#!/usr/bin/perl -w
#This script reads in output generated by executing gimp-procedural-db-dump
#in GIMP and outputs a summary with a list of replacement procedures where
#the replacement does not exist, a list of obsolete procedures (ones with no
#replacement), and the names of deprecated procedures (both with and without
#changes in the number of expected arguments).
#
# Usage:
# ./list-pdb-deprecations.pl < pdb.dump
#
#Kevin Cozens
#April 10, 2006
#
#Updated October 23, 2006  Kevin Cozens
#Changed output_procedure_name to split on " character. This fixes the
#parsing of the PDB dump created by a patched version 2.2 of GIMP.
#
#Updated December 10, 2010  Kevin Cozens
#Changed string used to detect if a procedure has been deprecated.
#
#Updated February 8, 2011  Kevin Cozens
#All deprecation messages are now recognized by output_new_procedure_name.
#
#Updated February 13, 2011  Kevin Cozens
#Added checks to make sure the replacements for deprecated functions exist.
#
#Updated March 1, 2011  Kevin Cozens
#Enhanced the report generated by this script. The deprecated procedures
#reported in one of four categories as mentioned in the description at
#the top of this file.

$show_arg_counts = 0;

if (@ARGV)
{
    if ($ARGV[0] eq "-h" || $ARGV[0] eq "--help")
    {
        print "Usage: $0 [-c|-h|--help]\n";
        print "       -h, --help Show this usage information\n";
        print "       -c         Show procedure argument counts in output\n";
        print "\n";
        exit;
    }

    if ($ARGV[0] eq "-c")
    {
        $show_arg_counts = 1;
        shift(@ARGV);
    }
}

$obsolete = ();

while (<>)
{
    #We can't do anything until we locate the start of a register block
    if ($_ =~ /^.register-procedure/)
    {
        #Extract and save a procedure name and its argument count
        $old_procedure_name = &get_old_procedure_name($_);

        &check_if_procedure_is_deprecated($old_procedure_name);
        &find_procedure_input_arguments;
        $procedures{$old_procedure_name} = &get_argument_count;
    }
}


#Now that we have a list of all known PDB procedures and their argument counts
#in addition to a list of deprecated procedures and their replacements, output
#a summary of the information.

#Print a list of any replacement procedure that has not been defined in PDB
print "The following is a list of replacement procedures that do not exist:\n";
foreach $new_procedure_name (sort(values(%deprecated)))
{
    if (!exists($procedures{$new_procedure_name}))
    {
        print "    $new_procedure_name\n";
    }
}
print "\n";

#List deprecated functions that have no replacement
print "The following deprecated functions have no replacement:\n";
foreach $old_procedure_name (@obsolete)
{
    print "    $old_procedure_name\n";
}
print "\n";

#List functions where the number of arguments didn't change between old and new
print "Deprecated procedures with a one-to-one replacement:\n";
foreach $old_procedure_name (sort(keys(%deprecated)))
{
    $new_procedure_name = $deprecated{$old_procedure_name};

    if (exists($procedures{$new_procedure_name}) &&
        $procedures{$old_procedure_name} == $procedures{$new_procedure_name})
    {
        print "    \"$old_procedure_name\", \"$new_procedure_name\"\n";
    }
}
print "\n";

#List functions where the number of arguments has changed between old and new
print "Deprecated procedures where the replacement has more arguments:\n";
foreach $old_procedure_name (sort(keys(%deprecated)))
{
    $new_procedure_name = $deprecated{$old_procedure_name};

    if (exists($procedures{$new_procedure_name}) &&
        $procedures{$new_procedure_name} > $procedures{$old_procedure_name})
    {
        if ($show_arg_counts == 0)
            { print "    \"$old_procedure_name\", \"$new_procedure_name\"\n"; }
        else
            { print "    \"$old_procedure_name\" (", $procedures{$old_procedure_name}, "), \"$new_procedure_name\" (", $procedures{$new_procedure_name}, ")\n"; }
    }
}
print "\n";

#List functions where the number of arguments has changed between old and new
print "Deprecated procedures where the replacement has fewer arguments\nand is not one of the item API procedures:\n";
foreach $old_procedure_name (sort(keys(%deprecated)))
{
    $new_procedure_name = $deprecated{$old_procedure_name};

    if (exists($procedures{$new_procedure_name}) &&
        $procedures{$new_procedure_name} < $procedures{$old_procedure_name} &&
        $new_procedure_name !~ /-item/)
    {
        if ($show_arg_counts == 0)
            { print "    \"$old_procedure_name\", \"$new_procedure_name\"\n"; }
        else
            { print "    \"$old_procedure_name\" (", $procedures{$old_procedure_name}, "), \"$new_procedure_name\" (", $procedures{$new_procedure_name}, ")\n"; }
    }
}
print "\n";

#List functions where the number of arguments has changed between old and new
print "Deprecated procedures where the replacement has fewer arguments\nand is one of the item API procedures:\n";
foreach $old_procedure_name (sort(keys(%deprecated)))
{
    $new_procedure_name = $deprecated{$old_procedure_name};

    if (exists($procedures{$new_procedure_name}) &&
        $procedures{$new_procedure_name} < $procedures{$old_procedure_name} &&
        $new_procedure_name =~ /-item/)
    {
        if ($show_arg_counts == 0)
            { print "    \"$old_procedure_name\", \"$new_procedure_name\"\n"; }
        else
            { print "    \"$old_procedure_name\" (", $procedures{$old_procedure_name}, "), \"$new_procedure_name\" (", $procedures{$new_procedure_name}, ")\n"; }
    }
}
exit;


sub get_old_procedure_name
{
    local (@words);

    @words = split(/\"/, "@_");
    $words[1] =~ s/_/-/g;
    $words[1] =~ s/ [<]1[>]//;
    return $words[1];
}


#This function handles four main types of deprecated messages:
#  "Deprecated: There is no replacement for this procedure."
#  "Deprecated: Use 'xxx' instead."
#  "This procedure is deprecated! Use 'xxx' instead."
#  "This procedure is deprecated! use 'xxx' instead."
#There is no replacement function if line doesn't contain "use".
sub check_if_procedure_is_deprecated
{
    local ($old_procedure_name) = @_;
    local ($line, @words);

    $line = <>;

    #Is this procedure deprecated?
    if ($line !~ /[Dd]eprecated/)
    {
        return 0;   #No, it isn't
    }

    #Default to there being no replacement procedure
    $new_procedure_name = "";

    $line =~ s/^\s+//;
    @words = split(/ /, $line);

    #If no "use" word, there is no replacement procedure
    if ($line =~ /[Uu]se /)
    {
        if ($line =~ /Deprecated:/)
        {
            $words[2] =~ s/\'//g;
            $words[2] =~ s/_/-/g;
            $new_procedure_name = $words[2];
        }
        else    #Assume line has "deprecated!"
        {
            $words[5] =~ s/\'//g;
            $words[5] =~ s/_/-/g;
            $new_procedure_name = $words[5];
        }
    }

    if ($new_procedure_name eq "")
    {
        push (@obsolete, $old_procedure_name);
    }
    else
    {
        $deprecated{$old_procedure_name} = $new_procedure_name;
    }
    return 1;   #This procedure is deprecated
}


#Search for the start of the procedures input argument list
sub find_procedure_input_arguments
{
    while (<> !~ /^  \(/)
    {
    }
}


#The first line read in this function will either be the opening parenthesis
#to mark the start of data for an argument or a close parenthesis to mark
#the end of the argument list (if there are no arguments for the procedure).
sub get_argument_count
{
    local ($arg_count, $line);

    $arg_count = 0;

    do
    {
        $line = <>; #Expecting ( to mark start of an argument
        if ($line =~ /^  \)/)   #End of argument list?
        {
            return $arg_count;
        }

        ++$arg_count;

        #Search for end of argument data
        do {
            $line = <>;
        } while ($line !~ /^    \)/);
    } while ($line !~ /^  \)/);

    return $arg_count;
}