# Hcve.pm: Class Used for HCVE Rule Sets

package RDA::Object::Hcve;

# $Id: Hcve.pm,v 1.24 2015/07/31 12:58:45 RDA Exp $
# ARCS: $Header: /home/cvs/cvs/RDA_8/src/scripting/lib/RDA/Object/Hcve.pm,v 1.24 2015/07/31 12:58:45 RDA Exp $
#
# Change History
# 20150731  MSC  Add new text emphasis.

=head1 NAME

RDA::Object::Hcve - Class Used for HCVE Rule Sets

=head1 SYNOPSIS

 require RDA::Object::Hcve;

=head1 DESCRIPTION

The objects of the C<RDA::Object::Hcve> class are used to manage Health
Checks / Validation Engine (HCVE) rule sets.

The following methods are available:

=cut

use strict;

BEGIN
{ use Exporter;
  use IO::File;
  use RDA::Text qw(get_string);
  use RDA::Error;
  use RDA::Handle::Memory;
  use RDA::Object;
  use RDA::Object::Buffer;
  use RDA::Object::Rda;
  use RDA::SDCL::Block qw($CONT $DIE_M $RET_RET $SPC_OBJ $SPC_REF $SPC_VAL);
  use RDA::SDSL::Module;
  use RDA::Value::Pointer;
  use RDA::Value::Scalar qw(:value);
}

# Define the global public variables
use vars qw($STRINGS $VERSION @EXPORT_OK @ISA %SDCL);
$VERSION   = sprintf('%d.%02d', q$Revision: 1.24 $ =~ /(\d+)\.(\d+)/);
@EXPORT_OK = qw(new_check);
@ISA       = qw(RDA::Error RDA::Object Exporter);
%SDCL      = (
  als => {
    ## no critic (Interpolation)
    'evalHcveCommand'  => ['$[HCVE]', 'eval_command'],
    'getHcveFact'      => ['$[HCVE]', 'get_fact'],
    'getHcveParameter' => ['$[HCVE]', 'get_parameter'],
    'getHcveResult'    => ['$[HCVE]', 'get_result'],
    'getHcveTargets'   => ['$[HCVE]', 'get_targets'],
    'getHcveValues'    => ['$[HCVE]', 'get_values'],
    'setHcveContext'   => ['$[HCVE]', 'set_context'],
    'setHcveFact'      => ['$[HCVE]', 'set_fact'],
    'setHcveParameter' => ['$[HCVE]', 'set_parameter'],
    'setHcveResult'    => ['$[HCVE]', 'set_result'],
    'setHcveRule'      => ['$[HCVE]', 'set_rule'],
    'setHcveTarget'    => ['$[HCVE]', 'set_target'],
    'setHcveVariable'  => ['$[HCVE]', 'set_variable'],
    },
  beg => \&_begin_hcve,
  dep => [qw(RDA::Object::Output)],
  inc => [qw(RDA::Object)],
  met => {
    'define_variable' => {ret => 0, evl => 'E'},
    'eval_command'    => {ret => 1},
    'format_errors'   => {ret => 1},
    'get_fact'        => {ret => 0},
    'get_parameter'   => {ret => 0},
    'get_result'      => {ret => 0},
    'get_targets'     => {ret => 0},
    'get_values'      => {ret => 0},
    'list_errors'     => {ret => 1},
    'pop_errors'      => {ret => 1},
    'purge_errors'    => {ret => 0},
    'set_context'     => {ret => 0},
    'set_fact'        => {ret => 0},
    'set_info'        => {ret => 0},
    'set_parameter'   => {ret => 0},
    'set_result'      => {ret => 0},
    'set_rule'        => {ret => 0},
    'set_target'      => {ret => 0},
    'set_trace'       => {ret => 0},
    'set_variable'    => {ret => 0, blk => 1},
    },
  top => 'HCVE',
  trc => 'HCVE',
  );

# Define the global private constants
my $CLS = 'RDA::Object::Hcve';
my $TRC = 'TRACE/HCVE/';

my @CLS = qw(RDA::Object::Env
             RDA::Object::View
             RDA::Object::Rda
             RDA::Object::Target
             RDA::Object::Display
             RDA::Object::Pipe
             RDA::Object::Report
             RDA::Object::Toc
             RDA::Object::Collect
             RDA::Object::Windows);

