;#
;# Copyright (c) 1995-1998
;#	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: Param.pm,v 1.19 1998/09/19 03:58:35 ikuo Exp $
;#
;# Useful libraries to treat parameters.
;#
;#	$param = Fan::Param->new(
;#		param_name => 'INIT',
;#		%param_values);
;#
;#	$defaults = Fan::Param->new(
;#		param_name => 'DEFAULT',
;#		param_prefix => "/usr/local/etc",
;#		param_file => "param.conf");
;#
;#	$options = Fan::Param->new(
;#		param_name => 'OPTION',
;#		param_array => \@ARGV);
;#
;# Since any key begins with 'param_' has special meaning for
;# Param package, the first statement in above, %param_value
;# can have no assoc key whose name begins with 'param_'.
;#
;# You can also combine parameters, as:
;#
;#	my $override = 1;
;#	$param = Fan::Param->new(param_name => "TARGET");
;#	$param->combine($init, $override);
;#	$param->combine($defaults, $override);
;#	$param->combine($options, $override);
;#
;# These statements are equevalent with:
;#
;#	$param = Fan::Param->new(param_name => "TARGET");
;#	$param->merge($init, $defaults, $options);
;#
;# You can access to any values in a Param object as follows:
;#
;#	$param->getval('key-to-access');
;#	$param->setval('key-to-access', 'value-to-set');
;#
;# You can restrict to set values for unexpected keys with
;# `param_keys' values for a Param object. For example,
;#
;#	%param_default = (
;#		"key_any" => '',			# any value
;#		"key_digit" => '/^\d+$/ || undef',	# only digits
;#		"key_ipaddr" => '/^\d+\.\d+\.\d+\.\d+$/ || undef',
;#							# ip address
;#		"key_range" => '$_ >= 100 && $_ < 200 || undef',
;#							# number range
;#		"key_path" => '-f $_ || undef'		# real path
;#		"key_abspath" => '/^\// || undef',	# absolute path
;#		"key_proc" => \&callproc		# procedure
;#	);
;#	$param = Fan::Param->new(
;#		param_name => 'PARAM WE WILL ACCESS',
;#		param_keys => \%default_default);
;#
;# if you initialize $param as above,
;#
;# 	$param->setval('not_in_default', 'any_value'),
;#
;# will do nothing and simply returns undef. You can modify
;# $param{$key} only if $param_default{$key} exists and the
;# evaluation of
;#
;#	$_ = $val;
;#	eval $param_default{$key};
;#
;# returns non zero.
;#
package Fan::Param;

use strict;
use vars qw($VERSION $LOG $param_sequence %wants);

use Carp;
use AutoLoader 'AUTOLOAD';

$VERSION = '0.03';
$LOG = 5; # notice level...

;# Sequencial number for Param objects.
$param_sequence = 0;

;# prototypes.
sub DESTROY ($);
sub new ($%);
sub error ($;$);
sub try_check ($$;$);
sub getval ($$);
sub delete ($$);
sub setval ($$$);
sub addval ($$$);
sub dump ($);
sub combine ($@);
sub merge ($@);

;# internal routines.
sub want_ref;
sub want_code;
sub want_hash;
sub want_array;
sub want_boolean;
sub want_integer;
sub want_octal;
sub want_ipv4_addr;
sub want_path;
sub want_file;
sub want_directory;
sub want_timezone;

;# initialize want hash
%wants = (
	'REF'		=> \&want_ref,
	'CODE'		=> \&want_code,
	'HASH'		=> \&want_hash,
	'ARRAY'		=> \&want_array,
	'BOOLEAN'	=> \&want_boolean,
	'INTEGER'	=> \&want_integer,
	'OCTAL'		=> \&want_octal,
	'IPv4_ADDR'	=> \&want_ipv4_addr,
	'PATH'		=> \&want_path,
	'FILE'		=> \&want_file,	
	'DIRECTORY'	=> \&want_directory,
	'TIMEZONE'	=> \&want_timezone,
);

;#

;# A special marker for AutoSplit.
1;
__END__

;# Destroy a Param object.
;#
sub DESTROY ($) {
	my $self = shift;

	# Log message for debugging purpose
	carp("Param DESTROYING $self [$self->{param_name}]") if $LOG > 5;
}

