;#
;# Copyright (c) 1995-1997
;#	Ikuo Nakagawa. All rights reserved.
;#
;# Redistribution and use in source and binary forms, with or without
;# modification, are permitted provided that the following conditions
;# are met:
;#
;# 1. Redistributions of source code must retain the above copyright
;#    notice unmodified, this list of conditions, and the following
;#    disclaimer.
;# 2. Redistributions in binary form must reproduce the above copyright
;#    notice, this list of conditions and the following disclaimer in the
;#    documentation and/or other materials provided with the distribution.
;#
;# THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
;# ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
;# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
;# PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS
;# BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY,
;# OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT
;# OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
;# BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
;# WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
;# OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE,
;# EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
;#
;# $Id: Loader.pm,v 1.22 1997/09/26 04:48:33 ikuo Exp $
;#
package Fan::Loader;

use strict;
use vars qw($VERSION $LOG);

use Carp;
use Fan::Param;
use AutoLoader 'AUTOLOAD';

$VERSION = '0.02';
$LOG = 5;

;# A special marker for AutoSplit.
1;
__END__

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

	carp("Loader DESTROYING $self") if $LOG >= 6;
}

;#
sub new ($;%) {
	my $this = shift;
	my $class = ref($this) || $this;
	my %param = @_;
	my $keys = $param{loader_keys};
	my $nest = $param{loader_nest};

	my $self = {
		loader_keys => ref($keys) eq 'HASH' ? $keys : undef,
		loader_nest => ref($nest) eq 'HASH' ? $nest : undef,
		loader_db => {},
		loader_current => 'DEFAULT'
	};

	bless $self, $class or croak("Loader::new bless: $!");
	carp("Loader CREATING $self") if $LOG >= 6;
	$self;
}

;#
;# $loader->search($package_name [, $create]);
;#
sub search ($;$$) {
	my $self = shift;
	my $name = shift;
	my $genflag = shift;

	$name = $self->{loader_current} if $name eq '';
	$name ne '' or confess("Empty name was detected");

	# Is there a database for given name?
	my $p = $self->{loader_db}->{$name};

	# Check value and create a new one if needed.
	if (!ref($p)) { # $p->isa('Fan::Param') must also be true.
		unless ($genflag) {
#warn("search: $name not found.\n");
			# We can't generate a new one.
			return undef; # simply return FALSE.
		}
		$p = Fan::Param->new(
			param_name => $name,
			param_keys => $self->{loader_keys}
		);
		ref($p) or carp("Can't create Param object"), return undef;
		$self->{loader_db}->{$name} = $p;
#warn("search: $name = $p created.\n");
	}

	# DEBUG only
	ref($p) && $p->isa('Fan::Param')
		or confess("$p must be a Param object");

	# Register this object as `current' param.
	$self->{loader_current} = $name;

#warn("search: $name = $p found.\n");

	# return Param object.
	$p;
}

