#!/usr/bin/perl
# Copyright (c) 2002 Felix Rosencrantz
#
# Information about this tool can be found at:
#       http://www.geocities.com/f_rosencrantz/xml_completion.htm
#
# This script is designed to take command help output and generate an XML
# version that can be converted to completion function for zsh.  Potentially
# other useful things could be generated (e.g. bash,tcsh completion code).

#use warnings;          Used for debugging
#require Data::Dumper;  Used for debugging
use Getopt::Long; 

## Define command line options
my $usage = 0,$multiple = 0, $command = '', $single_char_flags = 0;
my $unique_args = 0, $no_args=0, $pyx = 0;
my (@m_array, @x_array, @p_array, @args);
my %options = (
        "c" => \$command,
        "m" => \$multiple,
        "x" => \@x_array,
        "M" => \@m_array,
        "u" => \$usage,
        "p" => \@p_array,
        "S" => \$single_char_flags,
        "n" => \$unique_args,
        "a" => \@args,
        "A" => \$no_args,
        "pyx" => \$pyx,
);
 
my $cmdline = join(" ",@ARGV);
## Parse command line options
Getopt::Long::Configure("no_ignore_case");
GetOptions(\%options, "c|command=s", "u|usage", "m|multiple+","M|multiple-flags=s@","x|exclusion-set=s@","p|prefix-flags=s@","S|single-char-flags","n|unique-args", "a|args=s@", "pyx")  ||  &usage();
&usage() if ($usage);

# Create a function that performs flag prefix parsing.
&create_handle_prefix();


#Generate information PYX format, which can be easily converted to XML.
&open_pyx();
#Generate the header
&send_pyx("(command\n");
&send_pyx("Acommand $command\n");
&send_pyx("Amultiple true\n") if $multiple;
# Read the help/usage information

$order = 0;
while (<>)
{
    #The extract_flag sub extracts information about a flag.
    my $flag_hash = &extract_flag($_);
    my $flag = $flag_hash->{flag};
    my $flag2 = "";
    # Sometimes a flag has an alias, flag2
    $flag2 = $flag_hash->{flag2} if (defined $flag_hash->{flag2});
    
    next if (!defined $flag || $flag eq "");
    #Add the flag (and it's alias)
    &add_flag($flag,$flag_hash);
    &add_flag($flag2,$flag_hash) if (defined $flag2 && $flag2 ne "");
}
    

