# DIAGLET.pm: Diaglet Command Library

package RDA::Request::DIAGLET;

# $Id: DIAGLET.pm,v 1.24 2015/08/30 23:46:09 RDA Exp $
# ARCS: $Header: /home/cvs/cvs/RDA_8/src/scripting/lib/RDA/Request/DIAGLET.pm,v 1.24 2015/08/30 23:46:09 RDA Exp $
#
# Change History
# 20150830  MSC  Add the save type in sdp_attribute.

=head1 NAME

RDA::Request::DIAGLET - Diaglet Command Library

=head1 SYNOPSIS

 require RDA::Request::DIAGLET;

=head1 DESCRIPTION

The objects of the C<RDA::Request::DIAGLET> class are used to manage diaglets.

The following methods are available:

=cut

use strict;

BEGIN
{ use Exporter;
  use IO::File;
  use RDA::Text qw(get_string);
  use RDA::Handle::Data;
  use RDA::Object;
  use RDA::Object::Content qw($CHK_DSC $CHK_FAM $CHK_OLD $CHK_PLT $CHK_PRD
                              $CHK_SET $CHK_TGT $CHK_TYP $CHK_UID
                              $RE_GRP $RE_SET);
  use RDA::Object::Env;
  use RDA::Object::Hcve;
  use RDA::Object::Message;
  use RDA::Object::Rda;
  use RDA::Object::Xml;
}

# Define the global public variables
use vars qw($STRINGS $VERSION @ISA);
$VERSION = sprintf('%d.%02d', q$Revision: 1.24 $ =~ /(\d+)\.(\d+)/);
@ISA     = qw(Exporter);

# Define the global private constants
my $MAN = q{TOOL:HCVEman};
my $MET = q{TOOL:HCCEmeta};

my $HCCE = q{HCCE};
my $HCVE = q{HCVE};
my $NONE = q{};

# Define the global private variables
my $re_min = qr/^(V?[BO].*|IS|V[\-\+=!<>]|[=!][=~]|[<>]=?)$/i;
my $re_max = qr/^(V?[BO])/i;
my $re_tst = qr/^(V?[BO].*|IS|N.*|V[\-\+=!<>]|[=!][=~]|[<>]=?)$/i;
my %tb_att = map {$_ => 0} qw(list value);
my %tb_abr = (
  $HCCE => q{_HCCE_},
  $HCVE => q{_HCVE_},
  $NONE => $NONE,
  );
my %tb_cmd = (
  'DIAGLET.CHECK'    => \&_do_check,
  'DIAGLET.DESCRIBE' => \&_do_describe,
  'DIAGLET.EXAMINE'  => \&_do_examine,
  'DIAGLET.INFO'     => \&_do_info,
  'DIAGLET.LIST'     => \&_do_list,
  'DIAGLET.MAN'      => \&_do_man,
  'DIAGLET.META'     => \&_do_meta,
  'DIAGLET.RUN'      => \&_do_run,
  'DIAGLET.VERSION'  => \&_do_version,
  );
my %tb_dsc = (
  fam => 'family',
  ini => 'init',
  old => 'old',
  plt => 'platform',
  prd => 'product',
  set => 'set',
  tgt => 'target',
  ttl => 'title',
  typ => 'type',
  );
my %tb_fct = map {$_ => 0} qw(OS PERL RDA SDCL SDSL SQL);
my %tb_mod = map {$_ => 0} qw(ATTACH LOG RECORD SECTION VERIFY VERIFY_ABORT);
my %tb_pkg = (
  $HCCE => q{TOOL:HCCEexec},
  $HCVE => q{TOOL:HCVEexec},
  );
my %tb_res = map {$_ => 0} qw(FAILED PASSED SKIPPED WARNING);
my %tb_run = (
  sdp_ask  => \&_run_ask,
  sdp_exec => \&_run_exec,
  );
my %tb_syn = map {$_ => 0} qw(text wiki);
my %tb_tst = (
  $HCCE => q{TOOL:TLcomply},
  $HCVE => q{TOOL:TLhcve},
  );
my %tb_typ = map {$_ => 0} qw(ATTACH GROUP LOOP OS PERL PROMPT RDA SDCL SDSL
                              SQL);

# Report the package version
sub Version
{ return $VERSION;
}

=head2 S<$h = RDA::Request::DIAGLET-E<gt>new($agt)>

The object constructor. This method enables you to specify the agent reference
as an argument.

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

=over 10

=item S<  B<'_agt'> > Reference to the agent object

=item S<  B<'_cfg'> > Reference to the RDA software configuration

=item S<  B<'_cnt'> > Reference to the RDA content control object

=item S<  B<'_env'> > Environment copy

=item S<  B<'_vrb'> > Verbose indicator

=back

Internal keys are prefixed by an underscore.

=cut

sub new
{ my ($cls, $agt) = @_;

  # Create the library object and return its reference
  return bless {
    _agt => $agt,
    _env => $agt->get_env,
    _cfg => $agt->get_config,
    _cnt => $agt->get_content,
    _vrb => $agt->is_verbose
    }, ref($cls) || $cls;
}

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

This method deletes the library object.

=cut

sub delete_object
{ RDA::Object::dump_caller($_[0], 'Commands') if $RDA::Object::DELETE;
  undef %{$_[0]};
  undef $_[0];
  return;
}

=head2 S<$h-E<gt>exec_command($req)>

This method executes the command specified in the message.

=cut

sub exec_command
{ my ($slf, $req) = @_;

  my $cmd = $req->{'msg'};
  return exists($tb_cmd{$cmd})
    ? &{$tb_cmd{$cmd}}($slf, $req)
    : $req->error('NotImplemented', get_string('BAD_COMMAND', $cmd));
}

=head1 DIAGLET COMMANDS

=head2 DIAGLET.CHECK - Diaglet check command

This command checks the diaglet content and reports problems found. It supports
the following attributes:

=over 13

=item B<  diaglet>

Specifies the name or the path of the diaglet file.

=item B<  directory>

Specifies an alternative diaglet directory (C<hcve> by default).

=item B<  groups>

When present, restricts the rule set search to the specified groups.

=item B<  warnings>

When true, includes warnings (false by default).

=back

=cut