;#
;# undef name		... clear a variable `name'.
;# name			... set the value of `name' to 1.
;# name = value		... set the value of `name' to `value'.
;# name += value	... add \n + `value' to `name'.
;#
;# 1 will be returned on success.
;# when name has special meaning,... what shall we do?
;#
sub parse_line ($$;$) {
	my $self = shift;
	my $nest = $self->{loader_nest}; # hash ref.
	local $_ = shift; # an input line.
	my $param = @_ ? shift : ''; # Param object or Param name.
	my $p;

	# check param...
	if (ref($param) && $param->isa('Fan::Param')) {
		$p= $param;
	} else {
		ref($p= $self->search($param, 1)) && $p->isa('Fan::Param')
			or confess("Can't get a Param object for $param");
	}

	# Trim leading/trailing spaces.
	s/^\s+//; s/\s+$//;

	# Skip comment or null lines.
	return 0 if /^$/ || /^#/;

	# Set default value of the result.
	my($key, $val, $todo);

	# Parse this line.
	if (/^$/ || /^#/) {		# skip comment lines.
		return '';
	} elsif (/^delete\s+/) {	# delete variable.
		($key, $val, $todo) = ($', undef, 'delete');
	} elsif (/^undef\s+/) {		# set undef... TO BE FIXED.
		($key, $val, $todo) = ($', '', 'setval');
	} elsif (/\s*\+=\s*/) {		# add value.
		($key, $val, $todo) = ($`, $', 'addval');
	} elsif (/\s*=\s*/) {		# set value.
		($key, $val, $todo) = ($`, $', 'setval');
	} else {			# set to 1.
		($key, $val, $todo) = ($_, 1, 'setval');
	}

	# Convert `-' to `_'.
	$key =~ y/-/_/;
#warn("loader: key=$key, val=$val, todo=$todo\n");

	# Check special action.
	if (ref($nest) eq 'HASH' && exists($nest->{$key})) {
		my $s = $nest->{$key}; # make a copy...
		my $result;

		if ($s =~ s/^!//) {
			local $_ = $val;
			$result = eval $s;
			croak("loader: ".$@) if $@;
		} else {
			($result = $s) =~ s/\$_/$val/g;
		}
		if (!defined($result)) {
			croak("loader: wrong usage of $key");
		}
		if ($result eq '') {
			croak("loader: empty name found");
		}
		return $result;
	}

	# To check errors.
	my $err = 0;

	# Do real action.
	if ($todo eq '') {
		;
	} elsif ($todo eq 'delete') {
		$err++ if !defined($p->delete($key));
	} elsif ($todo eq 'addval') {
		$err++ if !defined($p->addval($key, $val));
	} elsif ($todo eq 'setval') {
		$err++ if !defined($p->setval($key, $val));
	} else { # what? this can't be happen.
		confess("loader: unexpected todo");
	}

	# Check the result.
	if ($err) {
		croak("loader: \"$key\" unrecognized parameter");
	}

	# Result is an empty string for normal cases.
	'';
}

;#
;# $p->parse_option(\@ARRAY);
;#
sub parse_option ($\@;$) {
	my $self = shift; # loader
	my $array = shift; # reference to ARRAY
	my $param_name = @_ ? shift : '';
	my $p = $self->search($param_name, 1);

	# DEBUG only
	ref($p) && $p->isa('Fan::Param')
		or confess("$p must be a Param object");

	# Array format is "--tag=value".
	while (@{$array} && ${$array}[$[] =~ s/^--//) {
		my $x = $self->parse_line(shift(@{$array}), $p);
		if (!defined($x)) {
			croak("loader: error found in parse_option");
		} elsif ($x eq '') { # good.
			;
		} else {
			$p = $self->search($x, 1);
			# DEBUG only
			ref($p) && $p->isa('Fan::Param')
				or confess("$p must be a Param object");
		}
	}

	# This routine returns # of (key, val) pairs we changed.
	1;
}

;# Load file and set parameters.
;#
;# $p->parse_file(filename);
;#
sub parse_file ($$;$) {
	my $self = shift;
	my $file = shift;
	my $param_name = @_ ? shift : '';
	my $p = $self->search($param_name, 1);

	# DEBUG only
	ref($p) && $p->isa('Fan::Param')
		or confess("$p must be a Param object");

	# Check filename, add prefix is filename is relative path.
	if ($file !~ /^\// && $self->{loader_prefix} ne '') {
		$file = $self->{loader_prefix}.'/'.$file;
	}

	# Open file
	local *FILE;
	unless (open(FILE, $file)) {
		carp("$self: open($file) - $!") if $LOG > 4;
		return undef;
	}

	# Reading lines
	my $line = '';
	local $_;
	while (<FILE>) {

		# strip CR/LF at end.
		chomp;
		s/\r?$//;

		# for cont'd lines
		if ($line ne '') {
			s/^\s+// ; # strip leading spaces
			$_ = $line.$_; # concat to saved line
		}
		$line = $_, next if s/\\$//; # cont'd line

		# found one line.
		$line = ''; # clear

		# trim leading/trailing spaces, and skip comment lines.
		s/^\s+//; s/\s+$//;
		next if /^$/ || /^#/;

		# try to parse, and check result
		my $x = $self->parse_line($_, $p);
		if (!defined($x)) {
			croak("$file($.): error was detected");
		} elsif ($x eq '') { # good.
			;
		} else {
			$p = $self->search($x, 1);
			# DEBUG only
			ref($p) && $p->isa('Fan::Param')
				or confess("$p must be a Param object");
		}
	}

	# we may be able to comment out the next line.
	close(FILE);

	# Returns # of ($key, $val) pairs we changed.
	1;
}

;#
;# $loader->combine_hash(\%hash [, 'PARAM_NAME' [, $override]])
;#
sub combine_hash ($\%;$$) {
	my $self = shift;
	my $hash = shift;
	my $param_name = @_ ? shift : '';
	my $p = $self->search($param_name, 1);
	my $f = shift;

	ref($hash) eq 'HASH'
		or carp("$hash must be HASH"), return undef;

	my $param = Fan::Param->new(
		param_name => 'temp',
		param_keys => $self->{loader_keys},
		%{$hash});
	ref($param) && $param->isa('Fan::Param') or return undef;

	$p->combine($param, $f);
}

;#
sub merge_hash ($\%;$) {
	my $self = shift;
	my $hash = shift;
	my $param_name = @_ ? shift : '';
	my $p = $self->search($param_name, 1);
	my $f = shift;

	$self->combine_hash($hash, $param_name, 1);
}

;# dump all Param objects in registry.
sub dumpall ($) {
	my $self = shift; # loader
	my $name;
	my $param;

	while (($name, $param) = each %{$self->{loader_db}}) {
		$param->dump;
	}
}

;#
;# $loader->get_value('key-you-want', 'key-of-param', 'key-of-param',...);
;#
sub get_value ($$@) {
	my $self = shift;
	my $want = shift;
	my @keys = @_;
	my $val = undef;

# warn("try get value of \"$want\" from (".join(', ', @keys).")\n");
	while (@keys) {
		my $key = pop(@keys);
		my $p = $self->{loader_db}->{$key};
		if (ref($p) && $p->isa('Fan::Param')) {
# warn("  try $key\n");
			my $v = $p->getval($want);
			if (defined($v)) {
				$val = $v.$val;
# warn("  found val = $v\n");
				last if $v !~ /^\n/;
			}
		}
	}

	# not found...
# { my $v = $val; $v =~ s/\n/ /g; warn("  returning val = $v\n"); }
	$val;
}

;# end of Fan::Loader module