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