sub _do_check
{ my ($slf, $req) = @_;
  my ($cnt, $err, $top, $typ, $xml);

  # Check the diaglet
  eval {
    (undef, $top, $xml) = _load($slf, $NONE, $req);
    if (defined($xml))
    { # Check the diaglet
      $cnt = 0;
      $err = RDA::Object::Hcve::new_check(
        $slf->{'_agt'}->get_lang('SDCL'),
        $slf->{'_agt'}->get_lang('SDSL'));
      $req->add_error(get_string('NO_SEQUENCE'))
        unless $xml->get_value('sequence', q{}) =~ m/^\d{3}$/;
      $req->add_error(get_string('NO_SET'))
        unless length($xml->get_value('set', q{}));
      $req->add_error(get_string('NO_TITLE'))
        unless length($xml->get_value('title', q{}));
      $req->add_error(get_string('NO_TYPE'))
        unless length($xml->get_value('type', q{}));
      foreach my $itm ($xml->find('sdp_content'))
      { ++$cnt;
        $typ = $itm->get_value('type', q{});
        if ($typ eq 'check')
        { _chk_rule_set($req, $err, $itm, $cnt);
        }
        elsif ($typ eq 'eval')
        { _chk_eval($req, $itm, $cnt);
        }
        else
        { $req->add_error(get_string('BAD_CONTENT', $cnt));
        }
      }
      $req->add_error(get_string('NO_CONTENT')) unless $cnt;
    }
    else
    { ($xml) = $top->find('sdp_top');
      die get_string('NO_DIAGLET') unless defined($xml);

      # Check a group description
      $req->add_error(get_string('NO_GROUP_NAME'))
        unless $xml->get_value('group', q{}) =~ $RE_GRP;
      $req->add_error(get_string('NO_GROUP_SEQ'))
        unless $xml->get_value('sequence', q{}) =~ m/^\d+$/;
    }
    };
  $req->add_error($@) if $@;

  # Provide the response
  return $req->has_errors
    ? $req->add_error($req->purge_errors,
        get_string('ERR_CHECK'))->error('Error')
    : $req->new('OK.Check')->add_data($slf->{'_vrb'}
        ? [get_string('NoIssues')]
        : undef);
}

=head2 DIAGLET.DESCRIBE - Describe command

This command provides the offset definition of the record returned by the
C<DIAGLET.INFO> commands.

=cut

sub _do_describe
{ my ($slf, $req) = @_;

  return $req->new('OK.Describe', offsets=>[$slf->{'_cnt'}->get_offsets])
}

=head2 DIAGLET.EXAMINE - Run examine command

This command examines the target compliance using a diaglet. It supports the
following attributes:

=over 13

=item B<  collector>

Specifies the collector used for the rule set report generation.

=item B<  diaglet>

Specifies the name or the path of the diaglet file.

=item B<  directory>

Specifies an alternative diaglet directory (C<hcve> by default).

=item B<  force>

When true, ignores the execution constraints (false by default).

=item B<  groups>

When present, restricts the rule set search to the specified groups.

=item B<  keep>

When true, keeps in memory the package used for executing rule sets (false by
default).

=item B<  target>

When present, restricts the examination to the specified target type.

=back

=cut

sub _do_examine
{ my ($slf, $req) = @_;
  my ($abr, $cfg, $det, $glb, $rsp, $str, $tgt, $val, $xml, %rsp);

  $rsp{'exit'} = 0;
  eval {
    # Initialization
    $cfg = $slf->{'_cfg'};

    # Parse the XML
    ($abr, undef, $xml) = _load($slf, $HCCE, $req);
    die get_string('NO_DIAGLET') unless defined($xml);

    # Apply the restrictions
    $glb = _get_desc($xml,{abr => $abr, set => 'NoName'});
    die get_string('NO_TARGET')
      unless exists($glb->{'tgt'});
    die get_string('BAD_TARGET', $glb->{'tgt'})
      if defined($val = $req->get_first('target')) && $glb->{'tgt'} ne $val;
    unless ($req->get_first('force'))
    { # Apply the plaform restrictions
      if (exists($glb->{'plt'}))
      { die get_string('BAD_PLATFORM', $glb->{'plt'})
          unless _tst_member($glb->{'plt'}, $cfg->get_os);
      }
      elsif (exists($glb->{'fam'}))
      { die get_string('BAD_FAMILY', $glb->{'fam'})
          unless _tst_member($glb->{'fam'}, $cfg->get_family);
      }

      # Apply the target restrictions
      ($tgt) = $xml->find('sdp_meta type="target"');
      if ($tgt)
      { if ($val = $tgt->get_value('host'))
        { $str = $cfg->get_host;
          die get_string('BAD_HOST', $str) unless _tst_member($val, $str);
        }
        elsif ($val = $tgt->get_value('domain'))
        { $str = $cfg->get_domain;
          die get_string('BAD_DOMAIN', $str) unless _tst_member($val, $str);
        }
      }
    }

    # Treat the diaglet content
    $glb->{'cls'} = $glb->{'typ'} || 'U';
    foreach my $job ($xml->find('sdp_content'))
    { ++$glb->{'cnt'};
      $det = _get_desc($job, $glb);
      if ($det->{'typ'} eq 'check' || $det->{'typ'} eq 'comply')
      { $rsp = _run_rules($slf, $HCCE, $req, $det, $abr);
        if (ref($rsp) eq 'RDA::Object::Message')
        { push(@{$rsp{'errors'}},  $rsp->get_value('errors'));
          push(@{$rsp{'results'}}, $rsp->get_value('results'));
          $rsp{'exit'} |= $rsp->get_first('exit');  ## no critic (Bit)
        }
      }
    }
    };

  # Indicate the completion status
  return $req->reply($@, 'Run', %rsp);
}

=head2 DIAGLET.INFO - Get diaglet information module command

This command returns the diaglet information. It supports the following
attributes:

=over 13

=item B<  diaglet>

Specifies the name or the path of the diaglet file.

=item B<  directory>

Specifies an alternative diaglet directory (C<hcve> by default).

=back

=cut

