# -*- perl -*-

#
#   Copyright (C) Heinz-Josef Claes (2002)
#                 hjclaes@web.de
#   
#   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 of the License, 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., 675 Mass Ave, Cambridge, MA 02139, USA.
#



push @VERSION, '$Id: checkParam.pl,v 1.12 2002/05/20 06:45:34 hjc Exp $ ';

use strict;

require 'checkObjPar.pl';

######################################################################
# Speicherung s"amtlicher Informationen "uber *einen* Parameter
package Option;

sub new
{
    my ($class) = shift;
    my ($self) = {};

    # Defaultwerte f"ur Parameter setzen
    my (%params) = ('-option' => undef,
		    '-only_if' => undef,
		    '-alias' => undef,
		    '-default' => undef,
		    '-param' => 'no',    # wird gesetzt, wenn '-default'
		    '-must_be' => 'no',
		    '-comment' => undef, # wird als Fehlermeld. ausgegeben
		                         # bei Fehler -only_if und -pattern
		    '-pattern' => undef
		    );

    &::checkObjectParams(\%params, \@_, 'Option::new', ['-option']);

    $params{'-param'} = 'yes' if (defined($params{'-default'}));
    $params{'-used'} = 'no';   # wird in CheckParam::check dann "uberpr"uft

    $self->{'param'} = \%params;    # Parameter an Objekt binden

    bless($self, $class);
}


sub get
{
    my ($self) = shift;
    my ($par) = shift;

    return $self->{'param'}{$par};
}


sub set
{
    my ($self) = shift;
    my ($par) = shift;
    my ($val) = shift;

    $self->{'param'}{$par} = $val;
}

######################################################################
package CheckParam;

sub new
{
    my ($class) = shift;
    my ($self) = {};

    # Defaultwerte f"ur Parameter setzen
    my (%params) = ('-list' => [],
		    '-allowLists' => 'no');

    &::checkObjectParams(\%params, \@_, 'CheckParam::new', []);

    $self->{'paramList'} = \%params;    # Parameter an Objekt binden

    # Hash mit '-option' und '-alias' f"ur schnellen Zugriff auf Option
    my (%option, $o);
    foreach $o (@{$self->{'paramList'}{'-list'}})
    {
	my ($opt) = $o->get('-option');
	$option{$opt} = $o;
	if ($opt = $o->get('-alias'))
	{
	    $option{$opt} = $o;
	}
    }
    $self->{'optionsPointer'} = \%option;

    bless($self, $class);
}


sub getList
{
    my ($self) = shift;
    my ($par) = shift;

    return $self->{'paramList'}{$par};
}


