洗練されたPerl: Perlによるアプリケーションの設定 第2回

                
# SSN: must be a string with exactly 9 digits
# LIMITED: must be a string key existing in the hash %limited_hash
$config->define(
# more complex subroutine validation
                'SSN'      => { ARGCOUNT => ARGCOUNT_ONE,
				VALIDATE => sub	
				{
				 my $varname = shift @_;
				 my $value = shift @_;
				 # only succeed with 9 digits in $value
				 return (9 == ($value =~ tr/0-9//));
				}
			      },
# limited values, must be 'alpha' or 'beta'
                'LIMITED'  => { ARGCOUNT => ARGCOUNT_ONE,
				VALIDATE => sub 
				{
				 my $varname = shift @_;
				 my $value = shift @_;
				 my %limited_hash = ( alpha => 1, beta => 2 );
				 return exists $limited_hash{$value};
				}
			      },
               );

                
$config->define(
                'TRIGGER' => { ARGCOUNT => ARGCOUNT_ONE,
                                ACTION => sub # autoaction
                                          {
                                           my $config = shift @_;
                                           my $varname = shift @_;
                                           my $value = shift @_;
                                           print "$varname = $value\n";
                                           $value++;
                                           $config->TRIGGER($value);
                                          }
                              }
               );
                    

                
$config->define('HOSTS' => { ARGCOUNT => ARGCOUNT_LIST });
# add a value to the array named HOSTS
$config->HOSTS("jove");
# list the values in the HOSTS array
print "$_\n" foreach @{$config->HOSTS};
# reset the array to 0 entries
$config->_default("HOSTS");

                
$config->define('PHONE' => { ARGCOUNT => ARGCOUNT_HASH });
# add values to the hash named PHONE
$config->PHONE("jimmy=1-800-453-2211");
# unusual cases
$config->PHONE("equals=a=b"); # the value will be "a=b"
$config->PHONE("harry=");     # the value will be a string of length 0 ('')
$config->PHONE("harry");      # the value will be undef
# list the sorted keys and their values in the PHONE hash
print "$_ => ", $config->PHONE()->{$_}, "\n" foreach sort keys %{$config->PHONE};
# you can also do it with Data::Dumper
print Dumper $config->PHONE;
# reset the hash to 0 entries
$config->_default("PHONE");
                    

                
my $config = AppConfig->new();
$config->define(
     # mutually exclusive options
    'FILE'       => { ARGCOUNT => ARGCOUNT_NONE, DEFAULT => 0, ACTION =>\&toggle_type },
    'DIRECTORY'  => { ARGCOUNT => ARGCOUNT_NONE, DEFAULT => 0, ACTION =>\&toggle_type },
    'SPECIAL'    => { ARGCOUNT => ARGCOUNT_NONE, DEFAULT => 1, ACTION =>\&toggle_type },
              );
# {{{ toggle_type: do the right thing when file type is specified (3 mutually exclusive options)
sub toggle_type
{
 my $self    = shift @_;
 my $varname = shift @_;
 my $value   = shift @_;
 return unless $value;                  # do nothing if we're being turned off
 # turn off all options except the one that invoked this action
 $self->set($_, 0) foreach grep !/^$varname$/i, qw/FILE DIRECTORY SPECIAL/;
}

                
#!/usr/bin/perl -w
use strict;
use AppConfig qw/:argcount/;
my $config = AppConfig->new();
$config->define(
                'TIMES'    => { ARGCOUNT => ARGCOUNT_HASH, ACTION =>\&toggle_option },
                'WINNER'   => { ARGCOUNT => ARGCOUNT_ONE,  ACTION =>\&cheat_action  },
                'LOSER'    => { ARGCOUNT => ARGCOUNT_ONE,  ACTION =>\&cheat_action  },
                'CHEATERS' => { ARGCOUNT => ARGCOUNT_NONE },
              );
$config->TIMES("Johnny Boy = .444");
$config->TIMES("Johnny Appleseed = 2.45");
$config->TIMES("Johnny Be Good = 8.002");
print "Winner: ", $config->WINNER, "\n";
print "Loser: ", $config->LOSER, "\n";
$config->WINNER("Johnny Be Good");
print "Winner: ", $config->WINNER, "\n";
print "Loser: ", $config->LOSER, "\n";
$config->LOSER("Johnny Be Good");
print "Winner: ", $config->WINNER, "\n";
print "Loser: ", $config->LOSER, "\n";
# {{{ toggle_option: toggle interdependent options 
sub toggle_option
{
 my $self    = shift @_;
 my $varname = shift @_;
 my $value   = shift @_; my @sorted =  sort { $self->TIMES()->{$a} <=> $self->TIMES()->{$b} } keys %{$self->TIMES};
 if (scalar @sorted > 1)                # we need more than 1 member to have a winner and a loser
 {
  # we have to set winner and loser directly to avoid the cheat_action
  $self->{VARIABLE}->{winner} = $sorted[0];
  $self->{VARIABLE}->{loser} = $sorted[-1];
 }
}
# }}}
# {{{ cheat_action: set TIMES hash value for a given key so it's always the winner or the loser
sub cheat_action
{
 my $self    = shift @_;
 my $varname = shift @_;
 my $value   = shift @_; my $time;
 $varname = uc $varname;                # make sure we match the variable name
 if ($varname eq 'WINNER')
 {
  # set the time to 0 unconditionally
  $time = 0;
 }
 elsif ($varname eq 'LOSER')
 {
  # set the time to the sum of all the times (it will always be the worst time, then)
  $time += $_ foreach values %{$config->TIMES()};
 }
 # trigger a resorting by inserting the newly wanted time
 $self->TIMES("$value=$time");
}
# }}}