sub _do_info
{ my ($slf, $req) = @_;
  my ($dir, $pth, $rec);

  # Validate the parameters
  return $req->error('NoDiaglet')
    unless ($pth = $req->get_first('diaglet'));

  # Analyze the file
  if ($pth =~ $RE_SET)
  { $rec = $slf->{'_cnt'}->get_details($pth);
  }
  else
  { $pth =~ s/\.xml$//i;
    $rec = $slf->{'_cnt'}->get_details(
      $slf->{'_cfg'}->is_absolute($pth)
        ? "$pth.xml" :
      ($dir = $req->get_first('directory'))
        ? $slf->{'_cfg'}->cat_file($dir, "$pth.xml") :
      $slf->{'_cfg'}->get_file('D_RDA_CHK', $pth, '.xml'));
  }

  # Analyze the file and return the results
  return $rec->[0]
    ? $req->new('OK.Info', info=>$rec)
    : $req->error('NotDiaglet');
}

=head2 DIAGLET.LIST - Diaglet list command

This command lists the existing diaglets applicable to the current context. It
supports the following attributes:

=over 15

=item B<  all>

When true, lists all diaglets (false by default).

=item B<  compliance>

When true, restricts the search to compliance-related rule sets.

=item B<  description>

When true, includes the description as data.

=item B<  directory>

Specifies an alternative diaglet directory (C<hcve> by default).

=item B<  groups>

When present, restricts the rule set search to the specified groups.

=item B<  products>

Specifies the list of products to consider (all by default).

=item B<  target>

When present, restricts the examination to the specified target type.

=item B<  types>

Specifies the list of types to consider (all by default).

=item B<  uid>

When true, reports the unique identifier instead of the set name.

=back

=cut

sub _do_list  ## no critic (Complex)
{ my ($slf, $req) = @_;
  my ($all, $buf, $cfg, $cnt, $dir, $dsc, $fam, $flg, $oem, $osn, $prd, $tgt,
      $typ, @tbl, %prd, %typ);

  $cfg = $slf->{'_cfg'};
  $cnt = $slf->{'_cnt'};

  # Validate the parameters
  $buf = q{} if ($dsc = $req->get_first('description'));
  $oem = ($tgt = $req->get_first('target'))
    ? 1
    : $req->get_first('compliance');
  unless ($all = $req->get_first('all'))
  { $fam = $cfg->get_family;
    $osn = $cfg->get_os;
    %prd = map {$_ => 0} $req->get_value('products')
      if ($prd = $req->is_defined('products'));
    %typ = map {$_ => 0} $req->get_value('types')
      if ($typ = $req->is_defined('types'));
  }

  # Analyze the directory
  if (defined($dir = $req->get_first('directory')))
  { if (opendir(DLD, $dir))
    { my ($off, $rec);

      $off = $req->get_first('uid') ? $CHK_UID : $CHK_SET;
      foreach my $fil (sort readdir(DLD))
      { next unless $fil =~ m/\.xml$/i  ## no critic (Unless)
          && $fil ne 'group.xml'
          && ($rec = $cnt->get_details($cfg->cat_file($dir, $fil)));
        unless ($all)
        { if ($rec->[$CHK_PLT])
          { next unless _tst_member($rec->[$CHK_PLT], $osn);
          }
          elsif ($rec->[$CHK_FAM])
          { next unless _tst_member($rec->[$CHK_FAM], $fam);
          }
          next if $prd && !exists($prd{$rec->[$CHK_PRD]});
          next if $typ && !exists($typ{$rec->[$CHK_TYP]});
          next if $rec->[$CHK_OLD];
        }
        if ($oem)
        { next unless defined($rec->[$CHK_TGT]);
          next if $tgt && $rec->[$CHK_TGT] ne $tgt;
        }
        push(@tbl, $rec->[$off]);
        $buf .= $rec->[$off].q{|}.$rec->[$CHK_DSC].qq{\n} if $dsc;
      }
      closedir(DLD);
    }
  }
  else
  { my ($off, $rec, $tbl, $uid);

    $off = $req->get_first('uid') ? 1 : 2;
    $tbl = $cnt->get_sets(q{*}, [$req->get_value('groups')], $all, 'seq',
      'uid', 'abr', 'dsc', 'prd', 'typ', 'old', 'tgt');
    foreach my $key (sort {$tbl->{$a}->[0] <=> $tbl->{$b}->[0] ||
                           $tbl->{$a}->[$off] cmp $tbl->{$b}->[$off]}
                          keys(%{$tbl}))
    { $rec = $tbl->{$key};
      unless ($all)
      { next if $prd && !exists($prd{$rec->[4]});
        next if $typ && !exists($typ{$rec->[5]});
        next if $rec->[6];
      }
      if ($oem)
      { next unless defined($rec->[7]);
        next if $tgt && $rec->[7] ne $tgt;
      }
      push(@tbl, $rec->[$off]);
      $buf .= q{!!hcve:}.$rec->[1].q{!}.$rec->[$off].q{!!|}.$rec->[3].qq{\n}
        if $dsc;
    }
  }

  # Return the completion status
  return $req->new('OK.List', sets => [@tbl])->add_data($buf)
}

=head2 DIAGLET.MAN - Diaglet manual generation command

This command generates a report containing the diaglet documentation. It
supports the following attributes:

=over 13

=item B<  collector>

Specifies the collector used for the report generation.

=item B<  diaglet>

Specifies the name or the path of the diaglet file.

=item B<  directory>

Specifies an alternative diaglet directory (C<hcve> by default).

=item B<  groups>

When present, restricts the rule set search to the specified groups.

=item B<  keep>

When true, keeps in memory the package used for generating the documentation
(false by default).

=back

=cut

sub _do_man
{ my ($slf, $req) = @_;
  my ($abr, $lng, $obj, $oid, $rsp, $xml);

  # Parse the diaglet and generate the documentation report
  eval {
    # Find the diaglet
    ($abr, undef, $xml) = _load($slf, $HCVE, $req);
    die get_string('NO_DIAGLET') unless defined($xml);

    # Load the package to generate the documentation
    $lng = $slf->{'_agt'}->get_lang('SDCL');
    $obj = $lng->load_package($MAN) or die get_string('NO_PACKAGE', $MAN);
    $oid = $obj->set_info('oid', $tb_tst{$HCVE});

    # Execute the code
    $obj->exec(get_string('ERR_RUN'), [$req, $xml, $abr], 'Man');
    $rsp = $obj->get_info('val');
    $obj->set_info('oid', $oid);

    # Keep the documentation package when requested
    if ($req->get_first('keep'))
    { $lng->keep_package($obj);
    }
    else
    { $lng->remove_package($obj);
    }
    };
  $req->add_error($@) if $@;

  # Indicate the completion status
  return ref($rsp) eq 'RDA::Object::Message'
    ? $rsp
    : $req->error('Man',{exit=>2});
}