sub check
{
    my ($self) = shift;
    # Defaultwerte f"ur Parameter setzen
    my (%params) = ('-argv' => [[]],
		    '-help' => ['<noHelp>']);

    my (%hash) = @_;    # Parameter in Hash kopieren
    my ($k);
    foreach $k (keys %params)
    {
	if (defined($hash{$k}))
	{
	    $params{$k} = $hash{$k};  # Wert "uberschreiben
	    delete $hash{$k};
	}
	else
	{
	    $params{$k} = $params{$k}[0];  # Defaultwert einsetzen
	}
    }
    my ($Help) = $params{'-help'};
    die "undefined params <", join('><', keys %hash),
    "> in CheckParam::check\n"
	if (keys %hash > 0);

    # Die gesetzten Optionen erst einmal auf Parameter analysieren
    my ($arg, @parList, $next, $aktOpt, %optWithPar, %optWithoutPar, $i);
    my ($op) = $self->{'optionsPointer'};
    $next = 'unknown';
    my ($i);
    for ($i = 0 ; $i < @{$params{'-argv'}} ; $i++)
    {
	$arg = $params{'-argv'}[$i];

	if ($next eq 'list')  # Listenparameter
	{
	    push @parList, $arg;
	    $next = 'unknown';
	    next;
	}
	if ($arg eq '--')   # n"achster Parameter ist 'list' - Parameter
	{
	    $next = 'list';
	    next;
	}
	if (defined($op->{$arg}))   # bekannte Option
	{
	    my ($o) = $op->{$arg};
	    $arg = $o->get('-option');
	    $o->set('-used' => 'yes');

	    if ($o->get('-param') eq 'yes')
	    {
		$optWithPar{$arg}{'object'} = $o;
		die "missing param for option <$arg>\n$Help"
		    if (++$i >= @{$params{'-argv'}});
		$optWithPar{$arg}{'value'} = $params{'-argv'}[$i];
		next;
	    }
	    else        # keine Parameter an Option
	    {
		$optWithoutPar{$arg} = $o;
		next;
	    }
	}
	else      # Listenparameter
	{
	    die "unknown parameter <$arg>\n$Help" if ($arg =~ /^-/);
	    push @parList, $arg;
	    next;
	}
    }

    # %optWithPar enth"alt jetzt die in ARGV gesetzten Optionen mit Parameter
    # $optWithPar{option}{'object'} = Zeiger auf vorgegeb. Objekt f"ur d. Opt.
    # $optWithPar{option}{'value'} = Wert der Option in ARGV

    # Ausgabe der gefundenen Optionen
    if (0)
    {
	my ($k);
	print "Ausgabe der gefundenen Optionen\n";
	print "\tOptionen mit Parameter:\n";
	foreach $k (sort keys %optWithPar)
	{
	    print "\t\t$k\t", $optWithPar{$k}{'value'}, "\n";
	}
	print "\tOptionen ohne Parameter:\n";
	foreach $k (sort keys %optWithoutPar)
	{
	    print "\t\t$k\n";
	}
	print "\tList-Parameter:\n";
	foreach $k (sort @parList)
	{
	    print "\t\t$k\n";
	}
    }

    # Überprüfen, ob List-Parameter erlaubt sind
    die "detected the following not allowed list parameters:\n\t<",
    join('> <', @parList), ">\n$Help"
	if (@parList > 0 and $self->{'paramList'}{'-allowLists'} eq 'no');

    # Die Defaultwerte einsetzen
    my ($optIter) = IterOpt_CheckParam->new($self);
    my ($o);
    while ($o = $optIter->next())
    {
	next unless (defined $o->get('-default'));  # kein default vorhanden
	my ($opt) = $o->get('-option');
	next if ($optWithPar{$opt});   # schon in ARGV gesetzt

	$optWithPar{$opt}{'object'} = $o;   # auf Default setzen
	$optWithPar{$opt}{'value'} = $o->get('-default');
    }

    # '-must_be' "uberpr"ufen
    while ($o = $optIter->next())
    {
	next if ($o->get('-must_be') eq 'no');  # mu"s nicht sein
	my ($opt) = $o->get('-option');

	if ($o->get('-param') eq 'no')   # kein Parameter
	{
	    die "missing option <$opt>\n$Help"
		unless ($optWithoutPar{$opt});
	}
	else # hat Parameter
	{
	    die "missing option <$opt param>\n$Help"
		unless ($optWithPar{$opt});
	}
    }

    # '-pattern' "uberpr"ufen
    my ($k);
    foreach $k (keys %optWithPar)
    {
	my ($o) = $optWithPar{$k}{'object'};
	next unless ($o->get('-pattern')); # hier gibt's keine Beschr"ankungen
	my ($pat) = $o->get('-pattern');

	unless ($optWithPar{$k}{'value'} =~ /$pat/)
	{
	    if ($o->get('-comment'))
	    {
		die $o->get('-comment');
	    }
	    else
	    {
		die "<", $optWithPar{$k}{'value'},
		"> is not a valid value for option <$k>\nallowed pattern is ",
		"<$pat>\n$Help";
	    }
		
	}
    }

    # '-only_if' "uberpr"ufen
    while ($o = $optIter->next())
    {
	next unless ($o->get('-only_if'));  # keine Einschr"ankungen
	next if ($o->get('-used') eq 'no'); # Parameter wird nicht verwendet
	my ($only_if) = $o->get('-only_if');

	# zuerst alle gesetzten Parameter durch '1' ersetzen
	my ($k);
	foreach $k (keys %optWithoutPar)
	{
	    my ($o) = $optWithoutPar{$k};
	    my ($opt) = $o->get('-option');
	    my ($alias) = $o->get('-alias');
	    $only_if =~ s/\[$opt\]/1/g;
	    $only_if =~ s/\[$alias\]/1/g;
	}
	foreach $k (keys %optWithPar)
	{
	    my ($o) = $optWithPar{$k}{'object'};
	    my ($opt) = $o->get('-option');
	    my ($alias) = $o->get('-alias');
	    $only_if =~ s/\[$opt\]/1/g;
	    $only_if =~ s/\[$alias\]/1/g;
	}
	$only_if =~ s/\[(.*?)\]/0/g;   # verbliebene durch 0 ersetzen
	my $only_print = $only_if;
	$only_if =~ s/or/\|/g;         # durch bin"are Operatoren ersetzen,
	$only_if =~ s/and/&/g;         # dann funktioniert not (!)
	$only_if =~ s/not/!/g;         # statt '!' kann auch 'not' verw. werden
	$only_if =~ s/exor/^/g;        # statt '^' kann auch 'exor' verw. werd.
	unless (eval "($only_if)")
	{
	    if ($o->get('-comment'))
	    {
		die $o->get('-comment');
	    }
	    else
	    {
		die "illegal combination in use of option <",
		$o->get('-option'), ">, rule = (", $o->get('-only_if'),
		")\n\t\t\t\t\t\t  <<$only_print>>\n$Help";
	    }
	}

      nichtTesten:;
    }


    if (0)
    {
	my ($k);
	print "Ausgabe der gefundenen Optionen\n";
	print "\tOptionen mit Parameter:\n";
	foreach $k (sort keys %optWithPar)
	{
	    print "\t\t$k\t", $optWithPar{$k}{'value'}, "\n";
	}
	print "\tOptionen ohne Parameter:\n";
	foreach $k (sort keys %optWithoutPar)
	{
	    print "\t\t$k\n";
	}
	print "\tList-Parameter:\n";
	foreach $k (sort @parList)
	{
	    print "\t\t$k\n";
	}
    }

    # Ergebnisse merken
    $self->{'Erg'}{'withPar'} = \%optWithPar;
    $self->{'Erg'}{'withoutPar'} = \%optWithoutPar;
    $self->{'Erg'}{'listPar'} = \@parList;
}