#Record if a flag can be used more than once.
#Each element of m_array is the argument to -M flag on the command line.
# So each element is a comma separated list of flags that should be marked
# as being allowed multiple times.
foreach my $flagset (@m_array)
{
    my @parts = ();
    if ($flagset =~ m#,#)
    {
        @parts = split(/,/,$flagset);
    }
    else
    {
        @parts = ($flagset)
    }
    foreach $flag (@parts)
    {
        $flags{$flag}{multiple}  = 1 if defined $flags{$flag};

    }
}

#Handle command line specified exclusion lists.
#Each element of the x_array is the argument to the -x flag on the command line.
#So each element is a comma separated list of flags that should be mutually
#exclusive.
foreach my $e_list (@x_array)
{
    my @parts= split(/,/,$e_list);
    my %list;
    foreach my $p (@parts)
    {
        next if $p eq ""; # Get ride of empty flags caused by split command.
        $list{$p} = 1;
        #If a flag has a sameas alias, then the alias is also excluded.
        $list{$flags{$p}{f}[0]{sameas}} = 1
                                           if (defined $flags{$p}{f}[0]{sameas}
                                               && $flags{$p}{multiple} != 1);
    }
    foreach my $k (keys %list)
    {
        my $ex_set = "";
        $ex_set=$flags{$k}{exclusionlist} if defined $flags{$k}{exclusionlist};
        my @set = grep(!(/^$k$/ || /^$/) ,keys %list,$ex_set);
        foreach my $f (@set)
        {
            $flags{$k}{exclusionlist} .= $f . " ";
        }
    }
}

#Automatically Generate exclusion lists for sameas aliases.
#If a flag is allowed multiple times, then no exclusion list is generated.
foreach my $k (keys %flags)
{
        next if $multiple; #All flags are allowed multiple times. (should hoist)
        next if defined $flags{$k}{exclusionlist}; #Already handled above.
        next if defined $flags{$k}{multiple} && $flags{$k}{multiple}; 
        if (defined $flags{$k}{f}[0]{sameas})
        {
            $flags{$k}{exclusionlist} .= "$flags{$k}{f}[0]{sameas}";
        }
}

#Fix up %flags.
#   Figure out if a flag is listed more than once, which we assume means
#   fixed strings.
#   Figure other things.
foreach $flag (keys %flags)
{
    # We have fixed strings.
    if ($#{$flags{$flag}{f}} > 0)
    {
        my $parts = ${flags{$flag}{f}};
        #print Data::Dumper::Dumper($parts),"\n"; #lll
        if (! defined ${$$parts[0]}{tag})
        {
            # We should have a tag with multiple lines...
            # print STDERR "Flag ($flag): seems not to have a tag...\n";
        }
        foreach my $option (@$parts)
        {
            $flags{$flag}{fixedstrings} .= "$$option{tag}:$$option{taghelp} ";
        }
    }
    else
    {
        #We have only one information  tag on this flag, save the information
        # at the top level of the entry.  (We should probably do something
        # like this above... possible bug)
        my $info = $flags{$flag}{f}[0];
        foreach $key (keys %$info)
        {
            ${$flags{$flag}}{$key} = $$info{$key};
        }
    }
}


foreach $flag (sort by_flag_order keys %flags)
{

    &send_pyx("(flag\n");
    &send_pyx("Aname $flag\n");
    &send_pyx("Aargtag $flags{$flag}{tag}\n") if ($flags{$flag}{tag} ne "");
    &send_pyx("Afixedstrings $flags{$flag}{fixedstrings}\n")
                                      if (defined $flags{$flag}{fixedstrings}
                                         && $flags{$flag}{fixedstrings} ne "");
    &send_pyx("Aexclusionlist $flags{$flag}{exclusionlist}\n")
                if (defined $flags{$flag}{exclusionlist} 
                    && $flags{$flag}{exclusionlist} ne "");
    &send_pyx("Amultiple true\n") if (defined $flags{$flag}{multiple}
                                       && $flags{$flag}{multiple} ne "");
    &send_pyx("Asame_word true\n") if ($flags{$flag}{sameword}
                                       && $flags{$flag}{sameword} ne "");
    &send_pyx("Ataghelp $flags{$flag}{taghelp}\n") if defined $flags{$flag}{taghelp};
    &send_pyx("Aflaghelp $flags{$flag}{flaghelp}\n") if defined $flags{$flag}{flaghelp};
    &send_pyx(")flag\n");

}

# Now handle commandline arguments...
my @cmd_args;
if (!$no_args && ($#args < 0))
{
    @cmd_args = ("files");
}
elsif ($no_args)
{
    @cmd_args=();
}
else
{
    @cmd_args = (@args);
}

for(my $i=0;$i<= $#cmd_args;$i++)
{
    my $arg=$cmd_args[$i];
    my $pos=$i+1;
    $pos = "any" if ($i== $#cmd_args);
    &send_pyx("(arg\n");
    &send_pyx("Aposition $pos\n");
    &send_pyx("Aargtag $arg\n");
    &send_pyx(")arg\n");
    
}

#Save information about how this file was generated.
&send_pyx("(generation\n");
&send_pyx("Acommand help2simple.pl $cmdline\n");
&send_pyx(")generation\n");
&send_pyx(")command\n");

#We're done.
&close_pyx();

exit 0;

################################################################################
sub usage
{
    print <<EOF;
Usage: help2simple.pl -c command_name -u -m -M f1,f2,... -x f1,f2,... -p f1,f2,.. -S -pyx
    -c command_name        The name of the command that will be completed
    -u                     Usage information
    -m                     All flags should be allowed more than once
    -M flag_comma_list     Flags that should be allowed more than once
    -x flag_comma_list     Exclusion list of flags
    -p flag_prefix         Flag prefix, used to distinguish prefix flags
    -S                     All single dash flags are single letter flags. 
    -n                     Add flag name to arg, to make argnames unique.
    -a argtag              Name of argtag to use for that position.
    -pyx                   Output in pyx format.
EOF
exit 0;
}


# Used to sort the keys of %flags by the 'order' key, which is the order
# that flags were found.
sub by_flag_order 
{
    return $flags{$a}{order} <=> $flags{$b}{order};
}

# open_pyx, send_pyx, close_pyx functions are used to generate PYX or XML
# output. This script calls these functions to handle the generation
# of the data.  The script hands PYX to send_pyx, which either spits that
# out, or generates XML.


sub open_pyx {

%Encode = (
	'<' => '&lt;',
	'>' => '&gt;',
	'&' => '&amp;',
	'"' => '&quot;',
);

$Encode = join('', keys(%Encode));

$Tag_open = 0;
}

sub close_pyx
{
    return if ($pyx);
    print '>' if $Tag_open;
    return;
    
}

sub send_pyx
{
    my $string = join('',@_);
    if ($pyx)
    {
        print $string;
        return;
    }    
    $_ = $string;

    my ($type, $value) = m/\A([A()?-])(.*)\Z/;

    if ($type eq 'A') {
	my ($att, $attval) = m/\AA([^\s]+)\s*(.*)\Z/;
	print " $att=\"" , encode($attval) , '"';
	return;
    }

    if ($Tag_open)
    {
        print "/" if ($type eq ")");
        print ">\n";
        undef $Tag_open;
        return if ($type eq ")");
    }

    if ($type eq '(') {
	print "<$value";
	$Tag_open = 1;
    }
    elsif ($type eq ')') {
	print "</$value>\n";
    }
    elsif ($type eq '-') {
	$value =~ s/\\n/\n/g;
	print encode($value);
    }
    elsif ($type eq '?') {
    	print "<?" , encode($value) , "?>\n";
    }

}

#Generate Entities for special characters.
sub encode {
	my $text = shift;
	$text =~ s/([$Encode])/$Encode{$1}/g;
	return $text;
}

#Extract_flag is responsible for parsing a line from the help, and
#extract information about a flag.
# It returns a reference to a hash that contains information about the flag.
sub extract_flag
{
    my $line = $_[0];
    my %info;

    $_ = $line;

    my ($flag,$flag2,$taghelp, $argtag, $argtag2, $sameword, $helptype);
    my ($equals, $equals2, $fixedstrings);
    $sameword = 0;
    $fixedstrings = "";

    # The expected input look something like:
    # -h lines      Set the size of the scrollback history buffer.
    # The line starts with a flag, ($1)
    # The flag is followed by and optional argument ($2)
    # The trailing content after 2 or more spaces is the help.($3)
    # The following regex performs this parsing.
    $helptype = "flaghelp";
    if (m#^\s*(-[^\s]+)\s+(([^\s]+)\s+)?(or|,)\s+(-[^\s]+)\s([^\s]+)?\s+(.*)$#)
    {
        $flag = $1;
        $flag2 = $5;
        $taghelp = $7;
        $argtag = $3;
        $argtag2 = $6;
    }
    elsif  (m#^\s*(-[^\s]+)( [^\s]+)*(\s\s+|\t)+(.*)$#)
    {
        $flag = $1;
        $flag2 = $argtag2 = '';
        $argtag = $2;
        $taghelp = $4;
    }
    else { return \%info; }

    #print STDERR "flag($flag) argtag($argtag) taghelp($taghelp) ($_)\n"; #lll
    my $flagparts = &handle_prefix($flag);
    if (@$flagparts == 2)
    {
        $flag = $$flagparts[0];
        $argtag  = $$flagparts[1];
        $sameword = 1 if ($argtag !~ /^ +/);
    }
    
    if ($single_char_flags && $flag =~ /^(-[^-])(.+)$/)
    {
        $flag = $1;
        $argtag = $2;
        $sameword = 1;
        $helptype = "taghelp";
    }
    elsif ( $flag =~ /^(-[^=]*)=(.*)$/)
    {
        $flag = $1;
        $argtag = $2;
        $helptype="taghelp";
        $equals=1;
        if ($flag2 =~ /^(-[^=]*)=(.*)$/)
        {
            $flag2 = $1;
            $argtag2 = $2;
            $equals2 = 1;
        }
    }


    $argtag = "" if (!defined $argtag);
    if ($argtag =~ /\|/)
    {
        $argtag =~ s/^\s*[[({<]//;
        $argtag =~ s/[])}>]\s*$//;
        my @f = split (/\|/,$argtag);
        $fixedstrings = join(" ",@f);
        $argtag = "";
    }
    

    if ($argtag ne "")
    {
        $helptype = "taghelp";
        $argtag .= $flag if $unique_args;  #Add flag name to arg if unique_args
    }
    $info{flag} = $flag;
    $info{flag2} = $flag2;
    $info{$helptype} = $taghelp;
    $info{tag}= $argtag;
    $info{tag2} = $argtag2;
    $info{sameword} = $sameword if ($sameword);
    $info{equals} = $equals if ($equals);
    $info{equals2} = $equals2 if ($equals2);
    $info{fixedstrings} = $fixedstrings if ($fixedstrings ne "");
    return(\%info);
}
# Stub function. Is be overriden by function generated via create_handle_prefix
sub handle_prefix {}

#Creates new handle_prefix().
# The handle_prefix() is used to separate a flag from it's argument.
# This is use to handle the "-p" flag.
sub create_handle_prefix
{
    my %prefix;
    foreach my $flag_prefix (@p_array)
    {
        my @parts=split(/,/,$flag_prefix);
        foreach my $p (@parts)
        {
            $prefix{$p} = 1;
        }
    }
$func = <<'EOF';
sub main::handle_prefix {
    my ($flag, $str);
    $_ = $_[0];
EOF
    foreach my $k (sort keys %prefix)
    {
        $func .= <<EOF;
    if (m/^$k(.*)\$/)
    {
        \$flag = "$k";
        \$str = \$1;
        return [\$flag,\$str];
    }
EOF
    }
    $func .= <<EOF;
    return [];
}
EOF
    eval $func;
}


# This add a flag_hash as returned from &extract_flag() and adds it to the
# global %flags hash.  Since a flag_hash can contain information for multiple
# flags, the first argument says which flag to use ("flag" or "flag2").
sub add_flag
{
    my ($flag, $hash) = @_;
    my %info;

    if ($$hash{flag} eq $flag)
    {
        $info{flag} = $$hash{flag};
        $info{sameas} = $$hash{flag2} if(defined $$hash{flag2}&& $$hash{flag2});
        $info{flaghelp} = $$hash{flaghelp} if (defined $$hash{flaghelp});
        $info{taghelp} = $$hash{taghelp} if (defined $$hash{taghelp});
        $tag = (defined ($$hash{tag}))? "tag" : "tag2";
        $info{tag} = $$hash{$tag} if (defined $$hash{$tag});
        $info{sameword} = $$hash{sameword} if ($$hash{sameword});
        $info{equals} = $$hash{equals} if ($$hash{equals});
        $info{fixedstrings}=$$hash{fixedstrings}
                if (defined $$hash{fixedstrings} && $$hash{fixedstrings} ne "");
    }
    else
    {
        $info{flag} = $$hash{flag2};
        $info{sameas} = $$hash{flag};
        $info{flaghelp} = $$hash{flaghelp} if (defined $$hash{flaghelp});
        $info{taghelp} = $$hash{taghelp} if (defined $$hash{taghelp});
        $tag = (defined ($$hash{tag2}))? "tag2" : "tag";
        $info{tag} = $$hash{$tag} if (defined $$hash{$tag});
        $info{sameword} = $$hash{sameword} if ($$hash{sameword});
        $info{equals} = $$hash{equals2} if ($$hash{equals2});
        $info{fixedstrings}=$$hash{fixedstrings} if($$hash{fixedstrings} ne "");
    }


    if (defined $flags{$flag})
    {
        push(@{$flags{$flag}{f}},\%info);
    }
    else
    {
        $flags{$flag}{f} = [\%info];
        $flags{$flag}{order} = $order++;
    }
}