# Define the global private variables
my %tb_res = (
  C => $CONT,
  R => $RET_RET,
  );
my %tb_stl = (
  q{=} => undef,
  q{*} => q{**},
  q{'} => q{''},
  q{`} => q{``},
  q{^} => q{^^},
  );

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

=head2 S<$h = RDA::Object::Hcve-E<gt>new($pkg)>

The object constructor. It takes the package object reference as an argument.

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

=over 12

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

=item S<    B<'dir' > > Package directory

=item S<    B<'err' > > Error buffer

=item S<    B<'lng' > > Reference to the language control object

=item S<    B<'lvl' > > Trace level

=item S<    B<'rpt' > > Reference to the local reporting control object

=item S<    B<'sys' > > Reference to the system view object

=item S<    B<'_col'> > Fact collector hash

=item S<    B<'_ctx'> > Action evaluation context

=item S<    B<'_lib'> > Library blocks

=item S<    B<'_lid'> > Loop identifier array

=item S<    B<'_map'> > Parameter to collector mapping

=item S<    B<'_res'> > HCVE rule result hash

=item S<    B<'_rul'> > HCVE rule identifier

=item S<    B<'_tid'> > Target identifier hash

=back

Internal keys are prefixed by an underscore.

=cut

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

  # Create the object and return its reference
  return bless {
    cfg  => $pkg->get_config,
    dir  => $pkg->get_info('dir'),
    err  => [],
    grp  => $pkg->get_info('grp'),
    lng  => $pkg->get_info('lng'),
    lvl  => $pkg->get_collector->get_trace('HCVE'),
    rpt  => $pkg->get_top('OUT'),
    sys  => $pkg->get_system,
    _col => {},
    _lib => [],
    _lid => [],
    _map => {},
    _res => {},
    _rul => q{},
    _tid => {},
    }, ref($cls) || $cls;
}

=head2 S<$h-E<gt>define_variable($name,$value)>

This method defines a variable in the evaluation context.

=cut

sub define_variable
{ my ($slf, $arg) = @_;
  my ($nam, $val);

  ($nam, $val) = @{$arg};
  if (ref($nam) && ($nam = $nam->eval_as_string))
  { $val = $VAL_UNDEF unless ref($val);
    $slf->{'_ctx'}->{'ctx'}->set_value($nam, $val);
  }
  return $val;
}

=head2 S<$h-E<gt>eval_command($typ,$cod[,$flg])>

This method evaluates a command block. It returns a list containing the value,
possibly followed by error details. When the flag is set, it does not extract
the error stack content.

=cut

sub eval_command  ## no critic (Complex)
{ my ($slf, $typ, $cod, $flg, $nam) = @_;
  my ($ctx, $ret, $val);

  $ctx = $slf->{'_ctx'};
  $nam = 'rule'.$slf->{'_rul'} unless defined($nam);
  if ($typ eq 'OS')
  { $val = join(qq{\n}, _call($slf, 'command', $ctx, $cod));
    $val =~ s/[\n\r\s]+$//m;
    return ($val, 'Execution Error', 'Exit code: '.$ret)
      if ($ret = _call($slf, 'status', $ctx));
  }
  elsif ($typ eq 'PERL')
  { my ($pgm);

    return ($val, 'Perl not available')
      unless ($pgm = $slf->{'cfg'}->get_value('T_PERL'));
    $cod =~ s/"/\\"/g;
    $cod =~ s/\$/\$/g;
    $cod =~ s/\n/ /g;
    $cod = $pgm.' -e "'.$cod.q{"};
    $ret = _call($slf, 'loadCommand', $ctx, $cod);
    $val = join(qq{\n}, _call($slf, 'getLines', $ctx));
    $val =~ s/[\n\r\s]+$//m;
    return ($val, 'Execution Error',
      'Exit code: '._call($slf, 'status', $ctx)) unless $ret;
  }
  elsif ($typ eq 'SDCL' || $typ eq 'RDA')
  { $ret = _eval_command($slf, $nam, $cod);
    $val = q{} unless defined($val = $slf->get_result);
    if ($ret)
    { return ($val, get_string($ret)) if $flg;
      return ($val, get_string($ret), $slf->pop_errors(1));
    }
  }
  elsif ($typ eq 'SDSL')
  { $ret = _eval_request($slf, $nam, $cod);
    $val = q{} unless defined($val = $slf->get_result);
    if ($ret)
    { return ($val, get_string($ret)) if $flg;
      return ($val, get_string($ret), $slf->pop_errors(1));
    }
  }
  elsif ($typ eq 'SQL')
  { $ret = _call($slf, 'setSqlTarget', $ctx,
      { B_LOCAL      =>1,
        T_ORACLE_SID =>scalar $slf->{'sys'}->get_value('ORACLE_SID'),
        D_ORACLE_HOME=>scalar $slf->{'sys'}->get_value('ORACLE_HOME'),
        T_USER       =>'system'})
      unless ref(_call($slf, 'getSqlTarget', $ctx)) eq 'RDA::Target::Db';
    $ret = _call($slf, 'loadSql', $ctx, "SET define on\n$cod");
    $val = join(qq{\n}, _call($slf, 'getSqlLines', $ctx));
    $val =~ s/^\s+//;
    $val =~ s/[\n\r\s]+$//m;
    return ($val, 'SQL Error', _call($slf, 'getSqlMessage', $ctx))
      unless $ret;
    return ($val, 'SQL Error')
      if _call($slf, 'grepLastSql', $ctx, '^(ORA|SP2)-\d+','f')
  }
  else
  { return ($val, get_string('BadType', $typ));
  }

  # Indicate the successful completion
  return ($val);
}

sub _call
{ my ($slf, $nam, @arg) = @_;
  my ($def);

  return ($def = $slf->{'_ctx'}->get_lib->find_macro($nam))
    ? $def->call($nam, @arg)
    : undef;
}

sub _eval_command
{ my ($slf, $nam, $cod) = @_;
  my ($blk, $cmd, $obj, $tbl, $top);

  # Abort if the evaluation context is not available
  return 'NoContext' unless exists($slf->{'_ctx'});

  # Create the block and add commands
  $blk = RDA::SDCL::Block->new($slf->{'lng'}, undef, $nam);
  $cmd = $blk->get_info('cmd');
  $cmd->{'export'} = [\&_exe_export, \&_get_export, 0, 0, $slf];
  $cmd->{'result'} = [\&_exe_result, \&_get_result, 0, 0, $slf];

  # Parse the action code
  $cod = q{} unless defined($cod);
  $top = $slf->{'_ctx'};
  eval {$blk->parse(RDA::Handle::Memory->new($cod), [@CLS, $CLS])};
  if ($@)
  { $slf->add_error([$blk->get_agent->pop_error], get_string('PARSE'));
    $blk->delete_object;
    return 'Parse';  # Text:Parse
  }

  # Execute the action and indicate its success
  $top = $slf->{'_ctx'};
  $blk->set_info('dir', $top->{'dir'});
  $blk->set_info('lvl', $top->{'lvl'});
  $blk->set_info('pre', $TRC);
  eval {$blk->exec_package($top)};
  if ($@)
  { $slf->add_error([$blk->get_agent->pop_error], get_string('EXEC'));
    $blk->delete_object;
    return 'Exec';  # Text:Exec
  }
  if ($blk->{'ctx'}->check_variable('$KEEP_BLOCK')) ## no critic (Interpolation)
  { delete($blk->{'_run'});
    push(@{$slf->{'_lib'}}, $blk)
  }
  else
  { # Resynchronize the calling block
    $top->{'OUT'}->deprefix($blk) if exists($top->{'OUT'});

    # Fix block chaining
    if (exists($blk->{'_run'}))
    { foreach my $run (keys(%{$tbl = $blk->{'_run'}}))
      { $obj = $slf->{'lng'}->find_package($run, $top->get_package('grp'));
        $obj->{'_par'} = $tbl->{$run} if $obj;
      }
    }

    # Delete the block
    $blk->delete_object;
  }
  return q{};
}

sub _eval_request
{ my ($slf, $nam, $cod) = @_;
  my ($agt, $blk, $top);

  # Abort if the evaluation context is not available
  return 'NoContext' unless exists($slf->{'_ctx'});

  # Parse the SDSL code
  $cod = q{} unless defined($cod);
  $top = $slf->{'_ctx'};
  $agt = $top->get_agent;
  $blk = eval {$agt->get_lang('SDSL')->load_data(
    RDA::Handle::Memory->new($cod), undef, $nam)};
  if ($@)
  { $slf->add_error([$agt->add_error($@)->pop_error], get_string('PARSE'));
    return 'Parse';  # Text:Parse
  }
  $blk->set_info('dir', $top->{'dir'});
  $blk->set_info('shr', $top);
  $blk->set_code('result', \&set_result, $slf);

  # Execute the action and indicate its success
  eval {$blk->request($agt->get_run->find('HCVE', 1), $top->{'lvl'})};
  if ($@)
  { $slf->add_error([$agt->add_error($@)->pop_error], get_string('EXEC'));
    $blk->delete_object;
    return 'Exec';  # Text:Exec
  }
  $blk->delete_object;
  return q{};
}

=head2 S<$h-E<gt>get_fact($nam[,$dft])>

This method performs required fact collection and returns the value of the
specified parameter.

=cut

sub get_fact
{ my ($slf, $nam, $dft) = @_;
  my ($cod, $col, $err, $key, $uid, $val, @err);

  # Perform the fact collection when needed
  $nam = uc($nam);
  if (defined($uid = _get_fact_id($slf->{'_map'}, $nam))
    && defined($col = delete($slf->{'_col'}->{$uid})))
  { foreach my $cmd (@{$col})
    { next unless ($cod = $cmd->get_data);

      # Execute the command
      ($val, $err, @err)
        = $slf->eval_command($cmd->get_value('type', q{}), $cod, 0, "fact$uid");
      die get_string('FACT', $uid, join(qq{\n}, $err, @err)) if $err;

      # Define parameter and variable
      $key = $cmd->get_value('parameter', q{});
      $slf->set_parameter($key, $val) if $key =~ m/^(\w+\.)+\w+$/;
      $key = $cmd->get_value('variable', q{});
      $slf->define_variable($key, $val)  if $key =~ m/^\$\w+$/;
    }
  }

  # Get the parameter value
  return $slf->get_parameter($nam, $dft);
}

sub _get_fact_id
{ my ($map, $nam) = @_;

  for (my $key = $nam ;;)  ## no critic (Loop)
  { return $map->{$nam} = $map->{$key} if exists($map->{$key});
    return unless $key =~ s/^((\w+\.)+\w+)\.\w+$/$1/;
  }
}

=head2 S<$h-E<gt>get_parameter($nam[,$dft])>

This method returns the value of the specified parameter.

=cut

sub get_parameter
{ my ($slf, $nam, $dft) = @_;
  my ($val, @tbl);

  @tbl = split(/\./, uc($nam));
  $val = $slf->{'_res'};
  foreach my $itm (@tbl)
  { return $dft unless ref($val) eq 'HASH' && exists($val->{$itm});
    $val = $val->{$itm};
  }
  return $val;
}

=head2 S<$h-E<gt>get_result([$rule])>

This method returns the result string of the specified rule. By default, it
returns the current one.

=cut

sub get_result
{ my ($slf, $rul) = @_;

  $rul = $slf->{'_rul'} unless defined($rul);
  return (length($rul) && exists($slf->{'_res'}->{'rule'}->{$rul}))
    ? $slf->{'_res'}->{'rule'}->{$rul}
    : undef;
}

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

This method returns the target identifier associations.

=cut

sub get_targets
{ return shift->{'_tid'};
}

=head2 S<$h-E<gt>get_values($str)>

This method returns the string with all HCVE variable references replaced by
their respective values. It supports nested references. The following reference
formats are supported:

=over 20

=item B<    ${nam}>

Replaces the reference with the variable values. When the variable is not
defined, it replaces the reference with an empty string.

=item B<    ${nam:dft}>

Replaces the reference with the variable values. When the variable is not
defined, it replaces the reference with the default text.

=item B<    ${nam?txt:dft}>

Replaces the reference with the specified text when the variable
exists. Otherwise, it replaces the reference with the default text.

=back

You can prefix the key by a character indicating how the variable value must be
emphasized. It is not used for other replacement texts. The valid style
characters are as follows:

=over 6

=item S<    *> for bold

=item S<    '> (single quote) for italic

=item S<    `> (back quote) for code

=item S<    ^> for code with spaces replaced by non-blanking spaces

=item S<    => for taking the value without transformation

=back

It returns the resulting value.

=cut

sub get_values
{ my ($slf, $str) = @_;

  if ($str && exists($slf->{'_ctx'}))
  { my $ctx = $slf->{'_ctx'}->{'ctx'};
    1 while $str =~
        s/\$\{([\*\'\`\^\=])?((\w+\.)*\w+)((\?)([^\{\}]*?))?(\:([^\{\}]*?))?\}/
          $3 ? _resolve_par($slf, $1, $2, $5, $6, $8)
             : _resolve_var($ctx, $1, $2, $5, $6, $8)/eg;
  }
  return $str;
}

sub _encode
{ my ($str, $stl) = @_;

  return $str unless defined($stl);
  $str =~ s/([\042\045\047\050\051\053\055\074\076\133\135\173-\175])/
    sprintf("&#x%X;", ord($1))/ge;
  return $stl.$str.$stl;
}

sub _merge_arr
{ my ($val, $stl) = @_;
  my ($buf, $cnt, $nxt, $ref);

  $buf = $nxt = q{};
  $cnt = 0;
  foreach my $itm (@{$val})
  { if (!($ref = ref($itm)))
    { $buf .= $nxt;
      $buf .= _encode($itm, $stl) if defined($itm);
    }
    elsif ($ref eq 'ARRAY')
    { $buf .= ($cnt++) ? '%NEXT%' : '%LIST%';
      $buf .= _merge_arr($itm, $stl);
    }
    elsif ($ref eq 'HASH')
    { $buf .= _merge_hsh($itm, $stl);
    }
    else
    { die "Bad reference\n";
    }
    $nxt = '%BR%';
  }
  $buf .= '%ENDLIST%' if $cnt;
  return $buf;
}

sub _merge_hsh
{ my ($hsh, $stl) = @_;
  my ($buf, $cnt, $ref, $val);

  $buf = q{};
  foreach my $key (sort keys(%{$hsh}))
  { $buf .= ($buf) ? '%NEXT%' : '%LIST%';
    $buf .= _encode($key, $stl);
    next unless defined($val = $hsh->{$key});
    $ref = ref($val);
    if ($ref eq 'HASH')
    { $buf .= _merge_hsh($val, $stl);
    }
    else
    { $cnt = 0;
      $val = [$val] unless $ref eq 'ARRAY';
      if (@{$val})
      { foreach my $itm (@{$val})
        { $buf .= ($cnt++) ? '%NEXT%' : '%LIST%';
          if (!($ref = ref($itm)))
          { $buf .= _encode($itm, $stl) if defined($itm);
          }
          elsif ($ref eq 'ARRAY')
          { $buf .= _merge_arr($itm, $stl);
          }
          elsif ($ref eq 'HASH')
          { $buf .= _merge_hsh($itm, $stl);
          }
          else
          { die "Bad reference\n";
          }
        }
        $buf .= '%ENDLIST%' if $cnt;
      }
    }
  }
  $buf .= '%ENDLIST%' if $buf;
  return $buf;
}

sub _resolve_par
{ my ($slf, $stl, $nam, $tst, $txt, $dft) = @_;
  my ($ref, $val, @tbl);

  @tbl = split(/\./, uc($nam));
  $val = $slf->{'_res'};
  foreach my $itm (@tbl)
  { return defined($dft) ? $dft : q{}
      unless ref($val) eq 'HASH' && exists($val->{$itm});
    $val = $val->{$itm};
  }
  if (defined($val))
  { eval {
      $stl = ($stl && exists($tb_stl{$stl})) ? $tb_stl{$stl} : q{};
      if (!($ref = ref($val)))
      { $val = _encode($val, $stl);
      }
      elsif ($ref eq 'ARRAY')
      { $val = _merge_arr($val, $stl);
      }
      elsif ($ref eq 'HASH')
      { $val = _merge_hsh($val, $stl);
      }
      else
      { die "Bad reference\n";
      }
      };
    return $val unless $@;
  }
  return defined($dft) ? $dft : q{};
}

sub _resolve_var
{ my ($ctx, $stl, $nam, $tst, $txt, $dft) = @_;
  my $val;

  if (defined($val = $ctx->get_value(q{$}.$nam)))
  { $val = $val->eval_value(1);
    if ($val->is_defined)
    { return defined($txt) ? $txt : q{} if $tst;
      eval {
        $stl = ($stl && exists($tb_stl{$stl})) ? $tb_stl{$stl} : q{};
        if ($val->is_array)
        { $val = _merge_arr($val->as_data, $stl);
        }
        elsif ($val->is_hash)
        { $val = _merge_hsh($val->as_data, $stl);
        }
        else
        { $val = _encode($val->as_string, $stl);
        }
        };
      return $val unless $@;
    }
  }
  return defined($dft) ? $dft : q{};
}

=head2 S<$h-E<gt>set_context($blk, $name)>

This method initializes a context for evaluating action code. It deduced the
initialization file name from the specified object identifier by adding a
C<.ctl> suffix to it. It deletes the previous context and it clears previous
test results.

It returns zero when that file has been successfully loaded and executed. It
returns -1 for a missing initialization file, -2 when the initialization file
cannot be opened, 1 for parsing errors, and 2 for execution errors.

=cut

sub set_context
{ my ($slf, $nam) = @_;
  my ($blk, $lng, $val);

  # Delete the previous context
  if ($blk = delete($slf->{'_ctx'}))
  { $blk->set_top('HCVE');
    $blk->set_top('OUT');
    $blk->delete_object;
  }

  # Determine the data collection specification file
  return -1 unless $nam;
  $lng = $slf->{'lng'};
  return -2
    unless ($blk = $lng->find_package($nam, $slf->{'grp'}) ||
                   $lng->load_file($nam, $slf->{'dir'}) ||
                   $lng->search_package($slf->{'grp'}, $nam));
  $lng->detach_package($blk);

  # Load and parse the file
  $blk->set_info('aux', $slf);
  $blk->set_info('lvl', $slf->{'lvl'});
  $blk->set_info('pre', $TRC);
  $blk->load_class($CLS, 1, $CLS);

  # Execute the context initialization
  $slf->{'_ctx'} = $blk;
  $slf->{'_lid'} = [];
  $slf->{'_res'} = {rule => {}};
  $slf->{'_rul'} = q{};
  $slf->{'_tid'} = {};
  eval {$blk->exec};
  if ($@)
  { $slf->add_error($@);
    return 2;
  }
  $blk->set_top('HCVE', $slf);

  # Share the output control
  $blk->set_top('OUT', $val) if ref($val = $slf->{'rpt'});
  return 0;
}

=head2 S<$h-E<gt>set_fact($oid,$xml)>

This method defines a new fact collector. It returns the number of parameters
registered.

=cut

sub set_fact
{ my ($slf, $oid, $xml) = @_;
  my ($cnt, $nam, @tbl);

  $cnt = 0;
  if ($oid && ref($xml) && (@tbl = $xml->find('sdp_command')))
  { $slf->{'_col'}->{$oid} = [@tbl];
    foreach my $itm ($xml->find('sdp_parameters/sdp_parameter'))
    { $nam = $itm->get_value('name', q{});
      next unless $nam =~ m/^((\w+\.)+\w+)$/;
      $slf->{'_map'}->{uc($nam)} = $oid;
      ++$cnt;
    }
  }
  return $cnt;
}

=head2 S<$h-E<gt>set_parameter($nam,$val)>

This method assigns a result to the specified parameter.

=cut

sub set_parameter
{ my ($slf, $nam, $val) = @_;
  my ($key, $ptr, @tbl);

  @tbl = split(/\./, uc($nam));
  return $val unless defined($key = pop(@tbl));
  $ptr = $slf->{'_res'};
  foreach my $itm (@tbl)
  { $ptr->{$itm} = {} unless ref($ptr->{$itm}) eq 'HASH';
    $ptr = $ptr->{$itm};
  }
  return $ptr->{$key} = $val;
}

=head2 S<$h-E<gt>set_result($val)>

This method assigns a result to the specified rule.

=cut

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

  return $slf->{'_res'}->{'rule'}->{$slf->{'_rul'}} = $val;
}

=head2 S<$h-E<gt>set_rule([$rule[,@loop]])>

This method specifies the identifier of the current rule and the current loop
identifiers. It returns the previous rule value. The current values are not
changed if an undefined rule value is specified as an argument.

=cut

sub set_rule
{ my ($slf, $rul, @lid) = @_;
  my ($old);

  $old = $slf->{'_rul'};
  ($slf->{'_rul'}, $slf->{'_lid'}) = ($rul, [@lid]) if defined($rul);
  return $old;
}

=head2 S<$h-E<gt>set_target($type,$tid)>

This method associates a target identifier to the current target. It returns
the hash key, derived from the type and the loop identifiers.

=cut

sub set_target
{ my ($slf, $typ, $tid) = @_;
  my ($tgt);

  $tgt = join('_', $typ, @{$slf->{'_lid'}});
  $slf->{'_tid'}->{$tgt} = $tid;
  return $tgt;
}

=head2 S<$h-E<gt>set_trace([$level])>

This method specifies the trace level for the HCVE code execution. It returns
the previous trace level.

=cut

sub set_trace
{ my ($slf, $lvl) = @_;
  my ($old);

  $old = $slf->{'lvl'};
  if (defined($lvl))
  { $lvl = 0 unless $lvl > 0;  ## no critic (Unless)
    $slf->{'lvl'} = $lvl;
    $slf->{'_ctx'}->init_trace($lvl) if exists($slf->{'_ctx'});
  }
  return $old;
}

=head2 S<$h-E<gt>set_variable($name,...)>

This method shares the action variables with the action evaluation context. The
variables are specified by their name. It returns the number of variables that
have been effectively shared.

=cut

sub set_variable
{ my ($slf, $blk, @nam) = @_;
  my ($cnt, $glb, $loc);

  # Abort if the evaluation context is not available
  return 0 unless exists($slf->{'_ctx'});

  # Share the local variables
  $cnt = 0;
  $glb = $slf->{'_ctx'}->get_context;
  $loc = $blk->get_context;
  foreach my $nam (@nam)
  { next unless $nam =~ m/^[\$\@\%]\w+$/;
    $glb->share_variable($nam, RDA::Value::Pointer->new($loc, $nam));
    ++$cnt;
  }

  # Indicate the number of variables that have been shared
  return $cnt;
}

=head1 ACTION-SPECIFIC COMMANDS

=for stopwords expr

=head2 S<export var,...>

This command shares the action variables with the action evaluation context. The
variables are specified by their name.

=head2 S<result expr>

This command specifies the results of the current rule and returns to the
calling context.

=head2 S<result C,expr>

This command specifies the results of the current rule and continues the rule
execution.

=head2 S<result D,expr>

This command specifies the results of the current rule and terminates the rule.

=head2 S<result R,expr>

This command specifies the results of the current rule and returns to the
calling context.

=cut

sub _get_export
{ my ($slf, $spc, $str, $cmd) = @_;

  $spc->[$SPC_OBJ] = $cmd->[4];
  $slf->get_var_list($spc, $str);
  return;
}

sub _get_result
{ my ($slf, $spc, $str, $cmd) = @_;
  my ($val);

  $spc->[$SPC_OBJ] = $cmd->[4];
  $spc->[$SPC_REF] = ($$str =~ s/^(c(ontinue)?|d(ie)?|r(eturn)?),\s*//i)
    ? uc(substr($1, 0, 1))
    : 'R';
  die get_string('VALUE') unless ($val = $slf->parse_list($str));
  $spc->[$SPC_VAL] = $val;
  return;
}

sub _exe_export
{ my ($slf, $spc) = @_;
  my ($glb, $loc);

  $glb = $spc->[$SPC_OBJ]->{'_ctx'}->{'ctx'};
  $loc = $slf->{'ctx'};
  foreach my $nam (@{$spc->[$SPC_VAL]})
  { $glb->share_variable($nam, RDA::Value::Pointer->new($loc,$nam));
  }
  return 0;
}

sub _exe_result
{ my ($slf, $spc) = @_;
  my ($obj, $val);

  $obj = $spc->[$SPC_OBJ];
  $val = $spc->[$SPC_VAL]->eval_as_line;
  $val =~ s/\n$//;
  $obj->{'_res'}->{'rule'}->{$obj->{'_rul'}} = $val;
  die $DIE_M unless exists($tb_res{$spc->[$SPC_REF]});
  $slf->{'ctx'}->set_internal('val', RDA::Value::Scalar::new_text($val));
  return $tb_res{$spc->[$SPC_REF]};
}

=head1 CHECK-SPECIFIC COMMANDS

=head2 S<$h = RDA::Object::Hcve::new_check($sdcl,$sdsl)>

The check object constructor. It takes references to the SDCL and SDCL language
control objects as arguments.

It is represented by a blessed hash reference. The following special keys are
used:

=over 12

=item S<    B<'dcl' > > Reference to the SDCL language control object

=item S<    B<'dsl' > > Reference to the SDSL language control object

=item S<    B<'err' > > Error buffer

=back

Internal keys are prefixed by an underscore.

=cut

sub new_check
{ my ($dcl, $dsl) = @_;

  return bless {
    err  => [],
    dcl  => $dcl,
    dsl  => $dsl,
    }, __PACKAGE__;
}

=head2 S<$h-E<gt>check_action($nam,$cod)>

This method checks the syntax of the SDCL code. It returns a zero value when
the code is successfully parsed.

=cut

sub check_action
{ my ($slf, $nam, $cod) = @_;
  my ($blk, $cmd);

  # Create the block and add commands
  $blk = RDA::SDCL::Block->new($slf->{'dcl'}, undef, $nam);
  $cmd = $blk->get_info('cmd');
  $cmd->{'export'} = [\&_exe_export, \&_get_export, 0, 0, $slf];
  $cmd->{'result'} = [\&_exe_result, \&_get_result, 0, 0, $slf];

  # Parse the action code
  return $blk->parse(RDA::Handle::Memory->new($cod), [@CLS, $CLS]);
}

=head2 S<$h-E<gt>check_setup($nam,$cod)>

This method checks the syntax of the SDSL code. It returns a zero value when
the code is successfully parsed.

=cut

sub check_setup
{ my ($slf, $nam, $cod) = @_;

  return RDA::SDSL::Module->new($slf->{'dsl'}, undef,
    $nam)->parse(RDA::Handle::Memory->new($cod));
}

=head1 SDCL PROPERTY INTERFACE

=head2 S<$h-E<gt>get_element($mode,$name)>

This method returns the value of the specified parameter as a list.

=cut

sub get_element
{ my ($slf, $mod, $nam) = @_;
  my ($val, @tbl);

  die get_string('BAD_MODE', $mod) unless $mod eq 'V';
  @tbl = split(/\./, $nam);
  $val = $slf->{'_res'};
  foreach my $itm (@tbl)
  { return () unless ref($val) eq 'HASH' && exists($val->{$itm});
    $val = $val->{$itm};
  }
  return ($val);
}

=head2 S<$h-E<gt>set_element($mode,$name,$value)>

This method provides a new value for the specified parameter.

=cut

sub set_element
{ my ($slf, $mod, $nam, $val) = @_;

  die get_string('BAD_MODE', $mod) unless $mod eq 'V';
  return $slf->set_parameter($nam, $val);
}

# --- SDCL extensions ---------------------------------------------------------

# Define a global hash variable
sub _begin_hcve
{ my ($pkg) = @_;

  $pkg->set_top('HCVE', RDA::Object::Hcve->new($pkg));
  return;
}

1;

__END__

=head1 SEE ALSO

L<RDA::Agent|RDA::Agent>,
L<RDA::Error|RDA::Error>,
L<RDA::Handle::Memory|RDA::Handle::Memory>,
L<RDA::Object|RDA::Object>,
L<RDA::Object::Buffer|RDA::Object::Buffer>,
L<RDA::Object::Rda|RDA::Object::Rda>,
L<RDA::SDCL::Block|RDA::SDCL::Block>,
L<RDA::SDCL::Context|RDA::SDCL::Context>,
L<RDA::SDSL::Module|RDA::SDSL::Module>,
L<RDA::Text|RDA::Text>,
L<RDA::Value::Pointer|RDA::Value::Pointer>

=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