source: soft/build_system/build_system/mkcd/tags/V3_3_4_1mdk/pm/Mkcd/Commandline.pm @ 1

package Mkcd::Commandline;

sub parseCommandLine;
sub usage;

our $VERSION = '0.0.1';

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 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;
        foreach (@$par) {
                $_->[0] and $params{$_->[0]} = $_;
                $_->[1] and $params{$_->[1]} = $_
            }

        my $params;
        foreach (@$par) { $_->[0] and $params .= $_->[0] }

        @$args or usage($name,$par,1);

        my @todo;
        my $onlyarg;

        my $a;
        my @default;
        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 (/^--(.+)/ and $params{$1}) { 
                    push @cur, $1 
                } elsif (/^--$/) { 
                    $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]]
                }
        }
        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 = [];
    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