sub getOptWithPar
{
    my ($self) = shift;
    my ($par) = shift;

    die "option <$par> does not exist"
	unless defined $self->{'optionsPointer'}{$par};
    my ($opt) = $self->{'optionsPointer'}{$par}->get('-option');

    return undef unless ($self->{'Erg'}{'withPar'}{$opt}); # is nix
    return $self->{'Erg'}{'withPar'}{$opt}{'value'};
}

sub getOptWithoutPar
{
    my ($self) = shift;
    my ($par) = shift;

    die "option <$par> does not exist"
	unless defined $self->{'optionsPointer'}{$par};
    my ($opt) = $self->{'optionsPointer'}{$par}->get('-option');
    return $self->{'Erg'}{'withoutPar'}{$opt};
}

sub getListPar
{
    my $self = shift;

    return @{$self->{'Erg'}{'listPar'}};
}

sub getNoListPar
{
    my $self = shift;

    return scalar(@{$self->{'Erg'}{'listPar'}});
}


######################################################################
# Iterator f"ur die List-Parameter
package Iter_ParList;

sub new
{
    my ($class) = shift;
    my ($CheckPar) = shift;
    my ($self) = {};

    $self->{'list'} = $CheckPar->{'Erg'}{'listPar'};
    $self->{'index'} = -1;
    bless($self, $class);
}

sub next
{
    my ($self) = shift;
    my ($l) = $self->{'list'};

    ++$self->{'index'};
    if ($self->{'index'} >= @$l)   # Ende erreicht
    {
	$self->{'index'} = -1;
	return undef;
    }
    else
    {
	return $$l[$self->{'index'}];
    }
}

######################################################################
# Iterator f"ur CheckParam, um s"amtliche gespeicherten Option zu erhalten
package IterOpt_CheckParam;

sub new
{
    my ($class) = shift;
    my ($CheckPar) = shift;
    my ($self) = {};

    $self->{'list'} = $CheckPar->getList('-list');
    $self->{'index'} = -1;

    bless($self, $class);
}


sub next
{
    my ($self) = shift;
    my ($l) = $self->{'list'};

    ++$self->{'index'};
    if ($self->{'index'} >= @$l)   # Ende erreicht
    {
	$self->{'index'} = -1;
	return undef;
    }
    else
    {
	return $$l[$self->{'index'}];
    }
}