# -*- perl -*-

#
#   Copyright (C) Heinz-Josef Claes (2001-2003)
#                 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: readKeyFromFile.pl 323 2004-02-01 14:52:05Z hjc $ ';

use strict;

require 'checkObjPar.pl';

package readKeyFromFile;

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

    # Defaultwerte f"ur Parameter setzen
    my (%params) = ('-filename'  => undef,
		    '-delimiter' => ':',    # Trenner Key -> value
		    '-prLog'     => undef,
		    '-verbose'   => undef);

    &::checkObjectParams(\%params, \@_, 'ReadKeyFromFile::new',
			 ['-filename', '-prLog']);

    &::setParamsDirect($self, \%params);

    my $file = $params{'-filename'};
    my $prLog = $params{'-prLog'};
    local *FILE;
    open(FILE, "< $file") or
	$prLog->print('-kind' => 'E',
		      '-str' => ["cannot open <$file>, exiting"],
		      '-exit' => 1);
    $self->{'filehandle'} = *FILE;

    bless $self, $class;
}


##################################################
sub readKey
{
    my $self = shift;

    my $delimiter = $self->{'-delimiter'};
    if ($self->{'readReady'})
    {
	$self->{'readReady'} = undef;
	return ();
    }

    $self->{'lastReadKey'} = ''
	unless (defined $self->{'lastReadKey'});

    local *FILE = $self->{'filehandle'};

    my ($l, $keyline, $lineno);
    my $keyFound = undef;
    while (1)
    {
	if ($self->{'lastReadKey'} ne '')
	{
	    $l = $self->{'lastReadKey'};
	    $self->{'lastReadKey'} = '';
	    $lineno = $self->{'lastReadKeyLineno'};
	}
	else
	{
	    $l = <FILE>;
	    unless (defined $l)
	    {
		$self->{'lastReadKey'} = undef;
		$self->{'readReady'} = 1;
		$lineno = $self->{'lastReadKeyLineno'};
		return ($lineno, $keyline);
	    }
	    chomp $l;
	    $l =~ s/\#.*//;            # Kommentar weg
	    next if $l =~ /^\s*$/o;     # Leerzeilen überlesen
	}
	if ($l =~ /^(\S+)$delimiter/)   # neuer key
	{
	    if ($keyFound)             # key schon gefunden, das war's
	    {
		$self->{'lastReadKey'} = $l;
		$self->{'lastReadKeyLineno'} = $.;
		return ($lineno, $keyline);
	    }
	    else
	    {
		$keyline .= ' ' . $l;
		$keyFound = 1;
		$lineno = $.;
	    }
	}
	else
	{
	    $keyline .= ' ' . $l;
	}
    }
}


############################################################
sub readAndCheckKeys
{
    my $self = shift;

    # Defaultwerte f"ur Parameter setzen
    my (%params) = ('-defaultValues' => undef,   # pointer to hash with
		                                 # key -> (default) values
		                                 # undef = no defaults
		    '-selectKeys' => []);

    &::checkObjectParams(\%params, \@_, 'ReadKeyFromFile::readAndCheckKeys',
			 ['-selectKeys']);

    my $prLog = $self->{'prLog'};
    my $verbose = $self->{'verbose'};
    my (%sk, $sk);
    foreach $sk (@{$params{'-selectKeys'}})
    {
	$sk{$sk} = undef;
    }

    my (%key) = ();   # Keys from config file with lines as values
    (%key) = (%{$params{'-defaultValues'}}) if $params{'-defaultValues'};

    my (%lineno);     # Keys from config file with line numbers as values
    my ($lineno, $l);
    while ((($lineno, $l) = $self->readKey()) != 0)
    {
	$l =~ s/\A\s*(.*?)\s*\Z/$1/o; # eleminate white space at begin and end
	my ($key, $l) = $l =~ /^(\S+)\s*=\s*(.*)/o;
	unless (exists $sk{$key})
	{
	    $prLog->print('-kind' => 'E',
			  '-str' => ["unknown key <$key> in (" .
				     $self->{'filename'} . ", $lineno)" ]);
	    next;
	}

	$lineno{$key} = $lineno;
	$key{$key} = $l;
    }

    my $noErrors = 0;
    my $k;
    foreach $k (@{$params{'-selectKeys'}})
    {
	($noErrors, $key{$k}) =
	    &_checkForKey($k, $lineno{$k}, \%key, $noErrors, $prLog, $verbose);
    }

    return ($noErrors, \%key, \%lineno);
}


############################################################
sub _checkForKey
{
    my ($spec, $lineno, $key, $noErrors, $prLog, $verbose) = @_;

    if (exists $$key{$spec})
    {
	my ($val) = $$key{$spec} =~ /\A\s*(.*?)\s*\Z/;

	my ($error, @w) = &_splitQuotedLine($val);
	if ($error > 0)
	{
	    $prLog->print('-kind' => 'E',
			  '-str' => ["unbalanced quotes " .
				     "in line $lineno, ${error}. pair"]);
	}
	else
	{
	    $prLog->print('-kind' => 'I',
			  '-str' => ["  $spec = <" . join('> <', @w) . '>'])
		if $verbose;
	}

	return ($noErrors, \@w);
    }
    else
    {
	$prLog->print('-kind' => 'E',
		      '-str' => ["missing key <$spec> in configuration file"]);
	$noErrors++;

	return ($noErrors, undef);
    }
}


############################################################
sub _splitQuotedLine
{
    my $line = shift;

    my $entry;
    my $i = 0;                            # error code: bei welcher
                                          # Hochkommagruppe fehlt das zweite
    my (@args) = ();

    $line =~ s/\\\'/\001/go;              # \' maskieren

    while (not $line =~ /\A\s*\#/)        # nur Kommentar
    {
	last if ($line =~ /\A\s*\Z/);     # völlig leer

	$line =~ s/\A\s*//;               # führende white space löschen

	if ($line =~ /\A\'(.*)/)          # single Quotes
	{
	    ++$i;
	    $line = $1;                   # erstes Hochkomma abschneiden
	    unless ($line =~ /\A(.*?)\'(.*)/)
	    {
#		print "zweites Hochkomma fehlt\n";
		return ($i, \());         # Error == 1
	    }
	    $entry = $1;
	    $line = $2;
	}
	else
	{
	    ($entry, $line) = $line =~ /(\S+)(.*)/;
	}

	$entry =~ s/\001/\\\'/og;         # \' Maskierung rückgängig
	push @args, $entry;
    }

    return (0, @args);                    # Error == 0
}


##################################################
sub DESTROY
{
    my ($self) = shift;

    local *FILE = $self->{'filehandle'};
    close(FILE) or
	$self->{'prLog'}->print('-kind' => 'E',
				'-str' =>
				["cannot close <" .
				 $self->{'param'}{'-file'} . ">\n"]);
}

1