=head2 DIAGLET.META - Diaglet compliance metadata generation command

This command generates a report containing the diaglet compliance metadata. It
supports the following attributes:

=over 13

=item B<  collector>

Specifies the collector used for the report generation.

=item B<  diaglet>

Specifies the name or the path of the diaglet file.

=item B<  directory>

Specifies an alternative diaglet directory (C<hcve> by default).

=item B<  groups>

When present, restricts the rule set search to the specified groups.

=item B<  keep>

When true, keeps in memory the package used for generating the documentation
(false by default).

=item B<  target>

When present, restricts the examination to the specified target type.

=back

=cut

sub _do_meta
{ my ($slf, $req) = @_;
  my ($abr, $lng, $obj, $oid, $rsp, $typ, $val, $xml);

  # Parse the diaglet and generate the documentation report
  eval {
    # Find the diaglet
    ($abr, undef, $xml) = _load($slf, $HCCE, $req);
    die get_string('NO_DIAGLET') unless defined($xml);

    # Apply the restriction
    die get_string('NO_TARGET')
      unless defined($typ = $xml->get_value('target'));
    die get_string('BAD_TARGET', $typ)
      if defined($val = $req->get_first('target')) && $typ ne $val;

    # Load the package to generate the documentation
    $lng = $slf->{'_agt'}->get_lang('SDCL');
    $obj = $lng->load_package($MET) or die get_string('NO_PACKAGE', $MET);
    $oid = $obj->set_info('oid', $tb_tst{$HCCE});

    # Execute the code
    $obj->exec(get_string('ERR_RUN'), [$req, $xml, $abr], 'Meta');
    $rsp = $obj->get_info('val');
    $obj->set_info('oid', $oid);

    # Keep the documentation package when requested
    if ($req->get_first('keep'))
    { $lng->keep_package($obj);
    }
    else
    { $lng->remove_package($obj);
    }
    };
  $req->add_error($@) if $@;

  # Indicate the completion status
  return ref($rsp) eq 'RDA::Object::Message'
    ? $rsp
    : $req->error('Meta',{exit=>2});
}

=head2 DIAGLET.RUN - Run diaglet command

This command executes a diaglet. It supports the following attributes:

=over 13

=item B<  collector>

Specifies the collector used for the rule set report generation.

=item B<  diaglet>

Specifies the name or the path of the diaglet file.

=item B<  directory>

Specifies an alternative diaglet directory (C<hcve> by default).

=item B<  force>

When true, ignores the execution constraints (false by default).

=item B<  groups>

When present, restricts the rule set search to the specified groups.

=item B<  keep>

When true, keeps in memory the package used for executing rule sets (false by
default).

=back

=cut

sub _do_run
{ my ($slf, $req) = @_;
  my ($abr, $cfg, $det, $glb, $rsp, $str, $tgt, $val, $xml, %rsp);

  $rsp{'exit'} = 0;
  eval {
    # Initialization
    $cfg = $slf->{'_cfg'};

    # Parse the XML
    ($abr, undef, $xml) = _load($slf, $HCVE, $req);
    die get_string('NO_DIAGLET') unless defined($xml);

    # Apply the restrictions
    $glb = _get_desc($xml,{abr => $abr, set => 'NoName'});
    unless ($req->get_first('force'))
    { # Apply the plaform restrictions
      if (exists($glb->{'plt'}))
      { die get_string('BAD_PLATFORM', $glb->{'plt'})
          unless _tst_member($glb->{'plt'}, $cfg->get_os);
      }
      elsif (exists($glb->{'fam'}))
      { die get_string('BAD_FAMILY', $glb->{'fam'})
          unless _tst_member($glb->{'fam'}, $cfg->get_family);
      }

      # Apply the target restrictions
      ($tgt) = $xml->find('sdp_meta type="target"');
      if ($tgt)
      { if ($val = $tgt->get_value('host'))
        { $str = $cfg->get_host;
          die get_string('BAD_HOST', $str) unless _tst_member($val, $str);
        }
        elsif ($val = $tgt->get_value('domain'))
        { $str = $cfg->get_domain;
          die get_string('BAD_DOMAIN', $str) unless _tst_member($val, $str);
        }
      }
    }

    # Treat the diaglet content
    $glb->{'cls'} = $glb->{'typ'} || 'U';
    foreach my $job ($xml->find('sdp_content'))
    { ++$glb->{'cnt'};
      $det = _get_desc($job, $glb);
      if ($det->{'typ'} eq 'check')
      { $rsp = _run_rules($slf, $HCVE, $req, $det, $abr);
        if (ref($rsp) eq 'RDA::Object::Message')
        { push(@{$rsp{'errors'}},  $rsp->get_value('errors'));
          push(@{$rsp{'results'}}, $rsp->get_value('results'));
          $rsp{'exit'} |= $rsp->get_first('exit');  ## no critic (Bit)
        }
      }
      elsif ($det->{'typ'} eq 'eval')
      { foreach my $itm ($job->get_content)
        { ++$det->{'cnt'};
          $val = $itm->get_name(q{});
          next unless exists($tb_run{$val});
          $rsp = &{$tb_run{$val}}($slf, $itm, $glb->{'cnt'}.q{/}.$det->{'cnt'});
          $req->abort if $rsp->is_error($req, get_string('ERR_RESPONSE'));
        }
      }
    }
    };

  # Indicate the completion status
  return $req->reply($@, 'Run', %rsp);
}

