#!/usr/bin/perl --

use strict;
use warnings;

# Diffs:
# * dir is not indented
#   Minor issue
# * No backup.
#   Not a problem if dir can be regenerated
# * gcj-4.0: installs in gcj-4.0 and gcj => --remove does not remove everything
#                                        => reinstall does not reinstall
#                                           because some parts are already
#                                           installed
# * some info files do not have menu entry (e.g. menu, linuxdoc-sgml)
#   => they use --menuentry and --descritpion
#   => this could be detected by lintian/linda
# * unsupported options
#   --remove-exactly replaced by --remove
#     Not that nice. Removing emacs-21/info also removes info
#     => need to reimplement --remove-exactly
#   --section with two arguments
#     could be detected by lintian/linda
#     IMO, --section should be avoided. everything should be in the info file
#     (maybe with a debian specific patch)
#     ditto for --descritpion and --menuentry
#     The current implementation seems to deal nicely with it
#   --description is sometime used without --menuentry
#     I discard this description

my $personality=""; # '', 'dpkg', 'gnu'

open (LOG, ">>/var/log/install-info.log");
print LOG "original command: ".join("'", @ARGV)."\n";

# Try to detect the personality
###############################

#  1. no short options in dpkg's i-i
foreach my $arg (@ARGV) {
    if ($arg =~ m/^-[ideshHr](=|$)/) {
        $personality="gnu";
        goto PERSONALITY_FOUND;
    }
}

#  2. dpkg's i-i deprecated options
foreach my $arg (@ARGV) {
    if ($arg =~ m/^--(debug$|maxwidth=|align=|calign=)/) {
        $personality="dpkg";
        goto PERSONALITY_FOUND;
    }
}

#  3. dpkg's specific options
foreach my $arg (@ARGV) {
    if ($arg =~ m/^--(menuentry=|description=|test$|keep-old$|remove-exactly$)/) {
        $personality="dpkg";
        goto PERSONALITY_FOUND;
    }
}

#  4. gnu's specific options
foreach my $arg (@ARGV) {
    if (   $arg =~ m/^--(entry|item|delete)(=|$)/
        or $arg =~ m/^--section=/) {
        $personality="gnu";
        goto PERSONALITY_FOUND;
    }
}

#  5. dpkg's parameter are always specified with an '='
foreach my $arg (@ARGV) {
    if ($arg =~ m/^--(info-?dir|info-file|dir-file)$/) {
        $personality="gnu";
        goto PERSONALITY_FOUND;
    }
}

#  6. two args to --section
#  7. no dir file => dpkg's defaut dir file
#  8. ends with two files in argument => gnu

PERSONALITY_FOUND:

my @args = ();

my $dir_specified=0;
foreach my $arg (@ARGV) {
    if (   $arg =~ m/^--(dir-file|info-?dir)(=|$)/
        or $arg =~ m/^-d(=|$)/) {
        $dir_specified=1;
        last;
    }
}

my $infofile="";
my $menuentry="";
my $description="";

my @tmp_args = @ARGV;
while (@tmp_args) {
    my $arg = $tmp_args[0];
    # unsupported dpkg's i-i options
    if (   $arg =~ m/^--(c?align|maxwidth)=/
        or $arg =~ m/^--(debug|test|keep-old)$/) {
        print STDERR "install-info: option '$arg' not supported and ignored.\n";
        print LOG "option '$arg' not supported and ignored.\n";
        shift @tmp_args;
    } elsif ($arg eq "--remove-exactly") {
        shift @tmp_args;
        push @args, $arg;
    } elsif ($arg =~ m/^--menuentry=(.*)$/) {
        $menuentry=$1;
        shift @tmp_args;
    } elsif ($arg =~ m/^--description=(.*)$/) {
        $description=$1;
        shift @tmp_args;
    } elsif ($arg =~ m/^--info-file(=|$)/) {
        shift @tmp_args;
        push @args, $arg;
        if ($arg =~ m/^--info-file=(.*)$/) {
            $infofile = $1;
        } else {
            $infofile = shift @tmp_args;
            push @args, $infofile;
        }
    } elsif (
        # dpkg's i-i options (except --section)
           $arg =~ m/^--(version|quiet|remove|help)$/
        or $arg =~ m/^--(info-?dir|dir-file)=/
        # gnu's i-i options (except --section)
        or $arg =~ m/^-([hHr]$|[ides]=)/
        or $arg =~ m/^--(delete|help|quiet|remove|version)$/
        or $arg =~ m/^--(dir-file|entry|info-?dir|item|section)=/) {
        shift @tmp_args;
        push @args, $arg;
    } elsif (    (   $arg =~ m/^-[ides]$/
                  or $arg =~ m/^--(dir-file|entry|info-?dir|item)$/)
             and scalar(@tmp_args)>=2) {
        # an option with its argument
        shift @tmp_args;
        push @args, $arg;
        push @args, shift @tmp_args;
    } elsif ($arg =~ m/^--section$/) {
        if ($personality eq "") {
            # dpkg's i-i expect two parameters for the --section option
            if (    scalar(@tmp_args) > 2
                and not (-f $tmp_args[1] or -f $tmp_args[1].".gz")
                and not (-f $tmp_args[2])
                and ($dir_specified or scalar(@tmp_args) > 3)) {
                $personality = "dpkg";
            }
        }

        if ($personality eq "dpkg") {
            shift @tmp_args;
            push @args, $arg;
            my $regex = shift @tmp_args;
            push @args, shift @tmp_args;
            push @args, "--section-regex";
            push @args, $regex;
        } else {
            shift @tmp_args;
            push @args, $arg;
            push @args, shift @tmp_args;
        }
    } elsif ($arg =~ m/^-/) {
        print LOG "Unknow option: '$arg'\n";
        shift @tmp_args;
        push @args, $arg;
    } else {
        if (scalar @tmp_args == 2 and $tmp_args[1] !~ m/^-/) {
            $dir_specified = 1;
        }
        $infofile=$arg unless (length $infofile);
        shift @tmp_args;
        push @args, $arg;
    }
}

# With the dpkg personality, we must specify the dir file
if ($personality ne "gnu") {
    if (not $dir_specified) {
        unshift @args, "/usr/share/info/dir";
        unshift @args, "--dir-file";
    }

    if (length $description and length $menuentry) {
        my $basename = $infofile;
        $basename =~ s|/usr/share/info/||;
        $basename =~ s/(\.info)?(\.gz)?$//;
        my $item="* $menuentry: ($basename).\t\t$description";
        unshift @args, $item;
        unshift @args, "--item";
    } elsif (length $description) {
        print STDERR "install-info: option '--description' used without '--menuentry'. Ignored.\n";
        print LOG "install-info: option '--description' used without '--menuentry'. Ignored.\n";
    } elsif (length $menuentry) {
        print STDERR "install-info: option '--menuentry' used without '--description'. Ignored.\n";
        print LOG "install-info: option '--menuentry' used without '--description'. Ignored.\n";
    }
} else {
    if (length $description) {
        print STDERR "install-info: The '--description' option is not supported and is ignored.\n";
    }
    if (length $menuentry) {
        print STDERR "install-info: The '--menuentry' option is not supported and is ignored.\n";
    }

}

unshift @args, "/usr/bin/ginstall-info";

print LOG "personality: '$personality'\n";
print LOG "dir_specified: '$dir_specified'\n";
print LOG "command: ".join("'", @args)."\n";
close LOG;
system(@args);