;# Create a new Param object.
;#
sub new ($%) {
	my $this = shift;
	my $class = ref($this) || $this;
	my %param = @_;
	my $self = { param_error => 0 };

	# Count up param objects.
	$param_sequence++;

	# Pick up some special parameters.
	$self->{param_name} = $param{param_name} || "Param[$param_sequence]";

	# Check keys param object.
	if (ref($param{param_keys}) eq 'HASH') {
		$self->{param_keys} = $param{param_keys}; # save ref
	}

	# Check keys for nesting parameters.
	if (ref($param{param_nest}) eq 'HASH') {
		$self->{param_nest} = $param{param_nest}; # save ref
	}

	# Create a new object.
	bless $self, $class or return undef;

	# Log message for debugging purpose
	carp("Param CREATING $self [$self->{param_name}]") if $LOG > 5;

	# Register (key, val) pairs in %param.
	my $key;
	my $val;
	while (($key, $val) = each %param) {
		$self->setval($key, $val) if $key !~ /^param_/;
	}

	# Return myself.
	$self;
}

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

	if (@_) {
		$self->{param_error} = shift;
	}
	$self->{param_error};
}

;#
;#
sub addkey ($$;$) {
	my $p = shift;
	my $key = shift;
	my $val = @_ ? shift : '';

	$p->{param_keys}->{$key} = $val;
}

;#
;#
sub try_check ($$;$) {
	my $p = shift;
	my $key = shift;
	my $h = $p->{param_keys}; # hash for keys
	local $_ = 1; # default return value.

	# Validation of the given key.
	if ($key =~ /^param_/ || (ref($h) eq 'HASH' && !exists($h->{$key}))) {
#		carp("$p: key=$key invalid key") if $LOG > 4;
		confess("$p: key=$key invalid key") if $LOG > 4;
		$p->{param_error}++;
		return undef;
	}

	# Validation of the given value, if exists.
	if (@_ && ref($h) eq 'HASH' && exists($h->{$key})) {
		my $val = $h->{$key};
		my $x = shift; # backup
		$_ = $x;

		# copy from default wants tables.
		if (!ref($val) && defined($wants{$val})) {
			$val = $wants{$val};
		}

		# check value types
		if ($_ eq '') {
			; # null string is o.k.
		} elsif ($val eq '') {
			; # o.k.
		} elsif (ref($val) eq 'CODE') {
			$_ = &{$val}($_);
		} elsif (defined(eval($val))) {
			; # good.
		} else {
			carp $@ if $@ && $LOG > 3; # evaluation error...
			undef $_;
		}
		if (!defined($_)) {
			croak("Param ($key, $x) invalid value") if $LOG > 4;
			$p->{param_error}++;
			return undef;
		}
	}

	# Result is the converted value.
	$_;
}

;#
;#
sub getval ($$) {
	my $p = shift;
	my $key = shift;

	$p->try_check($key) || return undef;
	defined($p->{$key}) ? $p->{$key} : undef;
}

;#
;#
sub delete ($$) {
	my $p = shift;
	my $key = shift;

	$p->try_check($key) || return undef;
	exists($p->{$key}) ? CORE::delete($p->{$key}) : 0;
}

;#
;#
sub setval ($$$) {
	my $p = shift;
	my $key = shift;
	my $val = shift;

	my $x = $p->try_check($key, $val);
	defined($x) ? ($p->{$key} = $x) : undef;
}

;#
;#
sub addval ($$$) {
	my $p = shift;
	my $key = shift;
	my $val = shift;

	$val = $p->{$key}."\n".$val;
	my $x = $p->try_check($key, $val);
	defined($x) ? ($p->{$key} = $x) : undef;
}

;# dump parameters
;#
sub dump ($) {
	my $p = shift;

	print "* $p name=$p->{param_name}\n";

	my @keys = sort keys %{$p};
	my $key;

	for $key (grep(/^param_/, @keys), grep(!/^param_/, @keys)) {
		my $val = $p->{$key};
		if ($val =~ /\n/) {
			my $s = $val =~ s/^\n// ? '+' : '';
			print " $key $s=\n";
			for $s (split(/\n/, $val)) {
				print "  $s\n";
			}
		} else {
			print " $key = $val\n";
		}
	}
	1;
}