sub _run_ask
{ my ($slf, $xml, $uid) = @_;
  my ($dat, $dft, $nam, $rsp, $val);

  die get_string('NO_NAME', $uid)
    unless defined($nam = $xml->get_value('name'));
  $dat = $xml->get_data ||
         $xml->get_value('line') ||
         get_string('Ask', $nam);
  $dat .= qq{\n}.get_string('Default', $dft)
    if defined($dft = $xml->get_value('default'))
    && length($dft = $slf->{'_env'}->resolve($dft, 1));
  $rsp = $slf->{'_agt'}->submit(q{.},
    RDA::Object::Message->new('ASK.ASK_LINE')->add_data($dat));
  if ($rsp->is_success)
  { $val = (defined($val = $rsp->get_data) && length($val))
      ? $slf->{'_env'}->resolve($val)
      : $dft;
    eval {$slf->{'_agt'}->get_run->set_temp($nam, $val) if defined($val)};
  }
  return $rsp;
}

sub _run_exec
{ my ($slf, $xml, $uid) = @_;
  my ($cmd, $cnt, $dat, $dst, $msg, $nam, $sep, $str, $tag, $typ,  %tbl);

  %tbl = map {$_ => $xml->get_value($_)} $xml->get_attr;
  die get_string('NO_COMMAND', $uid)
    unless defined($cmd = delete($tbl{'command'}));
  $dst = q{.} unless defined($dst = delete($tbl{'dest'}));
  $cnt = 0;
  foreach my $itm ($xml->get_content)
  { $tag = $itm->get_name(q{});
    if ($tag eq 'sdp_attribute')
    { die get_string('NO_ATTR_NAME', "$uid/$cnt")
        unless length($nam = $itm->get_value('name', q{}));
      $typ = $itm->get_value('type', q{});
      if ($typ eq 'value')
      { $str = $itm->get_data;
        $str =~ s/^\r*\n\r*//;
        $str =~ s/\r*\n\r*$//;
        $tbl{$nam} = defined($sep = $itm->get_value('separator'))
          ? [split(/\Q$sep\E/, $str)]
          : $str;
      }
      elsif ($typ eq 'list')
      { $str = $itm->get_data;
        $str =~ s/^\r*\n\r*//;
        $str =~ s/\r*\n\r*$//;
        $tbl{$nam} = [split(/\n/, $str)];
      }
      elsif ($typ eq 'save')
      { foreach my $key ($itm->get_attr)
        { $tbl{$nam}->{$key} = $itm->get_value($key)
            if $key ne 'name' && $key ne 'type';
        }
      }
      ++$cnt;
    }
    elsif ($tag eq 'sdp_data')
    { $dat = $itm->get_data;
      ++$cnt;
    }
    elsif (length($tag))
    { ++$cnt;
    }
  }
  $dat = $xml->get_data unless $cnt;
  $msg = RDA::Object::Message->new($cmd, %tbl);
  $msg->add_data($dat) if length($dat);
  return $slf->{'_agt'}->submit($dst, $msg);
}

sub _tst_member
{ my ($lst, $str) = @_;

  foreach my $itm (split(/,/, $lst))
  { return 1 if $itm eq $str;
  }
  return 0;
}

=head2 DIAGLET.VERSION - Version extraction diaglet command

This command extracts the version information from a diaglet. It supports the
following attribute:

=over 13

=item B<  diaglet>

Specifies the name or the path of the diaglet file.

=item B<  directory>

Specifies an alternative diaglet directory (C<hcve> by default).

=item B<  groups>

When present, restricts the rule set search to the specified groups.

=back

=cut

sub _do_version
{ my ($slf, $req) = @_;
  my ($xml, @tbl);

  # Parse the diaglet
  eval {
    (undef, undef, $xml) = _load($slf, $NONE, $req);
    die get_string('NO_DIAGLET') unless defined($xml);
    };
  return $req->error('Version', $@) if $@;

  # Extract the version information
  foreach my $itm ($xml->find('sdp_meta type="version" id="\S"'))
  { push(@tbl, sprintf('%-20s %s', _get_version($itm->get_value('id'))));
  }
  foreach my $rul ($xml->find('.../sdp_rule id="\d+" version="\d+"'))
  { push(@tbl, sprintf('  %-18s %s', 'Rule '.$rul->get_value('id'),
      $rul->get_value('version')));
  }

  # Indicate the completion status
  return $req->new('OK.Version')->add_data([@tbl]);
}

# --- Internal routines -------------------------------------------------------

# Check an eval content block
sub _chk_eval
{ my ($req, $xml, $blk) = @_;
  my ($cnt, $tag);

  $cnt = 0;
  foreach my $itm ($xml->get_content)
  { ++$cnt;
    $tag = $itm->get_name(q{});
    if ($tag eq 'sdp_ask')
    { $req->add_error(get_string('NO_NAME', "$blk/$cnt"))
        unless defined($itm->get_value('name'));
    }
    elsif ($tag eq 'sdp_exec')
    { _chk_exec($req, $itm, "$blk/$cnt");
    }
    elsif ($itm->get_type eq 'T')
    { $req->add_error(get_string('BAD_TAG', $tag));
    }
    else
    { $req->add_error(get_string('NO_TAG', "$blk/$cnt"));
    }
  }
  return;
}

sub _chk_exec
{ my ($req, $xml, $uid) = @_;
  my ($cnt, $tag);

  $cnt = 0;
  $req->add_error(get_string('NO_COMMAND', "$uid"))
     unless defined($xml->get_value('command'));
  foreach my $itm ($xml->get_content)
  { ++$cnt;
    $tag = $itm->get_name(q{});
    if ($tag eq 'sdp_attribute')
    { $req->add_error(get_string('NO_ATTR_NAME', "$uid/$cnt"))
        unless defined($itm->get_value('name'));
      $req->add_error(get_string('BAD_ATTR_TYPE', "$uid/$cnt"))
        unless exists($tb_att{$itm->get_value('type', q{})});
    }
    elsif ($tag eq 'sdp_data')
    {
    }
    elsif ($itm->get_type eq 'T')
    { $req->add_error(get_string('BAD_TAG', $tag));
    }
  }
  return;
}

# Check the message references
sub _chk_message
{ my ($tbl, $val) = @_;

  foreach my $uid (split(/,/, $val))
  { return 1 unless $uid =~ m/%(\w+\.)*\w+%/ || exists($tbl->{$uid});
  }
  return 0;
}

