package RDA::Setting;

# $Id: Setting.pm,v 1.76 2009/05/21 00:18:51 mschenke Exp $
# ARCS: $Header: /u02/webapps/workbench/cvs/RDA_4/src/scripting/lib/RDA/Setting.pm,v 1.76 2009/05/21 00:18:51 mschenke Exp $
#
# Change History
# 20090521  MSC  Improve the search mechanism.

=head1 NAME

RDA::Setting - Class Used for Objects to Setup Settings

=head1 SYNOPSIS

require RDA::Setting;

=head1 DESCRIPTION

The objects of the C<RDA::Setting> class are used to manage the setup of a
setting.

The following methods are available:

=cut

use strict;

BEGIN
{ use Exporter;
  use File::Basename;
  use File::Spec;
  use RDA::Object::Xml;
}

# Define the global public variables
use vars qw($VERSION);
$VERSION = sprintf("%d.%02d", q$Revision: 1.76 $ =~ /(\d+)\.(\d+)/);

# Define the global private variables
my $re_cfg = qr/<<(CONFIG):(\w+):(\d+):(.*)$/i;
my $re_ext = qr/<<EXTERN:([\w\/]+):(\w+):(.*)$/i;
my $re_mod = qr/<<MODULES:([^:]+):(.*?)(#(.*))?$/i;
my $re_lst = qr/<<(LIST):(\w+):(\-?\d+):(.*)$/i;
my $re_src = qr/<<(SEARCH):(\w+):([bdnprtw]*):(.*)$/i;
my $re_xml = qr/<<(XML):(\w+):(\w*):(.*)$/i;

my %tb_dft = (
  'B' => \&_dft_boolean,
  'C' => \&_dft_comment,
  'D' => \&_dft_dir,
  'E' => \&_dft_event,
  'F' => \&_dft_file,
  'I' => \&_dft_none,
  'L' => \&_dft_none,
  'M' => \&_dft_menu,
  'N' => \&_dft_value,
  'P' => \&_dft_product,
  'T' => \&_dft_value,
  );
my %tb_dsp = (
  'M' => \&_dsp_menu,
  );
my %tb_get = (
  'B' => \&_get_boolean,
  'D' => \&_get_dir,
  'F' => \&_get_file,
  'M' => \&_get_menu,
  'N' => \&_get_number,
  'T' => \&_get_value,
  );
my %tb_val = (
  'B' => \&_val_boolean,
  'D' => \&_val_dir,
  'F' => \&_val_file,
  'I' => \&_val_if,
  'L' => \&_val_loop,
  'M' => \&_val_menu,
  'N' => \&_val_number,
  'P' => \&_val_product,
  'T' => \&_val_value,
  );

# Report the module version number
sub Version
{ $VERSION;
}

=head2 S<$h = RDA::Setting-E<gt>new($nam)>

The object constructor. It takes the setting name as an argument.

C<RDA::Setting> is represented by a blessed hash reference. The following
special keys are used:

=over 12

=item S<    B<'_def'> > Definition name

=item S<    B<'_col'> > Optional multi-column indicator

=item S<    B<'_clr'> > Clear string

=item S<    B<'_dft'> > Default value

=item S<    B<'_dsc'> > Description string

=item S<    B<'_dup'> > Duplication value error message

=item S<    B<'_end'> > String that indicates the end of a value list

=item S<    B<'_err'> > Setting error text

=item S<    B<'_fam'> > Optional list of operating system families

=item S<    B<'_hlp'> > Setting help text

=item S<    B<'_inp'> > Setting prompt string

=item S<    B<'_itm'> > Menu item definition

=item S<    B<'_man'> > Setting manual text

=item S<    B<'_mnu'> > Menu item definition

=item S<    B<'_nam'> > Setting effective name

=item S<    B<'_one'> > Value to convert a value list in a single value

=item S<    B<'_opt'> > Optional setting flag

=item S<    B<'_ref'> > Setting validation reference

=item S<    B<'_rsp'> > Valid menu responses

=item S<    B<'_sep'> > Value separator

=item S<    B<'_typ'> > Setting type

=item S<    B<'_val'> > Setting validation type

=item S<    B<'_var'> > Array of additional settings

=item S<    B<'_vis'> > Flag to control character echo during input

=item S<    B<'-cnt'> > Retry counter

=item S<    B<'-cur'> > Current value

=item S<    B<'-fmt'> > Menu selector format

=item S<    B<'-itm'> > Menu item description hash

=item S<    B<'-lgt'> > Maximum length of the menu item selectors

=item S<    B<'-mnu'> > Array of displayed menu items

=item S<    B<'-nxt'> > Array of next values

=item S<    B<'-prv'> > Array of previous values

=item S<    B<'-rsp'> > Menu response hash

=item S<    B<'-sav'> > Saved elements

=back

Internal keys are prefixed by an underscore or a dash.

=cut

sub new
{ my $slf = shift;
  my $cls = ref($slf) || $slf;
  my $nam = shift;

  # Create the data collection object
  $slf = bless {_def => $nam}, $cls;

  # Set some attribute defaults
  $slf->{'_clr'} = '';
  $slf->{'_col'} = 0;
  $slf->{'_dsc'} = $nam;
  $slf->{'_dft'} = '';
  $slf->{'_dup'} = '';
  $slf->{'_err'} = '';
  $slf->{'_itm'} = '';
  $slf->{'_lvl'} = 0;
  $slf->{'_mnu'} = '';
  $slf->{'_nam'} = $nam;
  $slf->{'_opt'} = 0;
  $slf->{'_sep'} = ($^O eq 'MSWin32' || $^O eq 'MSWin64') ? ';' : ':';
  $slf->{'_typ'} = 'T';
  $slf->{'_var'} = [];
  $slf->{'_vis'} = 1;
  $slf->{'-nxt'} = [];
  $slf->{'-prv'} = [];

  # Return the object reference
  $slf;
}

=head2 S<$h-E<gt>get_detail>

This method returns the setting details. Only settings that have an inp, hlp,
or man property are considered. Otherwise, it returns an empty list.

=cut

sub get_detail
{ my $slf = shift;

  # Detect a relevant setting
  return () unless $slf->{'_typ'} ne 'C' &&
    (exists($slf->{'_inp'}) || exists($slf->{'_man'}) ||
     exists($slf->{'_hlp'}));

  # Provide the setting details
  ( $slf->{'_nam'},
    $slf->{'_lvl'},
    exists($slf->{'_inp'}) ? _get_detail($slf) : undef,
    exists($slf->{'_man'}) ? $slf->{'_man'} :
    exists($slf->{'_hlp'}) ? $slf->{'_hlp'} :
    undef
  );
}

sub _get_detail
{ my $slf = shift;
  my @tbl;

  if ($slf->{'_typ'} eq 'M')
  { my ($lgt, $max, $str, @key, %tbl);

    return undef unless exists($slf->{'_itm'});

    push(@tbl, $slf->{'_bef'}) if exists($slf->{'_bef'});
    _spl_menu(\%tbl, $slf->{'_itm'});
    $max = 0;
    foreach my $itm (sort keys(%tbl))
    { $max = $lgt if ($lgt = length($itm)) > $max;
    }
    if ($slf->{'_mnu'} =~ m/^<<n(umber)?$/i)
    { @key = sort {$a <=> $b} keys(%tbl);
    }
    else
    { @key = sort keys(%tbl);
    }
    foreach my $itm (@key)
    { $str = sprintf("  %-*s  ", $max, $itm);
      $str =~ s/\s/\\040/g;
      push(@tbl, $str.$tbl{$itm});
    }
    push(@tbl, $slf->{'_aft'}) if exists($slf->{'_aft'});
  }
  join("\n", @tbl, '"'.$slf->{'_inp'}.'"');
}

=head2 S<$h-E<gt>is_valid($family)>

This method indicates whether the setting is applicable for the specified
operating system family.

=cut

sub is_valid
{ my ($slf, $fam) = @_;

  # Accept it directly if there is no restriction
  return 1 unless exists($slf->{'_fam'});

  # Check if the family is included in the list
  for (@{$slf->{'_fam'}})
  { return 1 if $_ eq $fam;
  }

  # Otherwise, reject it
  0;
}

=head2 S<$h-E<gt>setup($module,$agent,$level,$list[,$trace[,$flag]])>

This method gets the setting value. When appropriate, it adds additional
settings to the input list. The setup is performed automatically when the
flag is set.

=cut

sub setup
{ my ($slf, $mod, $agt, $lvl, $lst, $trc, $flg) = @_;
  my ($ask, $inp, $nam, $typ, $val);

  # Get the default value
  $typ = $slf->{'_typ'};
  $ask = ($flg || $lvl < $slf->{'_lvl'})
    ? 0
    : (exists($slf->{'_inp'}) && exists($tb_get{$typ}));
  if (&{$tb_dft{$typ}}($slf, $agt, $agt->get_setting($slf->{'_def'}), $flg,
    $mod))
  { unshift(@$lst, @{$slf->{'_alt'}}) if exists($slf->{'_alt'});
    return undef;
  }

  # Ask the setting value
  if ($ask)
  { $slf->_dsp_text($agt, '_hlp', 2);
    &{$tb_dsp{$typ}}($slf, $agt) if exists($tb_dsp{$typ});
    $slf->_nxt_value([]);
    while ($ask)
    { $inp = $slf->{'_inp'};
      $inp =~ s/\$\{clr\}/$slf->{'_clr'}/g if $slf->{'_clr'};
      $inp =~ s/\$\{end\}/$slf->{'_end'}/g if exists($slf->{'_end'});
      $inp = _repl_var($agt, $inp, 1);
      $val = $slf->{'_vis'} ?
        $slf->_ask_setting($agt, $inp) :
        $slf->_ask_password($agt, $inp);
      if ($val eq '?')
      { $slf->_dsp_text($agt, '_hlp', 2);
        &{$tb_dsp{$typ}}($slf, $agt) if exists($tb_dsp{$typ});
      }
      else
      { ($val, $ask) = &{$tb_get{$typ}}($slf, $agt, $val, $lst);
      }
    }
  }
  else
  { $val = &{$tb_val{$typ}}($slf, $agt, $lst);
  }

  # Create or update the setting and return its effective name
  $nam = _repl_var($agt, $slf->{'_nam'});
  $nam =~ s/[^\-\w]/_/g;
  print "$trc $nam=".(defined($val) ? "'$val'" : 'undef')."\n" if $trc;
  if ($nam =~ s/^-//)
  { if (length($nam))
    { if (defined($val))
      { $agt->set_temp_setting($nam, $val);
      }
      else
      { $agt->clr_temp_setting($nam);
      }
    }
    return undef;
  }
  $agt->set_setting($nam, $val, $typ, _repl_var($agt, $slf->{'_dsc'}))
    if length($nam);
  $nam;
}

# Ask the user value
sub _ask_setting
{ my ($slf, $agt, $inp) = @_;
  my ($cur, $str);

  $str = $inp;
  if (length($cur = $slf->{'-cur'}))
  { $cur =~ s/\\/\\134/g;
    $str .= "\nHit 'Return' to accept the default ($cur)"
  }
  $slf->_dsp_string($agt, "$str\n>\\040", 0);
  $str = <STDIN>;
  print "\n";
  $str =~ s/[\s\r\n]+$//;
  ($str eq '')             ? $slf->{'-cur'} :
  ($str eq $slf->{'_clr'}) ? '' :
                             $str;
}

sub _ask_password
{ my ($slf, $agt, $inp) = @_;
  my $str;

  return '' unless defined($str = $agt->ask_password($inp, $slf->{'-cur'}));
  $str =~ s/[\s\r\n]+$//;
  $str;
}

# Do a boolean setting
sub _dft_boolean
{ my ($slf, $agt, $dft) = @_;

  unless (defined($dft))
  { $dft = _repl_var($agt, $slf->{'_dft'});
    return 1 if $slf->{'_opt'} && $dft eq '';
  }
  $slf->{'-prv'} = [$dft ? 'Y' : 'N'];
  0;
}

sub _get_boolean
{ my ($slf, $agt, $val, $lst) = @_;

  (_tst_boolean($slf, $val, $lst), 0);
}

sub _val_boolean
{ my ($slf, $agt, $lst) = @_;
 
  _tst_boolean($slf, $slf->{'-prv'}->[0], $lst);
}

sub _tst_boolean
{ my ($slf, $val, $lst) = @_;

  if ($val =~ m/\s*y(es)?/i)
  { unshift(@$lst, @{$slf->{'_var'}});
    return 1;
  }
  else
  { unshift(@$lst, @{$slf->{'_alt'}}) if exists($slf->{'_alt'});
    return 0;
  }
}

# Do a comment setting
sub _dft_comment
{ my ($slf, $agt, $dft, $flg) = @_;
  my $txt;

  unless ($flg)
  { # Resolve settings
    $dft = _repl_var($agt, $slf->{'_dft'}) unless defined($dft);

    # Display the comment
    if (exists($slf->{'_inp'}))
    { $txt = $slf->{'_inp'};
      $txt =~ s/\$\{dft\}/$dft/g;
      $slf->_dsp_string($agt, _repl_var($agt, $txt, 1), 1);
    }

    # When applicable, wait for the confirmation
    $dft = <STDIN> if $slf->{'_vis'};
  }

  # Refuse the default value
  1;
}

# Do a directory setting
sub _dft_dir
{ my ($slf, $agt, $dft) = @_;

  # When possible, use the current setting as default
  unless (defined($dft))
  { $dft = $slf->{'_dft'};
    if ($dft =~ $re_cfg)
    { $dft = _repl_cfg($agt, $1, $2, $3, $4);
    }
    elsif ($dft =~ $re_ext)
    { $dft = _repl_ext($agt, $1, $2, $3);
    }
    elsif ($dft =~ $re_lst)
    { $dft = _repl_lst($agt, $1, $2, $3, $4);
    }
    elsif ($dft =~ $re_src)
    { $dft = _repl_src($agt, $1, $2, $3, $4, '-d');
    }
    elsif ($dft =~ $re_xml)
    { $dft = _repl_xml($agt, $1, $2, $3, $4);
    }
    else
    { $dft =~ s/\//\001/g;
      $dft = $agt->clean_path(File::Spec->catdir(map
        {($_ eq '..') ? File::Spec->updir : $_}
        split(/\001/, _repl_var($agt, $dft))))
        if length($dft);
    }
    return 1 if $slf->{'_opt'} && $dft eq '';
  }

  # When requested, validate the directory
  return 1 if exists($slf->{'_alt'}) && defined($dft) && ! -d $dft;

  # Get the default list
  $slf->{'-prv'} = exists($slf->{'_end'})
    ? [split(/\Q$slf->{'_sep'}\E/, $dft)]
    : [$dft];
  0;
}

sub _get_dir
{ my ($slf, $agt, $val, $lst) = @_;
  my ($nxt);

  # Detect the end of a value list
  $nxt = exists($slf->{'_end'});
  return (join($slf->{'_sep'}, @{$slf->{'-nxt'}}), 0)
    if $nxt && $val eq $slf->{'_end'};

  # Reject an error
  if ($slf->_tst_file($agt, \$val, 'D'))
  { return ($val, $slf->{'-cnt'}) if $slf->_dsp_validation($agt, 1, '_err');
  }
  elsif ($slf->_chk_value($val))
  { return ($val, $slf->{'-cnt'}) if $slf->_dsp_validation($agt, 1, '_dup');
  }

  # Accept other value
  if ($nxt)
  { $slf->_nxt_value($val);
  }
  elsif (-d $val)
  { unshift(@$lst, @{$slf->{'_var'}});
  }
  ($val, $nxt);
}

sub _val_dir
{ my ($slf, $agt, $lst) = @_;

  if (exists($slf->{'_end'}))
  { foreach my $itm (@{$slf->{'-prv'}})
    { $slf->_dsp_validation($agt, 0, '_err')
        if $slf->_tst_file($agt, $itm, 'D');
      $slf->_dsp_validation($agt, 0, '_dup') if $slf->_chk_value($itm, 1);
    }
  }
  elsif ($slf->_tst_file($agt, $slf->{'-prv'}->[0], 'D'))
  { $slf->_dsp_validation($agt, 0, '_err');
  }
  else
  { unshift(@$lst, @{$slf->{'_var'}});
  }
  join($slf->{'_sep'}, @{$slf->{'-prv'}});
}

# Do an event setting
sub _dft_event
{ my ($slf, $agt, $dft, $flg, $mod) = @_;

  # Resolve settings and add the event to the module event stack
  $dft = _repl_var($agt, $slf->{'_dft'}) unless defined($dft);
  $mod->log($dft);

  # Refuse the default value
  1;
}

# Do a file setting
sub _dft_file
{ my ($slf, $agt, $dft) = @_;
  my @tbl;

  # When possible, use the current setting as default
  unless (defined($dft))
  { $dft = $slf->{'_dft'};
    if ($dft =~ $re_cfg)
    { $dft = _repl_cfg($agt, $1, $2, $3, $4);
    }
    elsif ($dft =~ $re_ext)
    { $dft = _repl_ext($agt, $1, $2, $3);
    }
    elsif ($dft =~ $re_lst)
    { $dft = _repl_lst($agt, $1, $2, $3, $4);
    }
    elsif ($dft =~ $re_src)
    { $dft = _repl_src($agt, $1, $2, $3, $4, '-f');
    }
    elsif ($dft =~ $re_xml)
    { $dft = _repl_xml($agt, $1, $2, $3, $4);
    }
    elsif ($dft)
    { $dft =~ s/\//\001/g;
      if (length($dft = _repl_var($agt, $dft)))
      { @tbl = map {($_ eq '..') ? File::Spec->updir : $_} split(/\001/, $dft);
        $tbl[0] = '/' if $tbl[0] eq '';
        $dft = $agt->clean_path(File::Spec->catfile(@tbl));
      }
    }
    return 1 if $slf->{'_opt'} && $dft eq '';
  }

  # When requested, validate the file
  return 1 if exists($slf->{'_alt'}) && defined($dft) && ! -f $dft;

  # Get the default list
  $slf->{'-prv'} = exists($slf->{'_end'})
    ? [split(/\Q$slf->{'_sep'}\E/, $dft)]
    : [$dft];
  0;
}

sub _get_file
{ my ($slf, $agt, $val, $lst) = @_;
  my ($nxt);

  # Detect the end of a value list
  $nxt = exists($slf->{'_end'});
  return (join($slf->{'_sep'}, @{$slf->{'-nxt'}}), 0)
    if $nxt && $val eq $slf->{'_end'};

  # Reject an error
  if ($slf->_tst_file($agt, \$val, 'F'))
  { return ($val, $slf->{'-cnt'}) if $slf->_dsp_validation($agt, 1, '_err');
  }
  elsif ($slf->_chk_value($val))
  { return ($val, $slf->{'-cnt'}) if $slf->_dsp_validation($agt, 1, '_dup');
  }

  # Accept other value
  if ($nxt)
  { $slf->_nxt_value($val);
  }
  elsif (-f $val)
  { unshift(@$lst, @{$slf->{'_var'}});
  }
  ($val, $nxt);
}

sub _val_file
{ my ($slf, $agt, $lst) = @_;

  if (exists($slf->{'_end'}))
  { foreach my $itm (@{$slf->{'-prv'}})
    { $slf->_dsp_validation($agt, 0, '_err')
        if $slf->_tst_file($agt, $itm, 'F');
      $slf->_dsp_validation($agt, 0, '_dup') if $slf->_chk_value($itm, 1);
    }
  }
  elsif ($slf->_tst_file($agt, $slf->{'-prv'}->[0], 'F'))
  { $slf->_dsp_validation($agt, 0, '_err');
  }
  else
  { unshift(@$lst, @{$slf->{'_var'}});
  }
  join($slf->{'_sep'}, @{$slf->{'-prv'}});
}

sub _tst_file
{ my ($slf, $agt, $val, $dft) = @_;
  my ($fil, $ref);

  # Resolve variables
  if (ref($val))
  { $fil = $val;
    unless ($agt->is_vms)
    { $$fil =~ s/\$\{(\w+)\}/_resolve($agt, $1)/eg;
      $$fil =~ s/\$(\w+)/_resolve($agt, $1)/eg;
    }
    $$fil =~ s/\%(\w+)\%/_resolve($agt, $1)/eg;
  }
  else
  { $fil = \$val;
  }

  # Test the directory/file
  $ref = exists($slf->{'_ref'}) ? uc(_repl_var($agt, $slf->{'_ref'})) : $dft;
  return 1
    unless index($ref, 'A') < 0 || File::Spec->file_name_is_absolute($$fil);
  return 1 unless index($ref, 'D') < 0 || -d $$fil;
  return 1 unless index($ref, 'E') < 0 || -e $$fil;
  return 1 unless index($ref, 'F') < 0 || -f $$fil;
  return 1 unless index($ref, 'R') < 0 || -r $$fil;
  return 1 unless index($ref, 'W') < 0 || -w $$fil;
  return 1 unless index($ref, 'X') < 0 || -x $$fil;
  0;
}

sub _resolve
{ my ($agt, $key) = @_;
  my $val;

  defined($val = $agt->get_setting($key)) ? $val :
  exists($ENV{$key}) ? $ENV{$key} :
  '';
}

# Treat a conditional setting
sub _val_if
{ my ($slf, $agt, $lst) = @_;
  my ($arg, $cmd, $ref, $val);

  # Eval the condition
  $val = 0;
  ($cmd, $ref, $arg) = split(/:/, _repl_var($agt, $slf->{'_dft'}), 3);
  if ($cmd && $ref)
  { $cmd = lc($cmd);
    $ref = $agt->get_setting($ref);
    if ($cmd eq 'decode')
    { if (defined($ref) && defined($arg))
      { my %tbl = split(/:/, $arg);
        if (exists($tbl{$ref}))
        { unshift(@$lst, split(/\s*,\s*/, $tbl{$ref}));
          $val = $ref;
        }
      }
    }
    elsif ($cmd eq 'eq')
    { $val = 1 if defined($ref) && defined($arg) && $ref eq $arg;
    }
    elsif ($cmd eq 'exists')
    { $val = 1 if defined($ref);
    }
    elsif ($cmd eq 'gt')
    { $val = 1 if defined($ref) && defined($arg) && $ref gt $arg;
    }
    elsif ($cmd eq 'hash')
    { if (defined($ref))
      { my ($cnt);
        $cnt = defined($arg) ? $arg : 0;
        $val = join('|', map {$cnt++ => $_} split(/\|/, $ref));
      }
    }
    elsif ($cmd eq 'lt')
    { $val = 1 if defined($ref) && defined($arg) && $ref lt $arg;
    }
    elsif ($cmd eq 'match')
    { $val = 1 if defined($ref) && defined($arg) && $ref =~ m#$arg#;
    }
    elsif ($cmd eq 'member')
    { if (defined($ref) && defined($arg))
      { my %tbl = map {$_ => 1} split(/,/, $arg);
        $val = 1 if exists($tbl{$ref});
      }
    }
    elsif ($cmd eq 'owner')
    { $val = 1
        if defined($ref) && defined($arg = (stat($ref))[4]) && $arg == $<;
    }
    elsif ($cmd eq 're')
    { if (defined($ref) && defined($arg))
      { my ($off, @tbl);
        $off = ($arg =~ s/^(\d+):// && $1) ? $1 - 1 : 0;
        @tbl = ($ref =~ m#$arg#);
        $val = $tbl[$off];
      }
    }
    elsif ($cmd eq 'start')
    { $val = 1 if defined($ref) && defined($arg) && index($ref, $arg) == 0;
    }
    elsif ($cmd eq 'values')
    { if (defined($ref))
      { my (%tbl);
        %tbl = split(/\|/, $ref);
        $val = $arg
          ? join('|', map {$tbl{$_}} sort {$a <=> $b} keys(%tbl))
          : join('|', map {$tbl{$_}} sort keys(%tbl));
      }
    }
  }

  # Adapt the setting list accordingly
  if ($val)
  { unshift(@$lst, @{$slf->{'_var'}});
  }
  elsif (exists($slf->{'_alt'}))
  { unshift(@$lst, @{$slf->{'_alt'}});
  }

  # Return the condition value
  $val;
}

# Treat a loop setting
sub _val_loop
{ my ($slf, $agt, $lst) = @_;
  my $val;

  # Initiate the loop operation
  if (exists($slf->{'-sav'}))
  { # Purge last loop iteration
    splice(@$lst);
  }
  else
  { # Enter in the loop
    $slf->{'-sav'} = [splice(@$lst)];
    $slf->{'-prv'} =
      [split(/\Q$slf->{'_sep'}\E/, _repl_var($agt, $slf->{'_dft'}))];
    $slf->{'_nam'} = '-'.$slf->{'_nam'} unless $slf->{'_nam'} =~ m/^-/;
  }

  # Get the next loop value
  while (defined($val = shift(@{$slf->{'-prv'}})))
  { last unless $val eq '' && $slf->{'_vis'};
  }

  # Determine what is the next action
  if (defined($val))
  { # Start an iteration
    push(@$lst, @{$slf->{'_var'}}, $slf->{'_def'});
  }
  else
  { # Restore the context and exit the look
    push(@$lst, @{$slf->{'_alt'}}) if exists($slf->{'_alt'});
    push(@$lst, @{$slf->{'-sav'}});
    delete($slf->{'-sav'});
  }

  # Return the loop value
  $val;
}

# Treat a menu setting
sub _dft_menu
{ my ($slf, $agt, $dft) = @_;
  my ($itm, $lgt, $val);

  # Parse the menu description
  $itm = $slf->{'_itm'};
  return 1 unless ($itm = ($itm =~ $re_lst)
    ? _repl_lst($agt, $1, $2, $3, $4)
    : _repl_var($agt, $itm));
  _spl_menu($slf->{'-itm'} = {}, $itm);
  $val = _repl_var($agt, $slf->{'_mnu'}) || '<<T';
  if ($val =~ m/^<<n(umber)?$/i)
  { $slf->{'-fmt'} = '  %*d  ';
    $slf->{'-mnu'} = [sort {$a <=> $b} keys(%{$slf->{'-itm'}})];
  }
  elsif ($val =~ m/^<<t(ext)?$/i)
  { $slf->{'-fmt'} = '  %-*s  ';
    $slf->{'-mnu'} = [sort keys(%{$slf->{'-itm'}})];
  }
  else
  { $slf->{'-fmt'} = '  %-*s  ';
    $slf->{'-mnu'} = [grep {exists($slf->{'-itm'}->{$_})} split(/\|/, $val)];
  }
  if (exists($slf->{'_rsp'}))
  { $val = $slf->{'_rsp'};
    _spl_menu($slf->{'-rsp'} = {}, _repl_var($agt, ($val eq '^')
      ? $itm
      : $slf->{'_rsp'}));
    $slf->{'-mnu'} = [grep {exists($$slf{'-rsp'}->{$_})} @{$slf->{'-mnu'}}];
  }
  else
  { $slf->{'-rsp'} = {map {$_ => $_} @{$slf->{'-mnu'}}};
  }
  return 1 unless scalar(@{$slf->{'-mnu'}});

  # Determine the selector size
  $val = 0;
  foreach my $itm (@{$slf->{'-mnu'}})
  { $val = $lgt if ($lgt = length($itm)) > $val;
  }
  return 1 unless ($slf->{'-lgt'} = $val);

  # When possible, use the current setting as default
  $dft = _repl_var($agt, $slf->{'_dft'}) unless defined($dft);
  if (exists($slf->{'_end'}))
  { $slf->{'-prv'} = [];
    foreach my $itm (split(/\Q$slf->{'_sep'}\E/, $dft))
    { push(@{$slf->{'-prv'}}, $val) if defined($val = _sel_menu($slf, $itm));
    }
  }
  elsif ($dft eq '^')
  { $slf->{'-prv'} = [$val] if defined($val = $slf->{'-mnu'}->[0]);
  }
  elsif (defined($val = _sel_menu($slf, $dft)))
  { $slf->{'-prv'} = [$val];
  }
  0;
}

sub _dsp_menu
{ my ($slf, $agt) = @_;
  my ($cnt, $col, $lgt, $max, $off, $row, $txt, @tbl);
 
  $cnt = $col = $max = 0;
  $slf->_dsp_text($agt, '_bef', 1);
  if ($slf->{'_col'})
  { foreach my $itm (@{$slf->{'-mnu'}})
    { push(@tbl, $txt = sprintf($slf->{'-fmt'}, $slf->{'-lgt'}, $itm)
        .$slf->{'-itm'}->{$itm});
      $max = $lgt if ($lgt = length($txt)) > $max;
      ++$cnt;
    }
    if ($max && ($col = int($agt->get_setting('RDA_COLUMNS') / $max)))
    { for (; $cnt % $col ; ++$cnt)
      { push(@tbl, '');
      }
      $lgt = $cnt / $col;
    }
  }
  if ($col)
  { for ($row = 0 ; $row < $lgt ; ++$row)
    { $txt = '';
      for ($off = $row ;  $off < $cnt ; $off += $lgt)
      { $txt .= sprintf('%-*s', $max, $tbl[$off]);
      }
      $txt =~ s/\s/\\040/g;
      $agt->dsp_string(*STDOUT, '', $txt)
    }
  }
  else
  { foreach my $itm (@{$slf->{'-mnu'}})
    { $agt->dsp_string(*STDOUT, sprintf($slf->{'-fmt'}, $slf->{'-lgt'}, $itm),
        $slf->{'-itm'}->{$itm}, 1);
    }
  }
  $slf->_dsp_text($agt, '_aft', 1);
}

sub _get_menu
{ my ($slf, $agt, $val, $lst) = @_;
  my ($flg, $nxt);

  # Detect the end of a value list
  $nxt = exists($slf->{'_end'});
  return (join($slf->{'_sep'}, @{$slf->{'-nxt'}}), 0)
    if $nxt && $val eq $slf->{'_end'};

  # Reject an error
  if ($slf->_tst_menu($agt, \$val))
  { return ($val, $slf->{'-cnt'}) if $slf->_dsp_validation($agt, 1, '_err');
  }
  elsif ($slf->_chk_value($val))
  { return ($val, $slf->{'-cnt'}) if $slf->_dsp_validation($agt, 1, '_dup');
  }

  # Accept other value
  if ($nxt)
  { return ($val, 0) if exists($slf->{'_one'}) && $val eq $slf->{'_one'};
    $slf->_nxt_value($val);
  }
  else
  { unshift(@$lst, @{$slf->{'_var'}});
  }
  ($val, $nxt);
}

sub _sel_menu
{ my ($slf, $itm) = @_;
  my $ret;

  foreach my $rsp (keys(%{$slf->{'-rsp'}}))
  { if ($itm eq $slf->{'-rsp'}->{$rsp})
    { return $rsp if $itm eq $rsp;
      $ret = $rsp;
    }
  }
  $ret;
}

sub _spl_menu
{ my ($tbl, $str) = @_;
  my ($key, $val, @tbl);

  @tbl = split(/\|/, $str);
  while (($key, $val) = splice(@tbl, 0, 2))
  { $tbl->{$key} = (defined($val) && length($val)) ? $val : $key
      if defined($key) && length($key);
  }
}

sub _tst_menu
{ my ($slf, $agt, $val) = @_;

  $$val =~ s/^\s+//;
  return 1 unless exists($slf->{'-rsp'}->{$$val});
  $$val = $slf->{'-rsp'}->{$$val};
  0;
}

sub _val_menu
{ my ($slf, $agt, $lst) = @_;

  if (exists($slf->{'_end'}))
  { foreach my $itm (@{$slf->{'-prv'}})
    { $slf->_dsp_validation($agt, 0, '_err')
        unless exists($slf->{'-rsp'}->{$itm});
      $slf->_dsp_validation($agt, 0, '_dup') if $slf->_chk_value($itm, 1);
    }
  }
  elsif (scalar(@{$slf->{'-prv'}})
    && exists($slf->{'-rsp'}->{$slf->{'-prv'}->[0]}))
  { unshift(@$lst, @{$slf->{'_var'}});
  }
  else
  { $slf->_dsp_validation($agt, 0, '_err');
  }
  join($slf->{'_sep'}, map {$slf->{'-rsp'}->{$_}} @{$slf->{'-prv'}});
}

# No default value
sub _dft_none
{ 0;
}

# Do a number setting
sub _get_number
{ my ($slf, $agt, $val) = @_;
  my ($flg, $nxt);

  # Detect the end of a value list
  $nxt = exists($slf->{'_end'});
  return (join($slf->{'_sep'}, @{$slf->{'-nxt'}}), 0)
    if $nxt && $val eq $slf->{'_end'};

  # Reject an error
  if ($slf->_tst_number($agt, \$val))
  { return ($val, $slf->{'-cnt'}) if $slf->_dsp_validation($agt, 1, '_err');
  }
  elsif ($slf->_chk_value($val))
  { return ($val, $slf->{'-cnt'}) if $slf->_dsp_validation($agt, 1, '_dup');
  }

  # Accept other value
  $slf->_nxt_value($val) if $nxt;
  ($val, $nxt);
}

sub _val_number
{ my ($slf, $agt) = @_;

  foreach my $itm (@{$slf->{'-prv'}})
  { $slf->_dsp_validation($agt, 0, '_err') if $slf->_tst_number($agt, \$itm);
    $slf->_dsp_validation($agt, 0, '_dup') if $slf->_chk_value($itm, 1);
  }
  join($slf->{'_sep'}, @{$slf->{'-prv'}});
}

sub _tst_number
{ my ($slf, $agt, $val) = @_;

  $$val =~ s/^\s+//;
  return 1 unless $$val =~ m/^([-+])?\d+(\.\d*)?([eE][\+\-]?\d+)?$/;
  $$val += 0;
  my $ref = exists($slf->{'_ref'}) ? _repl_var($agt, $slf->{'_ref'}) : '';
  return 0 unless $ref =~
    m/([IR])?([\[\]])([-+]?\d+(\.\d*)?)?\,([-+]?\d+(\.\d*)?)?([\[\]])/;
  my $typ = $1 || 'I';
  ((($typ eq 'I') ? $$val == int($$val) : 1) &&
    (defined($3) ? (($2 eq '[') ? ($$val >= $3) : ($$val > $3)) : 1) &&
    (defined($5) ? (($7 eq ']') ? ($$val <= $5) : ($$val < $5)) : 1)) ? 0 : 1;
}

# Treat a product setting
sub _dft_product
{ my ($slf, $agt, $dft) = @_;

  # Detect if the setting is already defined
  if (defined($dft))
  { $slf->{'-sav'} = $dft;
    return 0;
  }

  # Otherwise, check if auto discovery information are present
  ($slf->{'-sav'} = $agt->discover) ? 0 : 1;
}

sub _val_product
{ my ($slf, $agt, $lst) = @_;
  my ($cmd, $prd, $ref, $val);

  if (ref($slf->{'-sav'}))
  { ($cmd, $ref, $prd) = split(/:/, _repl_var($agt, $slf->{'_dft'}), 3);
    if ($cmd)
    { $cmd = lc($cmd);
      if ($cmd eq 'product')
      { $val = $slf->{'-sav'}->get_product($ref);
      }
      elsif ($ref && $prd)
      { if ($cmd eq 'check')
        { $val = $slf->{'-sav'}->check($ref, $prd);
        }
        elsif ($cmd eq 'find')
        { $val = $slf->{'-sav'}->find($ref, $prd);
        }
      }
      if (defined($val))
      { unshift(@$lst, @{$slf->{'_var'}});
        return $val;
      }
    }
  }
  else
  { unshift(@$lst, @{$slf->{'_var'}});
    return $slf->{'-sav'};
  }

  # Identify what to do when not found
  if (! $slf->{'_vis'})
  { unshift(@$lst, @{$slf->{'_var'}});
  }
  elsif (exists($slf->{'_alt'}))
  { unshift(@$lst, @{$slf->{'_alt'}});
  }
  ''
}

# Do a value setting
sub _dft_value
{ my ($slf, $agt, $dft) = @_;

  # When possible, use the current setting as default
  unless (defined($dft))
  { $dft = $slf->{'_dft'};
    $dft =
      ($dft =~ $re_cfg) ? _repl_cfg($agt, $1, $2, $3, $4) :
      ($dft =~ $re_ext) ? _repl_ext($agt, $1, $2, $3) :
      ($dft =~ $re_mod) ? _repl_mod($agt, $1, $2, $4) :
      ($dft =~ $re_lst) ? _repl_lst($agt, $1, $2, $3, $4) :
      ($dft =~ $re_src) ? _repl_src($agt, $1, $2, $3, $4, '-e') :
      ($dft =~ $re_xml) ? _repl_xml($agt, $1, $2, $3, $4) :
      _repl_var($agt, $dft);
    return 1 if $slf->{'_opt'} && $dft eq '';
  }

  # Get the default list
  $slf->{'-prv'} = exists($slf->{'_end'})
    ? [split(/\Q$slf->{'_sep'}\E/, $dft)]
    : [$dft];
  0;
}

sub _get_value
{ my ($slf, $agt, $val) = @_;
  my ($nxt);

  # Detect the end of a value list
  $nxt = exists($slf->{'_end'});
  return (join($slf->{'_sep'}, @{$slf->{'-nxt'}}), 0)
    if $nxt && $val eq $slf->{'_end'};

  # Reject an error
  if ($slf->_tst_value($val))
  { return ($val, $slf->{'-cnt'}) if $slf->_dsp_validation($agt, 1, '_err');
  }
  elsif ($slf->_chk_value($val))
  { return ($val, $slf->{'-cnt'}) if $slf->_dsp_validation($agt, 1, '_dup');
  }

  # Accept other value
  $slf->_nxt_value($val) if $nxt;
  ($val, $nxt);
}

sub _val_value
{ my ($slf, $agt) = @_;

  foreach my $itm (@{$slf->{'-prv'}})
  { $slf->_dsp_validation($agt, 0, '_err') if $slf->_tst_value($itm);
    $slf->_dsp_validation($agt, 0, '_dup') if $slf->_chk_value($itm, 1);
  }
  join($slf->{'_sep'}, @{$slf->{'-prv'}});
}

sub _tst_value
{ my ($slf, $val) = @_;

  exists($slf->{'_ref'}) && $val !~ $slf->{'_ref'};
}

# Compare the value with the previous values
sub _chk_value
{ my ($slf, $val, $flg) = @_;
  my $key;

  if (exists($slf->{'_end'}) && $slf->{'_dup'})
  { foreach my $prv (@{$slf->{$flg ? '-prv' : '-nxt'}})
    { if ($val eq $prv)
      { return 1 unless $flg;
        $flg = 0;
      }
    }
  }
  0;
}

# Display a string
sub _dsp_string
{ my ($slf, $agt, $str, $nxt) = @_;

  $agt->dsp_string(*STDOUT, '', $str, $nxt);
}

# Display a text
sub _dsp_text
{ my ($slf, $agt, $key, $nxt) = @_;

  $agt->dsp_string(*STDOUT, '', _repl_var($agt, $slf->{$key}), $nxt)
    if exists($slf->{$key});
}

# Report setting validation error
sub _dsp_validation
{ my ($slf, $agt, $flg, $msg) = @_;
  my ($key, $ret);

  if (exists($slf->{'_val'}))
  { if ($flg)
    { $ret = $slf->{'_val'} ne 'W';
      $slf->_dsp_text($agt, $msg, 1);
      unless ($ret)
      { $slf->_dsp_string($agt, "Do you want to specify a new value (Y/N)?", 0);
        $key = <STDIN>;
        $ret = ($key =~ m/\s*y(es)?/i) ? 1 : 0;
      }
      print "\n";
    }
    elsif ($slf->{'_val'} eq 'F')
    { $slf->_dsp_text($agt, $msg, 1);
      die "RDA-00118: Invalid value for setting '".$slf->{'_nam'}."'\n";
    }
    --$slf->{'-cnt'} if defined($slf->{'-cnt'}) && $slf->{'-cnt'} > 0;
  }
  $ret;
}

# Switch to the next value
sub _nxt_value
{ my ($slf, $val) = @_;

  if (ref($val))
  { $slf->{'-nxt'} = $val;
  }
  else
  { push(@{$slf->{'-nxt'}}, $val);
  }
  $slf->{'-cnt'} = (exists($slf->{'_val'}) && $slf->{'_val'} =~ m/^E(\d+)$/
    && !exists($slf->{'_end'})) ? $1 + 1 : -1;
  $slf->{'-cur'} = (defined($val = shift(@{$slf->{'-prv'}})) &&
    $val ne $slf->{'_clr'}) ? $val : '';
}

# Extract the setting from a configuration file
sub _repl_cfg
{ my ($agt, $cfg, $fil, $pos, $re) = @_;
  my $str;

  # Generate the regular expression
  $re = _repl_var($agt, $re);
  $re = ($cfg eq 'CONFIG') ? qr/$re/ : qr/$re/i;

  # Scan the file
  $fil = $agt->get_setting($fil);
  if ($fil && open(CFG, "<$fil"))
  { while (<CFG>)
    { s/[\r\n]+//;
      if ($_ =~ $re)
      { $str = eval "\$$pos";
        last;
      }
    }
    close(CFG);
  }

  # Return the value or an empty string
  defined($str) ? $str : '';
}


# Get the setting from an external module
sub _repl_ext
{ my ($agt, $pkg, $fct, $arg) = @_;
  my ($cmd, $str, @arg);

  # Execute the external code
  if ($pkg && $fct)
  { $pkg =~ s#\/#::#g;
    if ($arg)
    { foreach my $itm (split('\s*,\s*', $arg))
      { $itm = _repl_var($agt, $itm);
        $itm =~ s/'//g;
        $itm =~ s/\\+$//;
        push(@arg, $itm);
      }
    }
    $cmd = scalar(@arg)
      ? "$pkg\:\:$fct(\$agt, '".join("', '", @arg)."')"
      : "$pkg\:\:$fct(\$agt)";
    eval "require $pkg";
    $str = eval $cmd unless $@;
  }
  
  # Return the value or an empty string
  defined($str) ? $str : '';
}

# Search modules
sub _repl_mod
{ my ($agt, $sep, $re1, $re2) = @_;
  my ($flg, %tbl);

  # Scan the directory
  $flg = $agt->get_setting('RDA_CASE');
  if (opendir(DIR, $agt->get_setting('MOD_DIRECTORY')))
  { $re1 = $re1 ? qr#$re1#i : qr#.#;
    $re2 = qr#$re2#i if $re2;
    foreach my $nam (readdir(DIR))
    { $nam = uc($nam) unless $flg;
      next unless $nam =~ s/\.(ctl|def)$//i && $nam =~ $re1;
      next if $re2 && $nam =~ $re2;
      $tbl{$nam} = 1;
    }
    closedir(DIR);
  }

  # Return the modules found
  join($sep, sort keys(%tbl));
}

# List files
sub _repl_lst
{ my ($agt, $src, $dir, $pos, $re) = @_;
  my ($buf, $cnt, $flg, @tbl, %tbl);

  # Decode the options
  $re = _repl_var($agt, $re);
  $re = ($src eq 'LIST') ? qr#$re# : qr#$re#i;
  ($flg, $pos) = (1, -$pos) if $pos < 0;

  # Scan the directory
  $dir = $agt->get_setting($dir);
  if ($dir && opendir(DIR, $dir))
  { foreach my $nam (readdir(DIR))
    { $tbl{eval "\$$pos"} = 1 if $nam =~ $re;
    }
    closedir(DIR);
  }

  # Return the list
  if ($flg)
  { @tbl = sort {$a <=> $b} keys(%tbl);
  }
  else
  { @tbl = sort keys(%tbl);
  }
  $buf = '';
  $cnt = 0;
  foreach my $itm (@tbl)
  { $buf .= '|' if $cnt++;
    $buf .= "$cnt|$itm";
  }
  $buf;
}

# Search a file
sub _repl_src
{ my ($agt, $src, $dir, $opt, $re, $flt) = @_;
  my ($flg, $str, @tbl, %mod);

  # Decode the options
  $re = _repl_var($agt, $re);
  $re = eval "(\$src eq 'SEARCH') ? qr#$re# : qr#$re#i";
  $flg = index($opt, 'r') >= 0;
  $flt = '-e' if index($opt, 'w') >= 0;

  # Scan the directory
  $dir = $agt->get_setting($dir);
  _grep_dir(\@tbl, $dir, $re, 8, $flt, $flg) if $dir && opendir(DIR, $dir);

  # Indicate that no match has been found
  return '' unless scalar(@tbl);

  # Sort the file names
  if (index($opt, 'd') >= 0)
  { @tbl = sort {dirname($a)  cmp dirname($b) ||
                 basename($a) cmp basename($b)} @tbl;
  }
  elsif (index($opt, 'n') >= 0)
  { @tbl = sort {$a cmp $b} @tbl;
  }
  elsif (index($opt, 't') >= 0)
  { foreach my $nam (@tbl)
    { $mod{$nam} = (stat($nam))[9] || 0;
    }
    @tbl = sort {$mod{$b} <=> $mod{$a} || $a cmp $b} keys(%mod);
  }

  # Return the first match
  (index($opt, 'b') >= 0) ? basename($tbl[0]) :
  (index($opt, 'w') >= 0) ? dirname($tbl[0]) :
  $tbl[0];
}

sub _grep_dir
{ my ($tbl, $dir, $re, $lvl, $flt, $flg) = @_;
  my ($pth, @sub);

  # Read the directory content
  foreach my $nam (readdir(DIR))
  { $pth = File::Spec->catfile($dir, $nam);
    push(@$tbl, $pth) if $nam =~ $re && eval "$flt '$pth'";
    push(@sub, $pth) if $flg && -d $pth && -r $pth && $nam !~ m/^\.+$/;
  }
  closedir(DIR);

  # Explore sub directories
  if (--$lvl > 0)
  { foreach my $sub (@sub)
    { _grep_dir($tbl, $sub, $re, $lvl, $flt, $flg) if opendir(DIR, $sub);
    }
  }
}

# Replace settings in string
sub _repl_var
{ my ($agt, $str, $flg) = @_;
  my ($val, $var);

  # Replace special characters
  if ($flg)
  { $str =~ s/\\n/\n/g;
    $str =~ s/&\#10;/\n/g;
    $str =~ s/&\#34;/"/g;
    $str =~ s/&\#39;/'/g;
  }

  # Replace variables
  while ($str =~ m/(\$\{(ENV\.)?(\w+)(\:([^\{\}]*))?\})/)
  { $var = $1;
    $val = defined($5) ? $5 : '';
    $val = $2
      ? (defined($ENV{$3}) ? $ENV{$3} : $val)
      : $agt->get_setting($3, $val);
    $str =~ s/\Q$var\E/$val/g;
  }

  # Treat commands
  local $SIG{'__WARN__'} = sub {};
  $str =~ s/`(.*?)`/eval {
      $val = $1;
      if ($val && $^O eq 'VMS' && $val =~ m#[\<\>]# && $val !~ m#^PIPE #i)
      { $val = "PIPE $val";
        $val =~ s#2>&1#2>SYS\$OUTPUT#g;
      }
      $val = `$val`;
      $val =~ s#[\n\r]$##;
    };
    ($@ || $?) ? undef : $val;/eg;

  # Return the result
  $str;
}

# Extract the setting from an XML file
sub _repl_xml
{ my ($agt, $cfg, $fil, $key, $qry) = @_;
  my $obj;

  # Get the parsed XML and perform the query
  unless (defined($obj = $agt->get_setting("OBJ-$fil")))
  { $obj = RDA::Object::Xml->new($agt->get_setting('XML_TRACE',
      0))->parse_file($agt->get_setting($fil));
    $agt->set_temp_setting("OBJ-$fil", $obj);
  }
  ($obj) = $obj->find(_repl_var($agt, $qry));

  # Return the requested value
  (!$obj) ? '' :
  (!$key) ? $obj->data :
  exists($obj->{$key}) ? $obj->{$key} :
  '';
}

1;

__END__

=head1 SEE ALSO

L<RDA::Agent|RDA::Agent>, L<RDA::Block|RDA::Block>,
L<RDA::Daemon|RDA::Daemon>, L<RDA::Discover|RDA::Discover>,
L<RDA::Extra|RDA::Extra>, L<RDA::Filter|RDA::Filter>,
L<RDA::Lock|RDA::Lock>, L<RDA::Log|RDA::Log>,
L<RDA::Module|RDA::Module>, L<RDA::Output|RDA::Output>,
L<RDA::Pod|RDA::Pod>, L<RDA::Profile|RDA::Profile>,
L<RDA::Remote|RDA::Remote>, L<RDA::Render|RDA::Render>,
L<RDA::Upgrade|RDA::Upgrade>, L<RDA::Value|RDA::Value>,
L<RDA::Web|RDA::Web>

=head1 COPYRIGHT NOTICE

Copyright (c) 2002-2009, Oracle. All rights reserved.

=head1 TRADEMARK NOTICE

Oracle, JD Edwards, PeopleSoft, and Siebel are registered trademarks of Oracle
Corporation and/or its affiliates. Other names may be trademarks of their
respective owners.

=cut