;# Combine some parameters for Param objects.
;# $p->combine($a, $b, ..., $z, $flag) will combine as follows:
;# in order of $a, $b, ..., $z, copy parameter values to $p.
;# If $flag is non zero, override is permitted.
;#
sub combine ($@) {
	my $p = shift; # output object
	my @list = ();
	my $count = 0;
	my $n;

	# check Param objects.
	while (defined($n = shift) && ref($n) && $n->isa('Fan::Param')) {
		push(@list, $n);
	}

	# now $n is the flag of override.
	my $param;
	for $param (@list) {
		my $key;
		my $val;
		while (($key, $val) = each %{$param}) {
			next if $key =~ /^param_/;
			if (exists($p->{$key})) {
				if ($val =~ /^\n/) { # append
					$val = $p->{$key}.$val;
				} elsif (!$n) { # not override
					next;
				}
			}
			if ($p->try_check($key)) {
				$p->{$key} = $val; # copy
				$count++;
			} else {
				; # simply ignored
			}
		}
	}

	# succeeded
	1;
}

;# $p->merge($a, $b, ..., $z) is same as
;# $p->combine($a, $b, ..., $z, 1);
;#
sub merge ($@) {
	my $p = shift;

	$p->combine(@_, 1);
}

;# Subroutines for check operations
;#
sub want_ref {
	my $x = shift;

	if (@_) {
		ref($x) eq shift || return undef;
	} else {
		ref($x) || return undef;
	}
	$x;
}

;#
sub want_code {
	want_ref(shift, 'CODE');
}

;#
sub want_hash {
	want_ref(shift, 'HASH');
}

;#
sub want_array {
	want_ref(shift, 'ARRAY');
}

;# want boolean value,
;# converted to 1 or 0.
;#
sub want_boolean {
	my $x = shift;

	return $& ? 1 : 0 if $x =~ /^\d+$/;
	return 1 if $x =~ /^(yes|t|true|do|will)$/i;
	return 0 if $x =~ /^(no|nil|false|dont|wont)$/i;
	undef;
}

;# want decimal value,
;# force to be converted to an integer.
;#
sub want_decimal {
	my $x = shift;

	return $& + 0 if $x =~ /^\d+$/;
	undef;
}

;# want octal value,
;#
sub want_octal {
	my $x = shift;

	return $& if $x =~ /^[0-7]+$/;
	undef;
}

;# want an integer value (with or without sign),
;# force to be an integer.
;#
sub want_integer {
	my $x = shift;
	my $flag = 1;

	if ($x =~ s/^-//) {
		$flag = -1;
	} elsif ($x =~ s/^\+//) {
		;
	}

	return $flag * $& if $x =~ /^\d+$/;
	undef;
}

;# want IPv4 address.
;#
sub want_ipv4_addr {
	my $x = shift;

	return $& if $x =~ /^\d+\.\d+\.\d+\.\d+$/;
	undef;
}

;# want_path($string, $eval)
;# convert a tilda notation (like ~ftp).
;#
sub want_path {
	my $path = shift;
	my $dir = '';

# warn("input is \"$path\"\n");

	# Expand pathname first.
	# For example, "~ikuo/src/hogehoge" will expanded to
	# "/home/ikuo/src/hogehoge".
	if ($path =~ s|^~([^/]*)||) {
		if ($1 ne '') {
			$dir = (getpwnam($1))[7];
		} else {
			$dir = $ENV{'HOME'} || (getpwuid($<))[7];
		}
		$path = $dir.$path;
	}

	# Result must not be null string.
	return undef if $path eq '';

	# Evaluation test.
	if (@_) {
		local $_ = $path;

		if(!defined(eval shift)) {
			carp $@ if $@ && $LOG > 3;
# warn("result is undef\n");
			return undef;
		}
		$path = $_;
	}

# warn("result is path\n");
	# Result is $path.
	$path;
}

;#
sub want_file {
	want_path(shift, '-f $_ || undef');
}

;#
sub want_directory {
	want_path(shift, '-d $_ || undef');
}

;# want timezone.
;# converted to ``sign . %02d . %02d ''.
;#
sub want_timezone {
	my $tz = shift;

	if ($tz =~ /^(\+|-)(\d\d?)(\d\d)$/) {
		return sprintf("%s%02d%02d", $1, $2, $3);
	} elsif ($tz eq 'GMT') {
		return '+0000';	
	} elsif ($tz eq 'JST') {
		return '+0900';	
	}
	undef;
}

;# end of Fan::Param module