# Check a rule set
sub _chk_rule_set  ## no critic (Complex)
{ my ($req, $err, $xml, $blk) = @_;
  my ($cnt, $flg, $mod, $nbg, $nbf, $nbr, $out, $rid, $typ, $uid, $val,
      @grp, %fct, %grp, %msg, %out, %rul, %tbl);

  $flg = $req->get_first('warnings', 0);

  # Validate the opt-out identifier
  $req->add_error(get_string('BAD_OPTOUT'))
    unless $xml->get_value('id','X') =~ m/^\w+$/;

  # Analyze the facts
  $nbf = 0;
  foreach my $itm ($xml->find('sdp_facts/sdp_fact'))
  { ++$nbf;
    if (defined($uid = $itm->get_value('id')))
    { next if $fct{$uid}++;

      # Check the presence of a description
      $cnt = $itm->find('sdp_description');
      $req->add_error(get_string('NO_FACT_DESC', $uid)) unless $cnt;
      $req->add_error(get_string('DUP_FACT_DESC', $uid)) if $cnt > 1;

      # Validate the triggering parameters
      $cnt = 0;
      foreach my $trg ($itm->find('sdp_parameters/sdp_parameter'))
      { next unless defined($val = $trg->get_value('name'));
        $req->add_error(get_string('BAD_PARAMETER', $uid, $val))
          unless $val =~ m/^(\w+\.)+\w+$/;
        ++$cnt;
      }
      $req->add_error(get_string('NO_PARAMETER', $uid)) unless $cnt;

      # Validate the fact commands
      $cnt = 0;
      foreach my $cmd ($itm->find('sdp_command'))
      { ++$cnt;

        # Validate the command type
        $typ = uc($cmd->get_value('type', q{}));
        $req->add_error(get_string('BAD_FACT_TYPE', $uid, $typ))
           unless exists($tb_fct{$typ});

        # Check the command code
        if (($typ eq 'SDCL' || $typ eq 'RDA')
          && length($val = $cmd->get_data))
        { eval {$err->check_action("fact$uid", _fmt_code($val))};
          $req->add_error($err->add_error($@)->purge_errors,
            get_string('BAD_FACT_CODE', $uid)) if $@;
        }
        elsif ($typ eq 'SDSL' && length($val = $cmd->get_data))
        { eval {$err->check_setup("fact$uid", _fmt_code($val))};
          $req->add_error($err->add_error($@)->purge_errors,
            get_string('BAD_FACT_CODE', $uid)) if $@;
        }
        elsif ($typ eq 'PROMPT')
        { $req->add_error(get_string('BAD_FACT_PROMPT', $uid))
            unless $cmd->get_data =~ m/\S/;
          if (defined($val = $cmd->get_value('input')))
          { foreach my $key (split(/,/, $val))
            { next if $key =~ m/^((COL|HCVE|RUN)\/)?(\w+\.)+[A-Z]_[A-Z]\w*$/i;
              $req->add_error(get_string('BAD_INPUT', $uid, $val));
              last;
            }
          }
        }
      }
      $req->add_error(get_string('NO_FACT_COMMAND', $uid)) unless $cnt;
    }
    else
    { $req->add_error(get_string('BAD_FACT', $nbf));
    }
  }

  # Analyze the messages
  $cnt = 0;
  foreach my $itm ($xml->find('sdp_messages/sdp_message'))
  { ++$cnt;
    if (defined($uid = $itm->get_value('id')))
    { ++$msg{$uid};
    }
    else
    { $req->add_error(get_string('BAD_MESSAGE', $cnt));
    }
  }

  # Analyze the groups
  if (@grp = $xml->find('sdp_group'))
  { # Get the group name
    foreach my $grp (@grp)
    { $grp{$uid} = 1
        if defined($uid = $grp->get_value('id'));
    }

    # Analyze the rules
    $nbg = 0;
    foreach my $grp (@grp)
    { ++$nbg;
      $nbr = 0;
      $out = $grp->get_value('opt_out');
      foreach my $rul ($grp->find('sdp_rule'))
      { ++$nbr;

        # Check the rule identifier
        $rid = $rul->get_value('id',q{});
        if ($rid =~ m/^\w+$/)
        { next if $tbl{$rid}++;
          $req->add_error(get_string('BAD_ID', $rid))
            if length($rid) > 6;
          $out{$rid} = 0 if $rul->get_value('opt_out', $out);

          # Check the presence of a description
          $cnt = $rul->find('sdp_description');
          $req->add_error(get_string('NO_RULE_DESC', $rid)) unless $cnt;
          $req->add_error(get_string('DUP_RULE_DESC', $rid)) if $cnt > 1;

          # Check the dependencies
          $rul{$rid} = [];
          foreach my $dep ($rul->find('sdp_dependencies/sdp_dependency'))
          { $uid = $dep->get_value('id',q{});
            if ($uid !~ m/^\w+$/)
            { $req->add_error(get_string('BAD_DEPENDENCY', $rid));
            }
            elsif ($rid)
            { push(@{$rul{$rid}}, $uid);

              # Check the condition
              if (defined($val = $dep->get_value('condition')))
              { $req->add_error(get_string('DEP_CONDITION', $rid, $uid, $val))
                  unless $val =~ $re_tst;
                $req->add_error(get_string('DEP_MINIMUM', $rid, $uid, $val))
                  if $val =~ $re_min && !defined($dep->get_value('minimum'));
                $req->add_error(get_string('DEP_MAXIMUM', $rid, $uid, $val))
                  if $val =~ $re_max && !defined($dep->get_value('maximum'));
              }

              # Check the result
              $val = $dep->get_value('result','FAILED');
              $req->add_error(get_string('DEP_RESULT', $rid, $uid, $val))
                unless exists($tb_res{$val});

              # Check the syntax
              $val = $dep->get_value('syntax','text');
              $req->add_error(get_string('DEP_SYNTAX', $rid, $uid, $val))
                unless exists($tb_syn{$val});

              # Check the messages
              $req->add_error(get_string('DEP_MESSAGE', $rid, $uid, $val))
                if defined($val = $dep->get_value('message'))
                && _chk_message(\%msg, $val);
            }
          }

          # Check the command blocks
          $cnt = 0;
          $mod = uc($rul->get_value('mode', q{}));
          $typ = q{};
          foreach my $cmd ($rul->find('sdp_command'))
          { ++$cnt;

            # Validate the command type
            $typ = uc($cmd->get_value('type', q{}));
            $req->add_error(get_string('BAD_TYPE', $rid, $typ))
              unless exists($tb_typ{$typ});

            # Check the command code
            if (($typ eq 'SDCL' || $typ eq 'RDA')
              && length($val = $cmd->get_data))
            { eval {$err->check_action("rule$rid", _fmt_code($val))};
              $req->add_error($err->add_error($@)->purge_errors,
                get_string('ERR_COMMAND', $rid)) if $@;
            }
            elsif ($typ eq 'SDSL' && length($val = $cmd->get_data))
            { eval {$err->check_setup("rule$rid", _fmt_code($val))};
              $req->add_error($err->add_error($@)->purge_errors,
                get_string('ERR_COMMAND', $rid)) if $@;
            }
            elsif ($typ eq 'ATTACH')
            { $mod = 'ATTACH';
            }
            elsif ($typ eq 'GROUP')
            { $req->add_error(get_string('BAD_GROUP', $rid, $val))
                unless exists($grp{$val = $cmd->get_data});
            }
            elsif ($typ eq 'LOOP')
            { $req->add_error(get_string('BAD_GROUP', $rid, $val))
                unless exists($grp{$val = $cmd->get_data});
              $req->add_error(get_string('NO_VARIABLE', $rid))
                unless defined($cmd->get_value('variable'));
              if (defined($val = $cmd->get_value('input')))
              { foreach my $key (split(/,/, $val))
                { next
                    if $key =~ m/^((COL|HCVE|RUN)\/)?(\w+\.)+[A-Z]_[A-Z]\w*$/i;
                  $req->add_error(get_string('BAD_INPUT', $rid, $val));
                  last;
                }
              }
              else
              { $req->add_error(get_string('NO_INPUT', $rid));
              }
            }
            elsif ($typ eq 'PROMPT')
            { $req->add_error(get_string('BAD_PROMPT', $rid))
                unless $cmd->get_data =~ m/\S/;
              if (defined($val = $cmd->get_value('input')))
              { foreach my $key (split(/,/, $val))
                { next
                    if $key =~ m/^((COL|HCVE|RUN)\/)?(\w+\.)+[A-Z]_[A-Z]\w*$/i;
                  $req->add_error(get_string('BAD_INPUT', $rid, $val));
                  last;
                }
              }
            }

            # Check parameter and variable
            $req->add_error(get_string('BAD_PARAMETER', $rid, $val))
              if defined($val = $cmd->get_value('exec'))
              && $val !~ m/^(?:\w+\.)+\w+(?:\|(?:\w+\.)+\w+)*$/;
            $req->add_error(get_string('BAD_PARAMETER', $rid, $val))
              if defined($val = $cmd->get_value('parameter'))
              && $val !~ m/^(?:\w+\.)+\w+$/;
            $req->add_error(get_string('BAD_VARIABLE', $rid, $val))
              if defined($val = $cmd->get_value('variable'))
              && $val !~ m/^\$\w+$/;
          }
          $req->add_error(get_string('NO_RULE_COMMAND', $rid))
            unless $cnt;

          # Check the rule mode and name
          $val = length($rul->get_value('name', q{}));
          $req->add_error(get_string('NO_RULE_NAME', $rid))
            unless $val;
          $req->add_error(get_string('BAD_RULE_NAME', $rid))
            if $flg && $val > 20;
          $req->add_error(get_string('BAD_RULE_MODE', $rid, $mod))
            unless exists($tb_mod{$mod});

          # Check the actions
          $cnt = 0;
          foreach my $act ($rul->find('sdp_actions/sdp_action'))
          { # Check the condition
            if (defined($val = $act->get_value('condition')))
            { ++$cnt if $cnt;
              $req->add_error(get_string('ACT_CONDITION', $rid, $val))
                unless $val =~ $re_tst;
              $req->add_error(get_string('ACT_MINIMUM', $rid, $val))
                if $val =~ $re_min && !defined($act->get_value('minimum'));
              $req->add_error(get_string('ACT_MAXIMUM', $rid, $val))
                if $val =~ $re_max && !defined($act->get_value('maximum'));
            }
            else
            { ++$cnt;
            }

            # Check the result
            $val = $act->get_value('result','FAILED');
            $req->add_error(get_string('ACT_RESULT', $rid, $val))
              unless exists($tb_res{$val});

            # Check the syntax
            $val = $act->get_value('syntax','text');
            $req->add_error(get_string('ACT_SYNTAX', $rid, $val))
              unless exists($tb_syn{$val});

            # Check the variable
            $req->add_error(get_string('ACT_VARIABLE', $rid, $val))
              if defined($val = $act->get_value('variable'))
              && $val !~ m/^\$\w+$/;

            # Check the messages
            $req->add_error(get_string('ACT_MESSAGE', $rid, $val))
              if defined($val = $act->get_value('message'))
              && _chk_message(\%msg, $val);
          }
          $req->add_error(get_string('EXTRA_ACTION', $rid, $cnt - 1))
            if $cnt > 1;
        }
        else
        { $req->add_error(get_string('BAD_RULE', "$blk/$nbg/$nbr"));
        }
      }
      $req->add_error(get_string('NO_RULE', $nbg)) unless $nbr;
    }
  }
  else
  { $req->add_error(get_string('NO_GROUP'));
  }

  # Detect the duplicate facts
  foreach my $uid (sort keys(%fct))
  { $req->add_error(get_string('DUP_FACT', $uid))
      if $fct{$uid} > 1;
  }

  # Detect the duplicate messages
  foreach my $uid (sort keys(%msg))
  { $req->add_error(get_string('DUP_MESSAGE', $uid))
      if $msg{$uid} > 1;
  }

  # Detect the missing rules
  foreach my $rid (sort keys(%rul))
  { foreach my $did (@{$rul{$rid}})
    { $req->add_error(get_string('MISSING_RULE', $rid, $did))
        unless exists($rul{$did});
    }
    $req->add_error(get_string('DUP_RULE', $rid))
      if $tbl{$rid} > 1;
  }

  # Detect rules that can opted out but referenced in dependencies
  foreach my $rid (sort keys(%out))
  { $req->add_error(get_string('DEP_OPTOUT', $rid)) if $out{$rid};
  }

  # Detect circular references
  %tbl = ();
  foreach my $rid (sort keys(%rul))
  { if (exists($tbl{$rid}))
    { $req->add_error(get_string('RULE_LOOP', $rid)) if $tbl{$rid};
    }
    elsif (_detect_loop(\%tbl, \%rul, $rid))
    { $req->add_error(get_string('RULE_LOOP', $rid));
    }
  }
  return;
}

