1;#
2;# Copyright (c) 1995-1998
3;#	Ikuo Nakagawa. All rights reserved.
4;#
5;# Redistribution and use in source and binary forms, with or without
6;# modification, are permitted provided that the following conditions
7;# are met:
8;#
9;# 1. Redistributions of source code must retain the above copyright
10;#    notice unmodified, this list of conditions, and the following
11;#    disclaimer.
12;# 2. Redistributions in binary form must reproduce the above copyright
13;#    notice, this list of conditions and the following disclaimer in the
14;#    documentation and/or other materials provided with the distribution.
15;#
16;# THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
17;# ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
18;# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
19;# PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS
20;# BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY,
21;# OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT
22;# OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
23;# BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
24;# WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
25;# OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE,
26;# EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
27;#
28;# $Id: Param.pm,v 1.19 1998/09/19 03:58:35 ikuo Exp $
29;#
30;# Useful libraries to treat parameters.
31;#
32;#	$param = Fan::Param->new(
33;#		param_name => 'INIT',
34;#		%param_values);
35;#
36;#	$defaults = Fan::Param->new(
37;#		param_name => 'DEFAULT',
38;#		param_prefix => "/usr/local/etc",
39;#		param_file => "param.conf");
40;#
41;#	$options = Fan::Param->new(
42;#		param_name => 'OPTION',
43;#		param_array => \@ARGV);
44;#
45;# Since any key begins with 'param_' has special meaning for
46;# Param package, the first statement in above, %param_value
47;# can have no assoc key whose name begins with 'param_'.
48;#
49;# You can also combine parameters, as:
50;#
51;#	my $override = 1;
52;#	$param = Fan::Param->new(param_name => "TARGET");
53;#	$param->combine($init, $override);
54;#	$param->combine($defaults, $override);
55;#	$param->combine($options, $override);
56;#
57;# These statements are equevalent with:
58;#
59;#	$param = Fan::Param->new(param_name => "TARGET");
60;#	$param->merge($init, $defaults, $options);
61;#
62;# You can access to any values in a Param object as follows:
63;#
64;#	$param->getval('key-to-access');
65;#	$param->setval('key-to-access', 'value-to-set');
66;#
67;# You can restrict to set values for unexpected keys with
68;# `param_keys' values for a Param object. For example,
69;#
70;#	%param_default = (
71;#		"key_any" => '',			# any value
72;#		"key_digit" => '/^\d+$/ || undef',	# only digits
73;#		"key_ipaddr" => '/^\d+\.\d+\.\d+\.\d+$/ || undef',
74;#							# ip address
75;#		"key_range" => '$_ >= 100 && $_ < 200 || undef',
76;#							# number range
77;#		"key_path" => '-f $_ || undef'		# real path
78;#		"key_abspath" => '/^\// || undef',	# absolute path
79;#		"key_proc" => \&callproc		# procedure
80;#	);
81;#	$param = Fan::Param->new(
82;#		param_name => 'PARAM WE WILL ACCESS',
83;#		param_keys => \%default_default);
84;#
85;# if you initialize $param as above,
86;#
87;# 	$param->setval('not_in_default', 'any_value'),
88;#
89;# will do nothing and simply returns undef. You can modify
90;# $param{$key} only if $param_default{$key} exists and the
91;# evaluation of
92;#
93;#	$_ = $val;
94;#	eval $param_default{$key};
95;#
96;# returns non zero.
97;#
98package Fan::Param;
99
100use strict;
101use vars qw($VERSION $LOG $param_sequence %wants);
102
103use Carp;
104use AutoLoader 'AUTOLOAD';
105
106$VERSION = '0.03';
107$LOG = 5; # notice level...
108
109;# Sequencial number for Param objects.
110$param_sequence = 0;
111
112;# prototypes.
113sub DESTROY ($);
114sub new ($%);
115sub error ($;$);
116sub try_check ($$;$);
117sub getval ($$);
118sub delete ($$);
119sub setval ($$$);
120sub addval ($$$);
121sub dump ($);
122sub combine ($@);
123sub merge ($@);
124
125;# internal routines.
126sub want_ref;
127sub want_code;
128sub want_hash;
129sub want_array;
130sub want_boolean;
131sub want_integer;
132sub want_octal;
133sub want_ipv4_addr;
134sub want_path;
135sub want_file;
136sub want_directory;
137sub want_timezone;
138
139;# initialize want hash
140%wants = (
141	'REF'		=> \&want_ref,
142	'CODE'		=> \&want_code,
143	'HASH'		=> \&want_hash,
144	'ARRAY'		=> \&want_array,
145	'BOOLEAN'	=> \&want_boolean,
146	'INTEGER'	=> \&want_integer,
147	'OCTAL'		=> \&want_octal,
148	'IPv4_ADDR'	=> \&want_ipv4_addr,
149	'PATH'		=> \&want_path,
150	'FILE'		=> \&want_file,
151	'DIRECTORY'	=> \&want_directory,
152	'TIMEZONE'	=> \&want_timezone,
153);
154
155;#
156
157;# A special marker for AutoSplit.
1581;
159__END__
160
161;# Destroy a Param object.
162;#
163sub DESTROY ($) {
164	my $self = shift;
165
166	# Log message for debugging purpose
167	carp("Param DESTROYING $self [$self->{param_name}]") if $LOG > 5;
168}
169
170;# Create a new Param object.
171;#
172sub new ($%) {
173	my $this = shift;
174	my $class = ref($this) || $this;
175	my %param = @_;
176	my $self = { param_error => 0 };
177
178	# Count up param objects.
179	$param_sequence++;
180
181	# Pick up some special parameters.
182	$self->{param_name} = $param{param_name} || "Param[$param_sequence]";
183
184	# Check keys param object.
185	if (ref($param{param_keys}) eq 'HASH') {
186		$self->{param_keys} = $param{param_keys}; # save ref
187	}
188
189	# Check keys for nesting parameters.
190	if (ref($param{param_nest}) eq 'HASH') {
191		$self->{param_nest} = $param{param_nest}; # save ref
192	}
193
194	# Create a new object.
195	bless $self, $class or return undef;
196
197	# Log message for debugging purpose
198	carp("Param CREATING $self [$self->{param_name}]") if $LOG > 5;
199
200	# Register (key, val) pairs in %param.
201	my $key;
202	my $val;
203	while (($key, $val) = each %param) {
204		$self->setval($key, $val) if $key !~ /^param_/;
205	}
206
207	# Return myself.
208	$self;
209}
210
211;#
212sub error ($;$) {
213	my $self = shift;
214
215	if (@_) {
216		$self->{param_error} = shift;
217	}
218	$self->{param_error};
219}
220
221;#
222;#
223sub addkey ($$;$) {
224	my $p = shift;
225	my $key = shift;
226	my $val = @_ ? shift : '';
227
228	$p->{param_keys}->{$key} = $val;
229}
230
231;#
232;#
233sub try_check ($$;$) {
234	my $p = shift;
235	my $key = shift;
236	my $h = $p->{param_keys}; # hash for keys
237	local $_ = 1; # default return value.
238
239	# Validation of the given key.
240	if ($key =~ /^param_/ || (ref($h) eq 'HASH' && !exists($h->{$key}))) {
241#		carp("$p: key=$key invalid key") if $LOG > 4;
242		confess("$p: key=$key invalid key") if $LOG > 4;
243		$p->{param_error}++;
244		return undef;
245	}
246
247	# Validation of the given value, if exists.
248	if (@_ && ref($h) eq 'HASH' && exists($h->{$key})) {
249		my $val = $h->{$key};
250		my $x = shift; # backup
251		$_ = $x;
252
253		# copy from default wants tables.
254		if (!ref($val) && defined($wants{$val})) {
255			$val = $wants{$val};
256		}
257
258		# check value types
259		if ($_ eq '') {
260			; # null string is o.k.
261		} elsif ($val eq '') {
262			; # o.k.
263		} elsif (ref($val) eq 'CODE') {
264			$_ = &{$val}($_);
265		} elsif (defined(eval($val))) {
266			; # good.
267		} else {
268			carp $@ if $@ && $LOG > 3; # evaluation error...
269			undef $_;
270		}
271		if (!defined($_)) {
272			croak("Param ($key, $x) invalid value") if $LOG > 4;
273			$p->{param_error}++;
274			return undef;
275		}
276	}
277
278	# Result is the converted value.
279	$_;
280}
281
282;#
283;#
284sub getval ($$) {
285	my $p = shift;
286	my $key = shift;
287
288	$p->try_check($key) || return undef;
289	defined($p->{$key}) ? $p->{$key} : undef;
290}
291
292;#
293;#
294sub delete ($$) {
295	my $p = shift;
296	my $key = shift;
297
298	$p->try_check($key) || return undef;
299	exists($p->{$key}) ? CORE::delete($p->{$key}) : 0;
300}
301
302;#
303;#
304sub setval ($$$) {
305	my $p = shift;
306	my $key = shift;
307	my $val = shift;
308
309	my $x = $p->try_check($key, $val);
310	defined($x) ? ($p->{$key} = $x) : undef;
311}
312
313;#
314;#
315sub addval ($$$) {
316	my $p = shift;
317	my $key = shift;
318	my $val = shift;
319
320	$val = $p->{$key}."\n".$val;
321	my $x = $p->try_check($key, $val);
322	defined($x) ? ($p->{$key} = $x) : undef;
323}
324
325;# dump parameters
326;#
327sub dump ($) {
328	my $p = shift;
329
330	print "* $p name=$p->{param_name}\n";
331
332	my @keys = sort keys %{$p};
333	my $key;
334
335	for $key (grep(/^param_/, @keys), grep(!/^param_/, @keys)) {
336		my $val = $p->{$key};
337		if ($val =~ /\n/) {
338			my $s = $val =~ s/^\n// ? '+' : '';
339			print " $key $s=\n";
340			for $s (split(/\n/, $val)) {
341				print "  $s\n";
342			}
343		} else {
344			print " $key = $val\n";
345		}
346	}
347	1;
348}
349
350;# Combine some parameters for Param objects.
351;# $p->combine($a, $b, ..., $z, $flag) will combine as follows:
352;# in order of $a, $b, ..., $z, copy parameter values to $p.
353;# If $flag is non zero, override is permitted.
354;#
355sub combine ($@) {
356	my $p = shift; # output object
357	my @list = ();
358	my $count = 0;
359	my $n;
360
361	# check Param objects.
362	while (defined($n = shift) && ref($n) && $n->isa('Fan::Param')) {
363		push(@list, $n);
364	}
365
366	# now $n is the flag of override.
367	my $param;
368	for $param (@list) {
369		my $key;
370		my $val;
371		while (($key, $val) = each %{$param}) {
372			next if $key =~ /^param_/;
373			if (exists($p->{$key})) {
374				if ($val =~ /^\n/) { # append
375					$val = $p->{$key}.$val;
376				} elsif (!$n) { # not override
377					next;
378				}
379			}
380			if ($p->try_check($key)) {
381				$p->{$key} = $val; # copy
382				$count++;
383			} else {
384				; # simply ignored
385			}
386		}
387	}
388
389	# succeeded
390	1;
391}
392
393;# $p->merge($a, $b, ..., $z) is same as
394;# $p->combine($a, $b, ..., $z, 1);
395;#
396sub merge ($@) {
397	my $p = shift;
398
399	$p->combine(@_, 1);
400}
401
402;# Subroutines for check operations
403;#
404sub want_ref {
405	my $x = shift;
406
407	if (@_) {
408		ref($x) eq shift || return undef;
409	} else {
410		ref($x) || return undef;
411	}
412	$x;
413}
414
415;#
416sub want_code {
417	want_ref(shift, 'CODE');
418}
419
420;#
421sub want_hash {
422	want_ref(shift, 'HASH');
423}
424
425;#
426sub want_array {
427	want_ref(shift, 'ARRAY');
428}
429
430;# want boolean value,
431;# converted to 1 or 0.
432;#
433sub want_boolean {
434	my $x = shift;
435
436	return $& ? 1 : 0 if $x =~ /^\d+$/;
437	return 1 if $x =~ /^(yes|t|true|do|will)$/i;
438	return 0 if $x =~ /^(no|nil|false|dont|wont)$/i;
439	undef;
440}
441
442;# want decimal value,
443;# force to be converted to an integer.
444;#
445sub want_decimal {
446	my $x = shift;
447
448	return $& + 0 if $x =~ /^\d+$/;
449	undef;
450}
451
452;# want octal value,
453;#
454sub want_octal {
455	my $x = shift;
456
457	return $& if $x =~ /^[0-7]+$/;
458	undef;
459}
460
461;# want an integer value (with or without sign),
462;# force to be an integer.
463;#
464sub want_integer {
465	my $x = shift;
466	my $flag = 1;
467
468	if ($x =~ s/^-//) {
469		$flag = -1;
470	} elsif ($x =~ s/^\+//) {
471		;
472	}
473
474	return $flag * $& if $x =~ /^\d+$/;
475	undef;
476}
477
478;# want IPv4 address.
479;#
480sub want_ipv4_addr {
481	my $x = shift;
482
483	return $& if $x =~ /^\d+\.\d+\.\d+\.\d+$/;
484	undef;
485}
486
487;# want_path($string, $eval)
488;# convert a tilda notation (like ~ftp).
489;#
490sub want_path {
491	my $path = shift;
492	my $dir = '';
493
494# warn("input is \"$path\"\n");
495
496	# Expand pathname first.
497	# For example, "~ikuo/src/hogehoge" will expanded to
498	# "/home/ikuo/src/hogehoge".
499	if ($path =~ s|^~([^/]*)||) {
500		if ($1 ne '') {
501			$dir = (getpwnam($1))[7];
502		} else {
503			$dir = $ENV{'HOME'} || (getpwuid($<))[7];
504		}
505		$path = $dir.$path;
506	}
507
508	# Result must not be null string.
509	return undef if $path eq '';
510
511	# Evaluation test.
512	if (@_) {
513		local $_ = $path;
514
515		if(!defined(eval shift)) {
516			carp $@ if $@ && $LOG > 3;
517# warn("result is undef\n");
518			return undef;
519		}
520		$path = $_;
521	}
522
523# warn("result is path\n");
524	# Result is $path.
525	$path;
526}
527
528;#
529sub want_file {
530	want_path(shift, '-f $_ || undef');
531}
532
533;#
534sub want_directory {
535	want_path(shift, '-d $_ || undef');
536}
537
538;# want timezone.
539;# converted to ``sign . %02d . %02d ''.
540;#
541sub want_timezone {
542	my $tz = shift;
543
544	if ($tz =~ /^(\+|-)(\d\d?)(\d\d)$/) {
545		return sprintf("%s%02d%02d", $1, $2, $3);
546	} elsif ($tz eq 'GMT') {
547		return '+0000';
548	} elsif ($tz eq 'JST') {
549		return '+0900';
550	}
551	undef;
552}
553
554;# end of Fan::Param module
555