package Mkcd::Commandline;

our $VERSION = '1.1.0';

use strict;
require Exporter;
our @ISA = qw(Exporter);
our @EXPORT = qw(parseCommandLine usage);

=head1 NAME

commandline - mkcd module

=head1 SYNOPSYS

    require Mkcd::Commandline;

=head1 DESCRIPTION

C<Mkcd::Commandline> include the mkcd command line parsing functions.

=head1 SEE ALSO

mkcd

=head1 COPYRIGHT

Copyright (C) 2000,2001,2002,2003,2004 Mandrakesoft <warly@mandrakesoft.com>

This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.

=cut

sub parseCommandLine {
    my ($name, $args, $par) = @_;

    my %params;
    my ($params, $nb);
    foreach (@$par) {
	$_->[0] and $params{$_->[0]} = $_;
	$_->[1] and $params{$_->[1]} = $_;
	$_->[0] and $params .= $_->[0];
	$_->[1] eq $name and $nb = $_->[2]
    }
    if ($params !~ /h/ && ! defined $params{help}) {
	$params .= 'h';
	my $h = [ "h", "help", -1, "<path> <to> <the> <function>", "Display help, eg. $name -h option_X suboption_Y.", 
	    sub { 
		my (@path) = @_; 
		my $p = $par;
		foreach my $f (@path) {
		    foreach my $e (@$par) {
			if ($e->[1] eq $f) {
			    if (ref $e->[2]) {
				$p = $e->[2];
			    } else {
				last
			    }
			}
		    }
		}
		usage($name, $p, 0)
	    }, "Calling help" ];
	$params{help} = $h;
	$params{h} = $h;
	push @$par, $h
    }

    my (@default, @todo);
    if (@$args) {
	my ($onlyarg, $a);
	local $_;
	while (@$args || $a) {
	    $_ = $a ? $a : shift @$args;
	    $a = 0;
	    my @cur;
	    if ($onlyarg) {
		push @default, $_
	    } elsif ($params && /^-([$params]+)$/) {
		my @letter = split / */, $1; 
		push @cur, @letter;
	    } elsif (/^--(.+)/ && $params{$1}) { 
		push @cur, $1 
	    } elsif (/^--$/) { 
		$onlyarg = 1 
	    } elsif (/^-\S+$/) { 
		push @default, $_;
		$onlyarg = 1 
	    } else { push @default, $_ } 
	    foreach my $s (@cur) {
		$params{$s} or usage($name, $par, "$s, not such option");
		my $tmp = getArgs($name, $s, $args, \%params,$par);
		push @todo, [ $params{$s}[5], $tmp, $params{$s}[6] ]
	    }
	}
    } elsif ($nb) {
	usage($name,$par,1);
    }
    my $tmp = getArgs($name,$name, \@default, \%params,$par);
    unshift @todo, [$params{$name}[5], $tmp, $params{$name}[6]];
    push @$args, @default;
    return \@todo
}

sub getArgs {
    my ($name, $s, $args, $params, $par) = @_;
    my $i = $params->{$s}[2]; 
    my $tmp = [];
    my $a;
    if (ref $i) {
	foreach my $f (@{parseCommandLine($params->{$s}[1],$args,$i)}) {
	    &{$f->[0]}($tmp, @{$f->[1]}) or print "ERROR getArgs: $f->[2]\n";
	}
    } else {
	if ($i < 0) { 
	    while ($i++) { 
		$a = shift @$args;
		length $a or usage($name,$par, "$s not enough argument");
		$a =~ /^-./ and usage($name,$par, "$s before $a, not enough argument"); 
		push @$tmp, $a 
	    } 
	    while ($a = shift @$args) { 
		if ($a =~ /^-./) { 
		    unshift @$args, $a; 
		    last 
		} 
		push @$tmp, $a;
		$a = 0 
	    }
	} else { 
	    while ($i--) { 
		$a = shift @$args;
		length $a or usage($name,$par, "$s, not enough argument");  
		$a =~ /^-./ and usage($name,$par, "$s, before $a, not enough argument"); 
		push @$tmp, $a; 
		$a = 0 
	    }
	}
    }
    return $tmp;
}

sub usage {
    my ($name, $par, $level) = @_;
    my $st;
    foreach (sort { $a->[0] cmp $b->[0] || $a->[1] cmp $b->[1] } @$par) {
	if ($_->[1] eq $name) { 
	    $st = "\nusage
	    $name $_->[3]
	    $_->[4]

	    options:

$st"; 
	    next
	}
	$_->[0] and $st .= "\t\t-$_->[0], --$_->[1] $_->[3]\n\t\t\t$_->[4]\n" and next;
	$_->[1] and $st .= "\t\t--$_->[1] $_->[3]\n\t\t\t$_->[4]\n" and next;
    }

    print "\nERROR $name: $level\n" if $level;
    print "$st\n";
    exit()
}

1