# Detect circular dependencies
sub _detect_loop
{ my ($tbl, $rul, $rid) = @_;

  $tbl->{$rid} = 1;
  foreach my $did (@{$rul->{$rid}})
  { if (exists($tbl->{$did}))
    { return 1 if $tbl->{$did};
    }
    elsif (exists($rul->{$did}))
    { return 1 if _detect_loop($tbl, $rul, $did);
    }
  }
  return $tbl->{$rid} = 0;
}

# Format the code
sub _fmt_code
{ my ($val) = @_;
  my ($chr, $key, $ref);

  # Replace the references
  $chr = "\224";
  while ($val =~ m/(%+(.*?)%+)/)
  { ($ref, $key) = ($1, $2);
    if ($key =~ m/^(\w+\.)*\w+$/)
    { $ref = 0;
    }
    else
    { # Escape when not a reference
      $ref =~ s/%!/%/;
      $ref =~ s/!%/%/;
      $ref =~ s/%/$chr/g;
    }
    $val =~ s/%+$key%+/$ref/g;
  }
  $val =~ s/$chr/%/g;

  # Return the code without reference
  return $val;
}

# Get the description
sub _get_desc
{ my ($xml, $glb) = @_;
  my ($rec, $val);

  $rec = $glb ? {%{$glb}} : {};
  foreach my $key (keys(%tb_dsc))
  { $rec->{$key} = $val if defined($val = $xml->get_value($tb_dsc{$key}));
  }
  $rec->{'cnt'} = 0;
  $rec->{'xml'} = $xml;
  return $rec;
}

