# -*- perl -*-

#
#   Copyright (C) Heinz-Josef Claes (2004)
#                 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: evalTools.pl 327 2004-03-07 17:44:44Z  $ ';

use strict;

require 'checkObjPar.pl';
require 'prLog.pl';

package evalTools;


############################################################
sub makePatternIndexPatternLine
{
    my $pattLine = shift;

    my (%notPattern) = ('(' => undef,
			')' => undef,
			'and' => undef,
			'or' => undef,
			'not' => undef);
    my ($i, %patternID, @l);
    for ($i = 0 ; $i < @$pattLine ; $i++)
    {
	my $v = $$pattLine[$i];
	if (exists $notPattern{$v})     # ist kein Pattern
	{
	    push @l, $v;
	}
	else
	{
	    push @l, "\$line =~ /$v/ ";
	    $patternID{$v} = $i;
	}
    }
    return (\%patternID, join(' ', @l));
}


############################################################
sub checkLineDebug
{
    my ($patternList, $patternListID, $line, $what, $prLog) = @_;

    my (@list) = (@$patternList);
    my (@patShow) = (@$patternList);

    my ($pattern, $ref);
    while (($pattern, $ref) = each %$patternListID)
    {
	if ($line =~ /$pattern/)
	{
	    $list[$ref] = 1;     # Pattern paßt
	}
	else
	{
	    $list[$ref] = 0;     # Pattern paßt nicht
	}
	$patShow[$ref] = '<' . $patShow[$ref] . '>';
    }

#    $prLog->print('-kind' => 'D',
#		  '-str' => ["   checking $what: " . join(' ', @patShow)]);
    $prLog->print('-kind' => 'D',
		  '-str' => ["$what:",
			     "   checking <$line>: " . join(' ', @patShow)]);

    my $pattern = join(' ', @list);
    my ($result, $ret);
    if (eval $pattern)
    {
	$result = 'match';
	$ret = 1;
    }
    else
    {
	$result = 'no match';
	$ret = 0;
    }

    if ($@)
    {
	$prLog->print('-kind' => 'E',
		      '-str' =>
		      ["syntax error checking <$line> with pattern", 
		       "$what: <@$patternList>", $@,
		       "(Hint: allways mask '(', ')', '/' and reserved words)"],
		      '-exit' => 1);
    }

    $prLog->print('-kind' => 'D',
		  '-str' => ["\t\t$pattern => $result"]);
    return $ret;
}


############################################################
sub checkLine
{
    my ($pattern, $line, $what, $prLog, $verbose) = @_;

    my $ret;
    if (eval $pattern)
    {
	$ret = 1;                # pattern matches
    }
    else
    {
	$ret = 0;                # pattern does not match
    }

    if ($@)
    {
	$prLog->print('-kind' => 'E',
		      '-str' =>
		      ["syntax error checking <$line> with pattern",
		       "$what: <$pattern>", $@,
		       "(Hint: allways mask '(', ')', '/' and reserved words)"],
		      '-exit' => 1);
    }
    return $ret;
}