# Extract the version
sub _get_version
{ my ($str) = @_;
  my ($fil, $ver);

  (undef, $fil, $ver) = split(/\s+/, $str);
  $fil =~ s/,v$//i;
  return ($fil, $ver);
}

# Load the diaglet
sub _load
{ my ($slf, $typ, $req) = @_;
  my ($dir, $grp, $ifh, $lin, $pth, $xml);

  # Parse the diaglet
  $xml = RDA::Object::Xml->new($slf->{'_agt'}->get_collector->get_trace('XML'));
  $xml->normalize_text(-1);
  if ($pth = RDA::Object::Rda->is_path($req->get_first('diaglet')))
  { # Parse the file
    $pth =~ s/\.xml$//i;
    if ($pth =~ $RE_SET)
    { $pth = $slf->{'_cfg'}->get_file('D_RDA_CHK', "$1/$2", '.xml');
      $grp = $1;
    }
    elsif (RDA::Object::Rda->is_absolute($pth))
    { $pth = "$pth.xml";
      $grp = 'RDA' unless defined($grp = $slf->{'_cnt'}->get_group($pth));
    }
    elsif (defined($dir = $req->get_first('directory')))
    { $pth = RDA::Object::Rda->cat_file($dir, "$pth.xml");
      $grp = 'RDA' unless defined($grp = $slf->{'_cnt'}->get_group($pth));
    }
    else
    { $pth = $slf->{'_cfg'}->get_file('D_RDA_CHK', $pth, '.xml');
      $grp = 'RDA' unless defined($grp = $slf->{'_cnt'}->get_group($pth));
    }
    $xml->parse_file($pth);
  }
  elsif ($ifh = RDA::Handle::Data->new($req))
  { # Parse the data
    $xml->parse($lin) while defined($lin = $ifh->getline);
    $xml->eof;
    $ifh->close;
    $grp = 'RDA';
  }
  else
  { die get_string('NO_CODE');
  }

  # Reject diaglet with XML errors
  die get_string('ERR_XML') if $xml->get_error;

  # Return the XML tree
  return ($grp.$tb_abr{$typ}, $xml, $xml->find('sdp_diaglet'));
}

# Execute HCVE rules
sub _run_rules
{ my ($slf, $typ, $req, $det, $abr) = @_;
  my ($lng, $obj, $oid, $rsp);

  # Load the package
  $lng = $slf->{'_agt'}->get_lang('SDCL');
  $obj = $lng->load_package($tb_pkg{$typ})
    or die get_string('NO_PACKAGE', $tb_pkg{$typ});
  $oid = $obj->set_info('oid', $tb_tst{$typ});

  # Execute the code
  $obj->exec(get_string('ERR_RUN'), [$req, $det, 1]);
  $rsp = $obj->get_info('val');
  $obj->set_info('oid', $oid);

  # Keep the package when requested
  if ($req->get_first('keep'))
  { $lng->keep_package($obj);
  }
  else
  { $lng->remove_package($obj);
  }

  # Return the response
  return $rsp;
}

1;

__END__

=head1 SEE ALSO

L<RDA::Agent|RDA::Agent>,
L<RDA::Handle::Data|RDA::Handle::Data>,
L<RDA::Object|RDA::Object>,
L<RDA::Object::Collect|RDA::Object::Collect>,
L<RDA::Object::Content|RDA::Object::Content>,
L<RDA::Object::Env|RDA::Object::Env>,
L<RDA::Object::Hcve|RDA::Object::Hcve>,
L<RDA::Object::Message|RDA::Object::Message>,
L<RDA::Object::Rda|RDA::Object::Rda>,
L<RDA::Object::Xml|RDA::Object::Xml>,
L<RDA::Object::Hcve|RDA::Object::Hcve>,
L<RDA::Text|RDA::Text>

=head1 COPYRIGHT NOTICE

Copyright (c) 2002, 2016, Oracle and/or its affiliates. All rights reserved.

=head1 TRADEMARK NOTICE

Oracle and Java are registered trademarks of Oracle and/or its
affiliates. Other names may be trademarks of their respective owners.

=cut