# Block.pm: Class Used for Executing SDCL Code

package RDA::SDCL::Block;

# $Id: Block.pm,v 1.47 2015/11/13 15:58:59 RDA Exp $
# ARCS: $Header: /home/cvs/cvs/RDA_8/src/scripting/lib/RDA/SDCL/Block.pm,v 1.47 2015/11/13 15:58:59 RDA Exp $
#
# Change History
# 20151113  MSC  Reduce deletion exception list.

=head1 NAME

RDA::SDCL::Block - Class Used for Executing SDCL Code

=head1 SYNOPSIS

 require RDA::SDCL::Block;

=head1 DESCRIPTION

The objects of the C<RDA::SDCL::Block> class are used to execute Support
Diagnostic Collection Language (SDCL) code.

The following methods are available:

=cut

use strict;

BEGIN
{ use Exporter;
  use IO::File;
  use RDA::Text qw(extract_strings get_string);
  use RDA::Alarm qw(check_alarm clear_alarm set_alarm);
  use RDA::Error;
  use RDA::Handle::Memory;
  use RDA::Object;
  use RDA::Object::Content qw($RE_DC $RE_TST);
  use RDA::Object::Message;
  use RDA::Object::Rda qw($CREATE $TMP_PERMS);
  use RDA::Options;
  use RDA::SDCL::Context;
  use RDA::SDCL::Value qw($VALUE);
  use RDA::Value::Assoc;
  use RDA::Value::Code;
  use RDA::Value::Global;
  use RDA::Value::Hash;
  use RDA::Value::Internal;
  use RDA::Value::List;
  use RDA::Value::Pointer;
  use RDA::Value::Property;
  use RDA::Value::Scalar qw(:die :value new_class new_number new_text);
  use RDA::Value::Variable;
}

# Define the global public variables
use vars qw($STRINGS $VERSION @DUMP @EXPORT_OK @ISA
            $CONT $ERROR $RET_RET $RET_BRK $RET_NXT $RET_DIE
            $SPC_BLK $SPC_COD $SPC_FCT $SPC_LIN $SPC_OBJ $SPC_REF $SPC_VAL);
$VERSION   = sprintf('%d.%02d', q$Revision: 1.47 $ =~ /(\d+)\.(\d+)/);
@EXPORT_OK = qw($CONT $ERROR $RET_RET $RET_BRK $RET_NXT $RET_DIE
                $DIE $DIE_B $DIE_C $DIE_M $DIE_S $DIE_X
                $SPC_BLK $SPC_COD $SPC_FCT $SPC_LIN $SPC_OBJ $SPC_REF $SPC_VAL);
@ISA       = qw(RDA::Error RDA::Object Exporter);

$SPC_FCT = 0; # Associated execution function
$SPC_REF = 1; # Associated reference
$SPC_VAL = 2; # Associated value
$SPC_BLK = 3; # Associated code block
$SPC_LIN = 4; # Source line
$SPC_COD = 5; # Source code
$SPC_OBJ = 6; # Associated object reference

$CONT    = 0;
$ERROR   = -1;
$RET_RET = 1;
$RET_BRK = 2;
$RET_NXT = 3;
$RET_DIE = 4;

# Define the global private constants
my $EXE_FCT = 0; # Execution function
my $GET_FCT = 1; # Parsing function
my $SUB_BLK = 2; # When not null, subblock type
my $TXT_BLK = 3; # 0 = code / 1 or function reference = text

my $ALR = '___Alarm___';
my $DOT = q{.};
my $DSH = q{-};
my $OFF = q{  };
my $TRC = q{TRACE.N_MACRO};
my $UND = q{_};

my $RPT_NXT = qq{.N1\n};
my $RPT_XRF = q{  };

# Define the global private variables
my %tb_cls = (
  TL => undef,
  TM => [qw(RDA::Object::Content
            RDA::Object::Env
            RDA::Object::Rda
            RDA::Object::Target
            RDA::Object::Windows)],
  );
my %tb_cmd = (
  ## no critic (Numbered)
  'alias'    => [undef,           \&_get_alias,    0,   0],
  'append'   => [\&_exe_append,   \&get_var_txt,   'T', \&_merge_txt],
  'break'    => [\&_exe_break,    \&_get_break,    0,   0],
  'calc'     => [\&_exe_calc,     \&_get_value,    0,   0],
  'call'     => [\&_exe_calc,     \&_get_call,     0,   0],
  'code'     => [\&_exe_code,     \&_get_code,     'B', 0],
  'debug'    => [\&_exe_debug,    \&_get_list,     0,   0],
  'decr'     => [\&_exe_calc,     \&_get_decr,     0,   0],
  'define'   => [\&_exe_define,   \&_get_value,    0,   0],
  'delete'   => [\&_exe_calc,     \&_get_delete,   0,   0],
  'die'      => [\&_exe_die,      \&_get_die,      0,   0],
  'dump'     => [\&_exe_dump,     \&_get_list,     0,   0],
  'echo'     => [\&_exe_echo,     \&_get_list,     0,   0],
  'else'     => [\&_exe_else,     \&_get_cond3,    'B', 0],
  'elsif'    => [\&_exe_elsif,    \&_get_cond2,    'B', 0],
  'eval'     => [\&_exe_eval,     \&_get_none,     'E', 0],
  'for'      => [\&_exe_for,      \&_get_for,      'L', 0],
  'global'   => [\&_exe_global,   \&_get_global,   0,   0],
  'if'       => [\&_exe_if,       \&_get_cond1,    'B', 0],
  'import'   => [\&_exe_import,   \&get_var_list,  0,   0],
  'incr'     => [\&_exe_calc,     \&_get_incr,     0,   0],
  'job'      => [\&_exe_job,      \&_get_list,     'F', 0],
  'keep'     => [\&_exe_keep,     \&get_var_list,  0,   0],
  'loop'     => [\&_exe_loop,     \&_get_loop,     'L', 0],
  'macro'    => [\&_exe_macro,    \&_get_name,     'F', 0],
  'next'     => [\&_exe_next,     \&_get_break,    0,   0],
  'once'     => [\&_exe_once,     \&_get_while,    'L', 0],
  'options'  => [undef,           \&_get_options,  0,   0],
  'protect'  => [\&_exe_protect,  \&_get_none,     'E', 0],
  'recover'  => [\&_exe_recover,  \&_get_cond,     0,   0],
  'return'   => [\&_exe_return,   \&_get_value,    0,   0],
  'run'      => [\&_exe_run,      \&_get_run,      0,   0],
  'section'  => [undef,           \&_get_section,  'S', 0],
  'set'      => [\&_exe_set,      \&get_var_txt,   'T', \&_merge_txt],
  'sleep'    => [\&_exe_sleep,    \&_get_value,    0,   0],
  'test'     => [\&_exe_test,     \&_get_run,      0,   0],
  'thread'   => [\&_exe_job,      \&_get_thread,   'F', 0],
  'use'      => [undef,           \&_get_class,    0,   0],
  'var'      => [\&_exe_calc,     \&get_var_def,   0,   0],
  'wait'     => [\&_exe_wait,     \&_get_wait,     0,   0],
  'while'    => [\&_exe_while,    \&_get_while,    'L', 0],
  );
my %tb_del = map {$_ => 1} qw(COL RDA SYS);
my %tb_die = (
  A => $DIE_A,
  B => $DIE_B,
  M => $DIE_M,
  S => $DIE_S,
  x => $DIE_X,
  );
my %tb_int = map {$_ => 1} qw(error last line matches);
my %tb_off = (
  first   => RDA::Value::List->new(new_number(0)),
  second  => RDA::Value::List->new(new_number(1)),
  third   => RDA::Value::List->new(new_number(2)),
  fourth  => RDA::Value::List->new(new_number(3)),
  fifth   => RDA::Value::List->new(new_number(4)),
  sixth   => RDA::Value::List->new(new_number(5)),
  seventh => RDA::Value::List->new(new_number(6)),
  eighth  => RDA::Value::List->new(new_number(7)),
  ninth   => RDA::Value::List->new(new_number(8)),
  tenth   => RDA::Value::List->new(new_number(9)),
  );
my %tb_sct = (
  TL => 'tool',
  TM => 'test',
  );

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

=head2 S<$h = RDA::SDCL::Block-E<gt>new($lang[,$group,$name])>

The object constructor for language package object. It takes the language
object reference, the package name, and the collector object reference as extra
arguments.

=head2 S<$obj-E<gt>new('S',$name)>

The object constructor for code block objects. It takes the section name as an
extra argument.

=head2 S<$obj-E<gt>new($type)>

The object constructor for code block objects.

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

=over 12

=item S<    B<'abr' > > Module abbreviation (P)

=item S<    B<'agt' > > Reference to the agent object (P)

=item S<    B<'als' > > Alias table (P)

=item S<    B<'aux' > > Reference to the associated object (P)

=item S<    B<'beg' > > Start time (P)

=item S<    B<'cls' > > Valid class objects (P)

=item S<    B<'cmd' > > Command parsing hash (P)

=item S<    B<'cnt' > > Module counters (P)

=item S<    B<'ctx' > > Reference to the execution context (P)

=item S<    B<'dbg' > > Debug flag (P)

=item S<    B<'def' > > Reference to the definition item (P)

=item S<    B<'del' > > Delete mode (P)

=item S<    B<'dft' > > Default section execution indicator (P)

=item S<    B<'die' > > Die information (P)

=item S<    B<'dir' > > Package directory (P)

=item S<    B<'err' > > Error buffer (P)

=item S<    B<'glb' > > Valid global variables (P)

=item S<    B<'grp' > > Group restrictions (P)

=item S<    B<'lck' > > Lock control reference (P)

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

=item S<    B<'lvl' > > Trace level (P)

=item S<    B<'nam' > > Data collection module definition name (P)

=item S<    B<'nxt' > > List of next sections to execute (P)

=item S<    B<'oid' > > Object identifier (P,S)

=item S<    B<'opt' > > Switch list (P)

=item S<    B<'out' > > Output suppression indicator (P)

=item S<    B<'pre' > > Trace prefix (P)

=item S<    B<'pro' > > Thread protection indicator (P)

=item S<    B<'sct' > > List of sections already executed (P)

=item S<    B<'shr' > > Shared class hash (P)

=item S<    B<'tim' > > Time limit (P)

=item S<    B<'tst' > > Test module definition name (P)

=item S<    B<'txt' > > Module texts (P)

=item S<    B<'use' > > Use hash (P)

=item S<    B<'val' > > Collect value (P)

=item S<    B<'ver' > > Specification version number (P)

=item S<    B<'_chl'> > List of children (S,*)

=item S<    B<'_cod'> > Associated code block (S,*)

=item S<    B<'_exe'> > Execution sequence (P)

=item S<    B<'_grp'> > Module group (P)

=item S<    B<'_ifc'> > C<if> counter (F,S,*)

=item S<    B<'_ini'> > Initialization indicator (P)

=item S<    B<'_lib'> > Reference to the library driver (P)

=item S<    B<'_lin'> > Current line number in the specification file (P)

=item S<    B<'_lvl'> > Code block level (S,*)

=item S<    B<'_lst'> > Last specification executed (S,*)

=item S<    B<'_nam'> > Loop names (S,*)

=item S<    B<'_par'> > Reference to the parent object (*)

=item S<    B<'_pid'> > Process identifier hash (P)

=item S<    B<'_pkg'> > Reference to the package object (P,S,*)

=item S<    B<'_run'> > Parents of the called shared packages (P)

=item S<    B<'_sct'> > Section hash (P)

=item S<    B<'_thr'> > Thread indicator (P)

=item S<    B<'_trc'> > Macro trace directives (P)

=item S<    B<'_typ'> > Associated code block type (P,S,*)

=item S<    B<'_use'> > Use indicator hash (P)

=back

Internal keys are prefixed by an underscore.

Classes can manage or use following keys:

=over 12

=item S<    B<'ARC' > > Reference to the archive control object (P)

=item S<    B<'CNT' > > Reference to the RDA content object (P)

=item S<    B<'COL' > > Reference to the collector object (P)

=item S<    B<'DSP' > > Reference to the display control object (P)

=item S<    B<'ENV' > > Reference to the environment object (P)

=item S<    B<'HCVE'> > Reference to the HCVE control object (P)

=item S<    B<'IDX' > > Reference to the index control object (P)

=item S<    B<'INC' > > Reference to the inline code control object (P)

=item S<    B<'LIM' > > Reference to the limit control object (P)

=item S<    B<'MRC' > > Reference to the multi-run collection control object (P)

=item S<    B<'OUT' > > Reference to the local reporting control object (P)

=item S<    B<'RDA' > > Reference to the RDA software configuration (P)

=item S<    B<'REM' > > Reference to the remote access control object (P)

=item S<    B<'TGT' > > Reference to the target control object (P)

=item S<    B<'TIM' > > Reference to the timing control object (P)

=item S<    B<'TOC' > > Reference to the table of content object (P)

=item S<    B<'SYS' > > Reference to the system view object (P)

=item S<    B<'WIN' > > Reference to the windows access object (P)

=item S<    B<'XPL' > > Reference to the Oracle Explorer control object (P)

=back

=cut

sub new  ## no critic (Complex)
{ my $obj = shift;
  my ($cls, $slf);

  if ($cls = ref($obj))
  { my ($typ, $nam) = @_;

    if ($typ eq 'S')
    { die get_string('DUP_SECTION', $nam) if exists($obj->{'_sct'}->{$nam});

      # Create the section object
      $slf = bless {
        ctx => $obj->{'ctx'},
        oid => $nam,
        _chl => [],
        _cod => [],
        _ifc => 0,
        _lvl => 0,
        _pkg => $obj,
        _typ => $typ,
        }, $cls;

      # Manage the sections
      die get_string('NO_SECTION') unless $nam;
      $obj->{'_sct'}->{$nam} = $slf;
      push(@{$obj->{'_exe'}}, $nam) unless $nam =~ m/^(\-|begin|end)$/;
    }
    else
    { # Create the code object
      $slf = bless {
        ctx  => $obj->{'ctx'},
        _chl => [],
        _cod => [],
        _ifc => 0,
        _lvl => $obj->{'_lvl'} + 1,
        _par => $obj,
        _pkg => $obj->{'_pkg'},
        _typ => $typ,
        }, $cls;
      push(@{$obj->{'_chl'}}, $slf);

      # Create a dedicate context for macros and classes
      $slf->{'ctx'} = RDA::SDCL::Context->new($obj->{'ctx'})
        if $typ =~ m/^[CF]$/;

      # Propagate loop names
      $slf->{'_nam'} = [@{$obj->{'_nam'}}]
        if exists($obj->{'_nam'}) && $typ ne 'F';
    }
  }
  else
  { my ($lng, $grp, $nam) = @_;
    my ($agt, $col, $oid, $out, $tbl);

    # Assign a default value to missing arguments
    $nam = '_sdcl_' unless defined($nam);

    # Create the package object
    $agt = $lng->get_info('agt');
    $col = $agt->get_collector;
    $out = $agt->get_info('out');
    $slf = bless {
      COL  => $col,
      RDA  => $agt->get_config,
      SYS  => $agt->get_system,
      agt  => $agt,
      als  => {},
      cmd  => {%tb_cmd},
      cls  => {},
      ctx  => RDA::SDCL::Context->new($out),
      dbg  => $agt->is_verbose,
      del  => 0,
      dft  => 0,
      err  => [],
      glb  => {'$[ARG]' => 1},  ## no critic (Interpolation)
      lng  => $lng,
      lvl  => $lng->get_level % 10,
      nxt  => [],
      out  => $out,
      pre  => 'TRACE/',
      pro  => 0,
      use  => {},
      ver  => '0.0',
      _exe => [],
      _grp => $grp,
      _ini => 0,
      _run => {},
      _sct => {},
      _thr => 0,
      _trc => {},
      _typ => 'P',
      _use => {},
      }, $obj;
    $slf->{'_pkg'} = $slf;

    # Detect a data collection module
    if (defined($grp))
    { $slf->{'grp'} = ($grp eq 'RDA') ? [$grp] : [$grp, 'RDA'];
      $slf->{'oid'} = $oid = $grp.q{:}.$nam;
      if ($nam =~ $RE_DC)
      { $slf->{'abr'} = uc($grp.$UND.$3.$UND);
        $slf->{'nam'} = uc($grp.$DOT.$3);
      }
      else
      { $slf->{'def'} = undef;
        $slf->{'tst'} = uc($grp).$DOT.lc($3) if $nam =~ $RE_TST;
      }
    }
    else
    { $slf->{'grp'} = ['RDA'];
      $slf->{'oid'} = $oid = $nam;
    }

    # Load macro trace directives
    if (ref($tbl = $col->get_value($TRC)) eq 'HASH')
    { foreach my $key (keys(%{$tbl}))
      { $slf->{'_trc'}->{$1} = $tbl->{$key} if $key =~ m/^$oid:(\w+)$/;
      }
    }

    # Create a default associated object
    $slf->{'aux'} = $slf;
  }

  # Return the object reference
  return $slf;
}

=head2 S<$h-E<gt>check_die($err)>

This method determines how to handle an abort or a die.

=cut

sub check_die
{ my ($slf, $err) = @_;
  my ($buf, $mod, $msg);

  # Treat a die request
  if ($err =~ $DIE)
  { ($mod, $msg) = ($1, delete($slf->{'die'}));

    # Handle exit request
    if ($mod eq 'x')
    { if ($slf->has_errors)
      { $buf = get_string('ERR_THREAD').$slf->dump_errors.qq{\n};
        syswrite($RDA::Text::TRACE, $buf, length($buf));
      }
      $slf->{'agt'}->delete_object;
      exit(0);
    }

    # Handle die request
    die $msg        if $mod eq 'A';
    return $ERROR   if $mod eq 'B';
    $slf = $slf->get_top;
    $slf->get_display->dsp_line($msg) unless $slf->{'out'};
    return $RET_DIE if $mod eq 'M';
    return $CONT    if $mod eq 'S';
  }

  # Convert it as an error
  return $ERROR;
}

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

This method indicates whether enough free disk space remains. It always
returns zero when the check is disabled or when the reporting control is not
enabled.

=cut

sub check_free
{ my $slf = shift->get_top;

  return exists($slf->{'OUT'}) ? $slf->{'OUT'}->test_free(0, 1) : 0;
}

=head2 S<$h-E<gt>check_lstat($file,@stat)>

This method checks if the file information can be stored in the output control
object.

=cut

sub check_lstat
{ my $slf = shift->get_top;

  $slf->{'OUT'}->add_lstat(@_) if exists($slf->{'OUT'});
  return;
}

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

This method indicates whether quotas are exceeded.

=cut

sub check_quotas
{ my $slf = shift->get_top;
  my ($def);

  # Check quotas
  if (exists($slf->{'nam'}))
  { if (exists($slf->{'tim'}) && time > $slf->{'tim'})
    { $slf->get_collector('sta')->set_value($slf->{'nam'}.'.T_NOT',
        'Time quota exceeded');
      return 1;
    }
    if (exists($slf->{'OUT'}) && $slf->{'OUT'}->check_space < 0)
    { $slf->get_collector('sta')->set_value($slf->{'nam'}.'.T_NOT',
        'Space quota exceeded');
      return 2;
    }
  }

  # Return the current return code
  return 0;
}

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

This method indicates whether report space remains. It always returns zero
when the space quota is disabled or when the reporting control is not enabled.

=cut

sub check_space
{ my $slf = shift->get_top;

  return exists($slf->{'OUT'}) ? $slf->{'OUT'}->check_space : 0;
}

=head2 S<$h-E<gt>check_stat($file,@stat)>

This method checks if the file information can be stored in the output control
object.

=cut

sub check_stat
{ my $slf = shift->get_top;

  $slf->{'OUT'}->add_stat(@_) if exists($slf->{'OUT'});
  return;
}

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

This method indicates whether some time remains. It always returns zero
when the time quota is disabled.

=cut

sub check_time
{ my $slf = shift->get_top;

  return exists($slf->{'tim'}) ? $slf->{'tim'} - time : 0;
}

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

This method defines a new SDCL operator. You can specify multiple operator
names with a name array. It uses the first definition found. It generates an
error when no definitions are found.

=cut

sub define_operator
{ my $slf = shift;

  return $slf->{'_pkg'}->{'lng'}->define_operator(@_);
}

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

This method deletes an object and all subobjects, thus handling circular
references.

=cut

sub delete_object
{ my ($slf) = @_;

  # Delete subobjects
  if (exists($slf->{'cls'}))
  { my ($nam, $obj, $shr, $use, @cls, %nam);

    $slf->dump_caller('BLOCK') if $RDA::Object::DELETE;

    # Prepare the object deletion
    %nam = %tb_del;
    if ($slf->{'del'})
    { $use = $slf->{'use'};
      if (exists($slf->{'shr'}))
      { $shr = $slf->{'shr'}->{'use'};
        @cls = grep {!exists($shr->{$_})} keys(%{$use});

        # Determine the classes to preserve
        foreach my $cls (keys(%{$shr}))
        { $nam{$shr->{$cls}->{'top'}} = 1 if exists($shr->{$cls}->{'top'});
        }
      }
      else
      { @cls = keys(%{$use});
      }

      # Apply pending end treatments
      ## no critic (Reverse)
      foreach my $cls (sort {$use->{$b}->{'rnk'} <=> $use->{$a}->{'rnk'}
        || $b cmp $a} @cls)
      { &{$use->{$cls}->{'end'}}($slf) if exists($use->{$cls}->{'end'});
      }
    }

    # Delete class values
    foreach my $val (values(%{$slf->{'cls'}}))
    { $obj->free
        if ref($obj = $slf->{$nam = $val->as_name}) && !exists($nam{$nam});
    }
  }
  $slf->delete_sections if exists($slf->{'_sct'});
  if (exists($slf->{'_chl'}))
  { foreach my $obj (@{$slf->{'_chl'}})
    { $obj->delete_object;
    }
  }

  # Remove references to other objects and next delete the object
  undef %{$slf};
  undef $slf;
  return;
}

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

This method deletes all code sections.

=cut

sub delete_sections
{ my ($slf) = @_;

  $slf->{'_exe'} = [];
  foreach my $nam (keys(%{$slf->{'_sct'}}))
  { delete($slf->{'_sct'}->{$nam})->delete_object;
  }
  return $slf;
}

=head2 S<$h-E<gt>exec([$error[,$arg[,section,...]]])>

This method executes code sections, all by default.

=cut

sub exec  ## no critic (Builtin,Complex)
{ my ($slf, $txt, $arg, @sct) = @_;
  my ($agt, $col, $ctx, $err, $flg, $nam, $opt, $par, $ret, $shr, $use, $val,
      @cls, @err);

  # Abort the execution if the object is not appropriate
  $agt = $slf->{'agt'};
  $agt->abort(get_string('BAD_BLOCK'))
    unless exists($slf->{'_sct'}) && exists($slf->{'_sct'}->{$DSH});

  # Prepare the block for the execution
  $slf->{'_thr'} = 0;
  $slf->{'_lib'} = exists($slf->{'shr'})
    ? $slf->{'shr'}->{'_lib'}->new
    : $slf->{'lng'}->get_libraries->new
    unless exists($slf->{'_lib'});

  # Determine the trace requirements
  $slf->{'ctx'}->set_trace($slf->{'lvl'});

  # Evaluate the argument list before adjusting the context
  $ret = ref($arg);
  if ($ret =~ $VALUE)
  { $arg = $arg->eval_value;
  }
  elsif ($ret eq 'ARRAY')
  { $opt = RDA::Options::getopts($slf->{'opt'}, $arg) if exists($slf->{'opt'});
    $arg = RDA::Value::List::new_from_data(@{$arg});
  }
  elsif ($ret eq 'HASH')
  { $arg = RDA::Value::Assoc::new_from_data(%{$arg});
  }
  else
  { $arg = undef;
  }

  # Execute the begin treatment for the loaded classes
  unless ($slf->{'_ini'})
  { $use = $slf->{'use'};
    if (exists($slf->{'shr'}))
    { $shr = ($par = $slf->{'shr'})->{'use'};
      foreach my $cls (sort {$shr->{$a}->{'rnk'} <=> $shr->{$b}->{'rnk'}
        || $a cmp $b} keys(%{$shr}))
      { if (exists($shr->{$cls}->{'shr'}))
        { &{$shr->{$cls}->{'shr'}}($slf, $par);
        }
        elsif (exists($shr->{$cls}->{'top'}))
        { $nam = $shr->{$cls}->{'top'};
          $slf->set_top($nam, $par->get_top($nam));
        }
      }
      $slf->{'del'} = 1;
      @cls = grep {!exists($shr->{$_})} keys(%{$use});
    }
    else
    { @cls = keys(%{$use});
    }
    $flg = $slf->{'_use'};
    foreach my $cls (sort {$use->{$a}->{'rnk'} <=> $use->{$b}->{'rnk'}
      || $a cmp $b} @cls)
    { &{$use->{$cls}->{'beg'}}($slf, $flg->{$cls})
        if exists($use->{$cls}->{'beg'});
    }
    $slf->{'_ini'} = 1;
  }

  # Create the execution context and manage recursive calls
  $ctx = $slf->{'ctx'}->push_context($slf);

  # Declare the arguments and the options
  if (ref($arg) =~ $VALUE)
  { if ($arg->is_list)
    { $ctx->set_value('@arg', $arg);               ## no critic (Interpolation)
    }
    else
    { $slf->{'_arg'} = $ctx->set_object('$[ARG]',  ## no critic (Interpolation)
        $arg, 1);
    }
  }
  $ctx->set_value('%opt', RDA::Value::Assoc::new_from_data(%{$opt})) if $opt;

  # Define the time quota when requested
  if (exists($slf->{'nam'}))
  { $col = $slf->get_collector;
    $slf->{'beg'} = time;
    $val = $col->get_first('OUTPUT.B_NO_QUOTA')
      ? 0
      : int($col->get_first('STATUS.'.$slf->{'nam'}.'.N_SEC', 0));
    if ($val > 0)
    { $slf->{'tim'} = $slf->{'beg'} + $val;
    }
    else
    { delete($slf->{'tim'});
    }
  }
  elsif (exists($slf->{'tst'}))
  { $slf->{'beg'} = time;
  }

  # Execute the selected sections
  $err = $agt->switch_context($slf, undef, \&_exec, $slf, $ctx, \@err,
    \&check_die, @sct);

  # Restore the previous context
  $ctx->pop_context($slf);

  # Wait for thread completion
  _exe_wait($slf);

  # Execute the end treatment for the loaded classes
  unless ($slf->{'del'})
  { $use = $slf->{'use'};
    ## no critic (Reverse)
    foreach my $cls (sort {$use->{$b}->{'rnk'} <=> $use->{$a}->{'rnk'}
      || $b cmp $a} keys(%{$use}))
    { &{$use->{$cls}->{'end'}}($slf) if exists($use->{$cls}->{'end'});
    }
  }

  # Remove lock files
  eval {$slf->{'lck'}->end} if exists($slf->{'lck'}) && ref($slf->{'lck'});

  # Merge errors
  if (push(@err, @{$slf->purge_errors}))
  { $agt->abort([@err], $txt || get_string('ERR_EXEC'));
  }
  elsif ($err)
  { $agt->abort;
  }

  # Indicate a successful completion
  return 0;
}

sub _exec  ## no critic (Complex)
{ my ($slf, $ctx, $err, $die, @sct) = @_;
  my ($cnt, $nam, $ret, $sct);

  # Select the sections to execute
  $sct = $slf->{'_sct'};
  $slf->{'sct'} = {map {$_ => 0} @{$slf->{'_exe'}}};
  $slf->{'val'} = undef;
  if (@sct)
  { $slf->{'nxt'} = [];
    foreach my $str (@sct)
    { foreach my $nam (split(/\|/, $str))
      { next unless exists($sct->{$nam})  ## no critic (Unless)
                 && $nam !~ m/^(?:begin|end|\-)$/;
        push(@{$slf->{'nxt'}}, $nam);
        last;
      }
    }
  }
  elsif (@{$slf->{'_exe'}})
  { $slf->{'nxt'} = [@{$slf->{'_exe'}}];
  }
  else
  { $slf->{'nxt'} = [$DSH];
    $slf->{'dft'} = 1;
  }

  # Execute the selected sections
  $cnt = 0;
  $ctx->{'val'} = $VAL_UNDEF;
  if (@{$slf->{'nxt'}})
  { unless ($slf->{'dft'})
    { eval {$ret = $sct->{$DSH}->_exec_block("section '$DSH'")};
      $ret = &{$die}($slf, $@) if $@;
      if ($ret < 0)
      { push(@{$err}, @{$slf->purge_errors});
        ++$cnt;
      }
      $slf->{'dft'} = 1;
      $ctx->{'val'} = $VAL_UNDEF;
    }
    unshift(@{$slf->{'nxt'}}, 'begin') if exists($sct->{'begin'});
    while (defined($nam = shift(@{$slf->{'nxt'}})))
    { next unless exists($sct->{$nam});
      last if $slf->check_quotas;
      $slf->{'sct'}->{$nam} = 1;
      eval {$ret = $sct->{$nam}->_exec_block(qq{section '$nam'})};
      $ret = &{$die}($slf, $@) if $@;
      if ($ret)
      { unless ($ret > 0)  ## no critic (Unless)
        { push(@{$err}, @{$slf->purge_errors});
          ++$cnt;
        }
        last;
      }
    }
    unless ($ret < 0)  ## no critic (Unless)
    { eval {$slf->{'val'} = $ctx->get_internal('val')->eval_as_scalar};
      $ret = &{$die}($slf, $@) if $@;
      if ($ret < 0)
      { push(@{$err}, @{$slf->purge_errors});
        ++$cnt;
      }
    }
    if (exists($sct->{'end'}))
    { $slf->{'sct'}->{'end'} = 1;
      eval {$ret = $sct->{'end'}->_exec_block(q{section 'end'})};
      $ret = &{$die}($slf, $@) if $@;
      if ($ret < 0)
      { push(@{$err}, @{$slf->purge_errors});
        ++$cnt;
      }
    }
  }

  # Return the number of errors
  return $cnt;
}

=head2 S<$h-E<gt>exec_block([$dsc])>

This method executes the block, preserving the last value of its context. It
returns 0 on successful completion, otherwise, the return code.

=cut

sub exec_block
{ my ($slf, $dsc) = @_;
  my ($ret, $old);

  # Check if the block has been deleted
  return 0 unless exists($slf->{'_cod'});

  # Execute the block, preserving the last variable
  $old = $slf->{'ctx'}->{'val'};
  $ret = $slf->_exec_block($dsc);
  $slf->{'ctx'}->{'val'} = $old;
  return $ret;
}

sub _exec_block
{ my ($slf, $dsc, $arg) = @_;
  my ($ctx, $job, $ret, $top, $trc);

  # Determine the trace requirements
  $ctx = $slf->{'ctx'};
  $top = $slf->get_top;
  $trc = $top->{'pre'}.$slf->{'_pkg'}->{'oid'};
  $trc .= "|$job" if ($job = $top->get_collector('job'));
  $ctx->set_prefix($trc);

  # Execute the code block
  $ctx->{'val'} = $VAL_UNDEF;
  if ($ctx->{'trc'})
  { $ctx->trace(qq{Start $dsc});
    $ctx->set_value('@arg', $arg) if ref($arg);  ## no critic (Interpolation)
    eval {$ret = $slf->_exec_code};
    if ($@)
    { $slf->abort_block($@) unless $@ =~ $DIE;
      $ctx->trace(qq{Abort $dsc}) unless $@ eq $DIE_X;
      die $@;
    }
    $ret = $slf->abort_block(get_string('NO_LOOP'))
      if $ret == $RET_NXT || $ret == $RET_BRK;
    $ctx->trace(qq{End $dsc});
  }
  else
  { $ctx->set_value('@arg', $arg) if ref($arg);  ## no critic (Interpolation)
    $ret = $slf->_exec_code;
    $ret = $slf->abort_block(get_string('NO_LOOP'))
      if $ret == $RET_NXT || $ret == $RET_BRK;
  }

  # Return the last return code
  return $ret;
}

=head2 S<$h-E<gt>exec_code($name[,$value])>

This method executes the named block and returns the last value. You can
specify an initial value for the last value.

=cut

sub exec_code
{ my ($slf, $nam, $arg) = @_;
  my ($ctx, $def, $old, $ret, $val);

  # Find the code block definition
  die get_string('CODE_UNKNOWN', $nam)
    unless ($def = $slf->{'ctx'}->find_code($nam));

  # Execute the code block and report errors
  $ctx = $def->{'ctx'};
  $ctx->trace("Start block $nam") if $ctx->{'trc'};

  $old = $ctx->{'val'};
  if (ref($arg))
  { $ctx->set_internal('val', $arg);
  }
  else
  { $ctx->{'val'} = $VAL_UNDEF;
  }
  eval {$ret = $def->_exec_code($slf)};
  $val = exists($def->{'val'}) ? $def->{'val'} : $ctx->{'val'};
  $ctx->{'val'} = $old;

  if ($@)
  { $ctx->trace("Abort block $nam") if $ctx->{'trc'};
    die $@;
  }
  $ret = $slf->abort_block(get_string('NO_LOOP'))
    if $ret == $RET_NXT || $ret == $RET_BRK;
  $ctx->trace("End block $nam") if $ctx->{'trc'};
  $slf->get_agent->abort([$slf->pop_error],get_string('CODE_ERROR', $nam))
    if $ret < 0;

  # Return the last value
  return $val;
}

sub _exec_code
{ my ($slf) = @_;
  my ($ctx, $ret);

  # Execute the code block
  $ctx = $slf->{'ctx'};
  $ret = $CONT;
  eval {
    foreach my $spc (@{$slf->{'_cod'}})
    { $ctx->trace($spc->[$SPC_COD]) if $ctx->{'trc'};
      $slf->{'_lst'} = $spc;
      last if ($ret = &{$spc->[$SPC_FCT]}($slf, $spc));
    }
    };
  return $ret unless $@;

  # Propagate the error
  die $@ if $@ =~ $DIE;
  $slf->abort_block($@);
  die $DIE_B;
}

=head2 S<$h-E<gt>exec_package($parent[,$error,$die[,$arg[,section,...]]])>

This method executes code sections, all by default.

=cut

sub exec_package  ## no critic (Complex)
{ my ($slf, $par, $txt, $die, $arg, @sct) = @_;
  my ($agt, $ctx, $dst, $err, $flg, $nam, $opt, $ret, $src, $use, $top,
      @cls, @err, @var);

  # Abort the execution if the object is not appropriate
  $agt = $slf->{'agt'};
  $agt->abort(get_string('NO_PARENT'))
    unless ref($par);
  $agt->abort(get_string('BAD_BLOCK'))
    unless exists($slf->{'_sct'}) && exists($slf->{'_sct'}->{$DSH});

  # Prepare the block for the execution
  $slf->{'_thr'} = 0;
  $slf->{'_par'} = $par;
  $slf->{'_lib'} = $par->get_lib->new unless exists($slf->{'_lib'});

  # Determine the trace requirements
  $slf->{'ctx'}->set_trace($slf->{'lvl'});

  # Evalue the argument list before adjusting the context
  $arg = (ref($arg) =~ $VALUE) ? $arg->eval_value : undef;

  # Merge classes
  $top = $par->get_top;
  $src = $slf->{'use'};
  $dst = $top->{'use'};
  $flg = $slf->{'_use'};
  @cls = grep {!exists($dst->{$_})} keys(%{$src});
  foreach my $cls (sort {$src->{$a}->{'rnk'} <=> $src->{$b}->{'rnk'}
    || $a cmp $b} @cls)
  { $dst->{$cls} = $src->{$cls};
    &{$src->{$cls}->{'beg'}}($top, $flg->{$cls})
      if exists($src->{$cls}->{'beg'});
  }

  # Validate the global variables
  $src = $slf->{'glb'};
  $dst = $top->{'glb'};
  foreach my $var (keys(%{$src}))
  { next if $src->{$var};
    push (@var, $var) unless exists($dst->{$var});
  }
  $agt->abort([@var], get_string('NO_GLOBAL', $slf->{'oid'})) if @var;

  # Create the execution context and manage recursive calls
  $ctx = $slf->{'ctx'}->push_context($slf, $par->{'ctx'}, $par);

  # Declare the arguments and the options
  if (ref($arg) =~ $VALUE)
  { if ($arg->is_list)
    { $ctx->set_value('@arg', $arg);              ## no critic (Interpolation)
    }
    else
    { $slf->{'_arg'} = $ctx->set_object('$[ARG]', ## no critic (Interpolation)
        $arg, 1);
    }
  }
  $ctx->set_value('%opt', RDA::Value::Assoc::new_from_data(%{$opt})) if $opt;

  # Execute the selected sections
  $err = $agt->switch_context($slf, undef, \&_exec, $slf, $ctx, \@err,
    $die || \&check_die, @sct);

  # Restore the previous context
  $ctx->pop_context($slf, $par);

  # Merge errors
  if (push(@err, @{$slf->purge_errors}))
  { $agt->abort([@err], $txt || get_string('ERR_EXEC'));
  }
  elsif ($err)
  { $agt->abort;
  }

  # Indicate a successful completion
  return 0;
}

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

This method returns a reference to the access control object.

=cut

sub get_access
{ return shift->{'_pkg'}->{'COL'}->get_access(@_);
}

=head2 S<$h-E<gt>get_agent([$name[,$default]])>

This method returns the value of an agent object attribute or the default
value when the attribute is not defined.

It returns a reference to the agent object when no attribute name is specified.

=cut

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

  return defined($nam)
    ? $slf->{'_pkg'}->{'agt'}->get_info($nam, $val)
    : $slf->{'_pkg'}->{'agt'};
}

=head2 S<$h-E<gt>get_collector([$name[,$default]])>

This method returns the value of a collector object attribute or the default
value when the attribute is not defined.

It returns a reference to the collector object when no attribute name is
specified.


=cut

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

  return defined($nam)
    ? $slf->{'_pkg'}->{'COL'}->get_info($nam, $val)
    : $slf->{'_pkg'}->{'COL'};
}

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

It returns a reference to the RDA software configuration object.

=cut

sub get_config
{ return shift->{'_pkg'}->{'RDA'};
}

=head2 S<$h-E<gt>get_context([$name[,$default]])>

This method returns the value of a current execution context object attribute,
or the default value when the attribute is not defined.

It returns a reference to the current execution context object when no
attribute name is specified.

=cut

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

  return defined($nam)
    ? $slf->{'ctx'}->get_info($nam, $val)
    : $slf->{'ctx'};
}

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

This method returns the reference of the current execution package.

=cut

sub get_current
{ return shift->{'ctx'}->get_current;
}

=head2 S<$h-E<gt>get_definition([$mode,$name[,$default]])>

This method returns the item element. It supports the following access modes:

=over 8

=item S<    B<'D'>> Returns the property description using C<get_desc>.

=item S<    B<'I'>> Returns the item object reference using C<find>.

=item S<    B<'P'>> Returns the property value using C<get_property>.

=item S<    B<'T'>> Returns the property value using C<get_text>.

=item S<    B<'V'>> Returns the property value using C<get_value>.

=item S<    B<'i'>> Same as C<I> but creates missing objects.

=item S<    B<'p'>> Same as C<P> but disables the value validation.

=item S<    B<'t'>> Same as C<T> but disables the value validation.

=item S<    B<'v'>> Same as C<V> but disables the value validation.

=back

It returns a reference to the result set definition item when no attribute name
is specified.

=cut

sub get_definition
{ my ($slf, $mod, $nam, $dft) = @_;
  my ($def);

  # Get the group item on first use
  $slf = $slf->get_top;
  $slf->{'def'} = $slf->get_collector('set')->find($slf->{'nam'}, 1)
    unless exists($slf->{'def'});

  # Get the property value
  if (defined($nam))
  { return $def->get_element($mod, $nam, $dft) if ref($def = $slf->{'def'});
    return @{$dft} if wantarray && ref($dft) eq 'ARRAY';
    return $dft;
  }

  # Get the item reference
  return $def if ref($def = $slf->{'def'});
  die get_string('NO_SETUP');
}

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

It returns the directory containing the package specifications.

=cut

sub get_dir
{ my $slf = shift->{'_pkg'};

  return exists($slf->{'dir'})
    ? $slf->{'dir'}
    : $slf->{'RDA'}->get_dir('D_RDA_COL', $slf->{'grp'}->[0]);
}

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

It returns a reference to the display control object.

=cut

sub get_display
{ my $slf = shift->get_top;

  return $slf->{'DSP'} if exists($slf->{'DSP'});
  return $slf->{'DSP'} = $slf->{'agt'}->get_display;
}

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

This method returns a reference to the error buffer.

=cut

sub get_errors
{ return shift->{'_pkg'}->{'err'};
}

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

It returns the group name when applicable.

=cut

sub get_group
{ return shift->get_top('_grp');
}

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

This method returns a reference to the inline code control object.

=cut

sub get_inline
{ my ($slf) = @_;
  my ($cls);

  $slf = $slf->get_top;
  unless (exists($slf->{'INC'}))
  { $cls = 'RDA::Object::Inline';
    load_class($slf, $cls, 0, $cls);
    &{$slf->{'use'}->{$cls}->{'beg'}}($slf, $slf->{'_use'}->{$cls});
  }
  return $slf->{'INC'}
}

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

This method returns a reference to the macro library driver.

=cut

sub get_lib
{ return shift->{'_pkg'}->{'_lib'};
}

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

This method returns a reference to the lock control object.

=cut

sub get_lock
{ my ($slf) = @_;

  $slf = $slf->get_top;
  unless (exists($slf->{'lck'}))
  { eval {
      require RDA::Object::Lock;
      $slf->{'lck'} = RDA::Object::Lock->new($slf->get_agent,
        $slf->get_collector->get_dir('L', 1));
    };
    $slf->{'lck'} = undef if $@;
  }
  return $slf->{'lck'};
}

=head2 S<$h-E<gt>get_method($class,$method)>

This method returns a reference to the method definition.

=cut

sub get_method
{ my ($slf, $cls, $met) = @_;
  my ($use);

  $use = $slf->get_top('use');
  die get_string('UNKNOWN_CLASS', $cls)
    unless exists($use->{$cls});
  die get_string('UNKNOWN_METHOD', $met, $cls)
    unless exists($use->{$cls}->{'met'}->{$met});
  return $use->{$cls}->{'met'}->{$met};
}

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

This method returns a reference to the report control object.

=cut

sub get_output
{ my ($slf, $key, $val) = @_;
  my ($out);

  return $out if ($out = $slf->get_top('OUT'));
  die get_string('NO_OUTPUT');
}

=head2 S<$h-E<gt>get_package([$name[,$default]])>

This method returns the value of a package object attribute or the default
value when the attribute is not defined.

It returns a reference to the package when no attribute name is specified.

=cut

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

  return defined($nam)
    ? $slf->{'_pkg'}->get_info($nam, $val)
    : $slf->{'_pkg'};
}

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

This method returns the reference of the remote session control object.

=cut

sub get_remote
{ my ($slf) = @_;
  my ($cls);

  $slf = $slf->get_top;
  unless (exists($slf->{'REM'}))
  { $cls = 'RDA::Object::Remote';
    load_class($slf, $cls, 0, $cls);
    &{$slf->{'use'}->{$cls}->{'beg'}}($slf, $slf->{'_use'}->{$cls});
  }
  return $slf->{'REM'};
}

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

This method returns a reference to the current report.

=cut

sub get_report
{ return shift->get_output->get_info('cur');
}

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

It returns a reference to the system view object.

=cut

sub get_system
{ return shift->{'_pkg'}->{'SYS'};
}

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

It returns a reference to the thread hash.

=cut

sub get_threads
{ return shift->get_top('_pid');
}

=head2 S<$h-E<gt>get_top([$name[,$default]])>

This method returns the value of a top package object attribute or the default
value when the attribute is not defined.

It returns a reference to the top package when no attribute name is specified.

=cut

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

  $slf = $slf->{'_pkg'};
  while (exists($slf->{'_par'}))
  { $slf = $slf->{'_par'}->{'_pkg'};
  }
  return defined($nam)
    ? $slf->get_info($nam, $val)
    : $slf;
}

=head2 S<$h-E<gt>get_text($key)>

This method returns the translated string associated to the specified key.

=cut

sub get_text
{ my ($slf, $key) = @_;
  my ($tbl);

  # Load the module strings on the first usage
  $slf->{'txt'} = extract_strings(\$tbl, $slf->{'oid'},
    $slf->{'dir'}) unless exists($slf->{'txt'});

  # Return the translated string
  return exists($slf->{'txt'}->{$key}) ? $slf->{'txt'}->{$key} : "<$key>";
}

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

This method returns the version number of the specifications.

=cut

sub get_version
{ return shift->{'ver'};
}

=head2 S<$h-E<gt>parse($ifh[,$classes])>

This method parses the SDCL code from the specified input handle. It closes the
file handle at the end of parsing. It returns the object reference.

=cut

sub parse  ## no critic (Complex)
{ my ($slf, $ifh, $cls) = @_;
  my ($buf, $cmd, $cur, $lin, $nam, $off, $par, $pod, $spc, $sub, $txt, $typ);

  # Load and parse the file
  $slf->{'_lin'} = 0;
  if ($ifh)
  { $lin = q{};
    $pod = $sub = $txt = 0;

    # Initialize the operators
    $slf->{'lng'}->get_operators;

    # Preload default classes
    $cls = $slf->{'lng'}->get_info('cls') unless ref($cls);
    foreach my $pkg (@{$cls})
    { load_class($slf, $pkg, 1, $pkg);
    }

    # Create the top code block
    $cur = $slf->new('S', $DSH);
    $off = $OFF x $cur->{'_lvl'};

    # Treat all lines
    $par = undef;
    while (defined($buf = $ifh->getline))
    { # Trim leading spaces and join continuation lines
      $slf->{'_lin'}++;
      $buf =~ s/^\s+//;
      $buf =~ s/[\r\n]+$//;
      $lin .= $buf;
      next if $lin =~ s/\\$//;
      $lin =~ s/\s+$//;

      # Ignore a documentation block
      if ($pod)
      { $pod = 0 if $lin =~ m/^=cut/;
        $lin = q{};
        next;
      }
      if ($lin =~ m/^=[a-z]/)
      { $pod = 1;
        $lin = q{};
        next;
      }

      # Detect and treat the beginning of a block
      if ($lin =~ s/^\173(\s*)//)
      { # Take text line without other processing
        if ($txt)
        { push(@{$cur->[$SPC_VAL]}, $1.$lin);
          $lin = q{};
          $sub = 0;
          next;
        }

        # Generate an error if a block is not expected
        _add_parse_error($slf, get_string('BAD_START')) unless $sub;

        # Do not limit the block to a single line
        $sub = 0;
      }

      # Treat the line
      if ($lin =~ m/^\175(\s*\#.*)?$/)
      { # Indicate that a code or text block must be closed
        if ($par)
        { $sub = 1;
        }
        else
        { _add_parse_error($slf, get_string('BAD_END'));
        }
      }
      elsif ($txt)
      { # Take all lines without other processing
        $lin =~ s/^["]//;
        push(@{$cur->[$SPC_VAL]}, $lin);
      }
      elsif ($lin !~ m/^#/ && $lin !~ m/^$/)  ## no critic (Fixed)
      { # Create the specification and parse the arguments
        if ($lin =~ s/^(\w+)// && exists($slf->{'cmd'}->{$1}))
        { $cmd = $slf->{'cmd'}->{$1};
          $spc = [$cmd->[$EXE_FCT], undef, undef, undef, $slf->{'_lin'},
            $slf->{'_lin'}.$DOT.$off.$1.$lin];
          $lin =~ s/^\s*//;
        }
        else
        { $cmd = $slf->{'cmd'}->{'calc'};
          $lin = $1.$lin if defined($1);
          $spc = [$cmd->[$EXE_FCT], undef, undef, undef, $slf->{'_lin'},
            $slf->{'_lin'}.$DOT.$off.'[calc] '.$lin];
        }
        eval {&{$cmd->[$GET_FCT]}($cur, $spc, \$lin, $cmd)};
        if ($@)
        { _add_parse_error($slf, $@);
        }
        elsif ($lin !~ m/^(?:#.*)?$/)
        { _add_parse_error($slf, get_string('SYNTAX'));
        }
        $typ = $cmd->[$SUB_BLK];

        # Add the command in the current block
        push(@{$cur->{'_cod'}}, $spc) if $spc->[$SPC_FCT];

        # Prepare the parsing of a subblock
        if ($typ eq 'S')
        { _add_parse_error($slf, get_string('NO_END')) if $par;
          if ($nam = $spc->[$SPC_REF])
          { if (exists($slf->{'_sct'}->{$nam}))
            { _add_parse_error($slf, get_string('DUP_SECTION', $nam));
            }
            else
            { $cur = $slf->new($typ, $spc->[$SPC_REF]);
              $off = $OFF x $cur->{'_lvl'};
            }
          }
        }
        elsif ($typ)
        { $par = $cur;
          if ($txt = $cmd->[$TXT_BLK])
          { $cur = $spc;
            $cur->[$SPC_VAL] = [];
          }
          else
          { $spc->[$SPC_BLK] = $cur = $cur->new($typ);
            $off = $OFF x $cur->{'_lvl'};
            push(@{$cur->{'_nam'}}, $spc->[$SPC_OBJ]) if $typ eq 'L';
          }
          $sub = 2;
        }
      }
      elsif ($lin =~ m/\$[Ii]d\:\s+\S+\s+(\d+)(\.(\d+))?\s/)
      { $slf->{'ver'} = sprintf('%d.%02d', $1, $3 || 0);
      }
      $lin = q{};

      # Check of a subblock must be closed
      if ($sub > 0 && --$sub == 0)
      { # Perform the specified post treatment
        if (ref($txt) eq 'CODE')
        { eval {&$txt($slf, $cur)};
          _add_parse_error($slf, $@) if $@;
        }

        # Return to the previous level
        $txt = 0;
        $cur = $par;
        $off = $OFF x $cur->{'_lvl'};
        $par = exists($cur->{'_par'}) ? $cur->{'_par'} : undef;
      }
    }
    _add_parse_error($slf, get_string('NO_END')) if $par;
    $ifh->close;
  }
  else
  { _add_parse_error($slf, get_string('ERR_OPEN', $slf->{'oid'}, $!));
  }

  # Delete the code when there are errors
  if ($typ = $slf->has_errors)
  { $slf->delete_sections;
    $slf->{'agt'}->abort($slf->purge_errors,
      get_string('ERR_PARSE', $typ, $slf->{'oid'}));
  }

  # Return the object reference
  return $slf;
}

sub _add_parse_error
{ my ($slf, $msg) = @_;

  $msg =~ s/[\n\r\s]+$//;
  $msg = get_string('Syntax', $msg, $slf->{'_lin'})
    if $slf->{'_lin'};
  $slf->add_error($msg);
  return;
}

=head2 S<$h-E<gt>resolve_text($key)>

This method resolves the translated string references in the specified string.

=cut

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

  $str =~ s/\$\<(\w+)\>/$slf->get_text($1)/eg if defined($str);
  return $str;
}

=head2 $h-E<gt>run($name,$arg,$ctx)>

This method executes a data collection or macro code block. You can pass
arguments as a list value.

=cut

sub run
{ my ($slf, $nam, $arg, $blk) = @_;
  my ($bkp, $ctx, $err, $ret);

  # Evalue the argument list before adjusting the context
  $arg = $arg->eval_value if ref($arg);

  # Execute the associated code block
  $ctx = $slf->{'ctx'}->push_context($blk, $blk->{'ctx'});
  $bkp = $ctx->set_trace($slf->{'_pkg'}->{'_trc'}->{$nam})
    if exists($slf->{'_pkg'}->{'_trc'}->{$nam});
  eval {
    $ret = $slf->_exec_block("macro '$nam'", $arg);
    $ret = $ctx->get_internal('val') unless $ret < 0;  ## no critic (Unless)
    };
  $err = $@;
  $ctx->set_trace($bkp) if defined($bkp);
  $ctx->pop_context;

  # Return the error indicator or the last value unless aborted
  return $ret unless $err;

  # Propagate the die
  $blk->{'_pkg'}->{'die'} = $ret
    if defined($ret = delete($slf->{'_pkg'}->{'die'}));
  die $err;
}

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

This method produces a cross-reference of the macro definitions and the macro
and package calls.

=cut

sub xref
{ my ($slf, $aux) = @_;
  my ($buf, $lib, $tbl, $xrf);

  # Analyze the code
  $xrf = {};
  foreach my $sct ($DSH, 'begin', @{$slf->{'_exe'}}, 'end')
  { _xref_code($xrf, $slf->{'_sct'}->{$sct}) if exists($slf->{'_sct'}->{$sct});
  }

  # Analyze auxiliary code
  if (ref($aux) eq 'ARRAY')
  { foreach my $rec (@{$aux})
    { _xref_value($xrf, $rec->[0], $rec->[1]);
    }
  }

  # Display the cross-reference
  $buf = _dsp_name(get_string('Xref', $slf->{'oid'})).$RPT_NXT;

  # List called packages
  $buf .= _dsp($xrf->{'run'}, $xrf->{'run'}, 'XrefRun', \&_lnk_package);

  # Classify the macros
  $lib = $slf->{'lng'}->get_libraries->new;
  foreach my $nam (sort keys(%{$xrf->{'mac'}}))
  { push(@{$xrf->{exists($xrf->{'def'}->{$nam}) ? 'mcl' :
                  $lib->find_macro($nam)        ? 'mcp' :
                                                  'mco'}}, $nam);
  }
  $buf .= _dsp($xrf->{'def'}, $xrf->{'def'}, 'XrefMacrDef');
  $buf .= _dsp($xrf->{'mcl'}, $xrf->{'mac'}, 'XrefCallLocal');
  $buf .= _dsp($xrf->{'mcp'}, $xrf->{'mac'}, 'XrefCallLib');
  $buf .= _dsp($xrf->{'mco'}, $xrf->{'mac'}, 'XrefCallOther');

  # Classify the methods
  foreach my $cls (sort keys(%{$slf->{'use'}}))
  { $tbl = $slf->{'use'}->{$cls};
    foreach my $nam (keys(%{$tbl->{'met'}}))
    { push(@{$xrf->{'mtd'}->{$nam}}, $cls);
    }
    foreach my $nam (keys(%{$tbl->{'als'}}))
    { my ($obj, $met, @arg) = @{$tbl->{'als'}->{$nam}};
      push(@{$xrf->{'ald'}->{$nam}},
        q{``}.$obj.q{->}.$met.q{(}.join(q{,}, @arg, q{...}).q{)``});
    }
  }
  foreach my $nam (sort keys(%{$xrf->{'met'}}))
  { push(@{$xrf->{exists($xrf->{'mtd'}->{$nam}) ? 'mtu' : 'mto'}}, $nam);
  }
  $buf .= _dsp($slf->{'use'}, undef,         'XrefInclude', \&_lnk_api);
  $buf .= _dsp($xrf->{'als'}, $xrf->{'als'}, 'XrefAliaUsage');
  $buf .= _dsp($xrf->{'mtu'}, $xrf->{'met'}, 'XrefMethUsage');
  $buf .= _dsp($xrf->{'prp'}, $xrf->{'prp'}, 'XrefPropUsage');
  $buf .= _dsp($xrf->{'als'}, $xrf->{'ald'}, 'XrefAliaDef');
  $buf .= _dsp($xrf->{'mtu'}, $xrf->{'mtd'}, 'XrefMethDef');
  $buf .= _dsp($xrf->{'mto'}, $xrf->{'met'}, 'XrefMethUnknown');

  # Classify the named blocks
  foreach my $nam (sort keys(%{$xrf->{'cod'}}))
  { push(@{$xrf->{exists($xrf->{'cdd'}->{$nam}) ? 'cdu' : 'cdo'}}, $nam);
  }
  $buf .= _dsp($xrf->{'cdd'}, $xrf->{'cdd'}, 'XrefCodeDef');
  $buf .= _dsp($xrf->{'cdu'}, $xrf->{'cod'}, 'XrefCodeUsage');
  $buf .= _dsp($xrf->{'cdo'}, $xrf->{'cod'}, 'XrefCodeUnknown');

  # Classify the operators
  $buf .= _dsp($xrf->{'opr'}, $xrf->{'opr'}, 'XrefOperUsage');

  # Return the report
  return $buf;
}

# Display a result set
sub _dsp
{ my ($key, $lin, $ttl, $typ) = @_;
  my ($buf, $flg);

  return q{} unless defined($key);
  $key = [sort keys(%{$key})] if ref($key) eq 'HASH';
  return q{} unless @{$key};

  return _dsp_title(get_string($ttl)).($typ
    ? join(q{}, map{_dsp_text($RPT_XRF, &$typ($_))} @{$key})
    : join(q{}, map{_dsp_text($RPT_XRF, qq{``$_``})} @{$key})).$RPT_NXT
    unless defined($lin);

  $buf = _dsp_table(get_string($ttl));
  $flg = $ttl =~ m/Def$/;
  foreach my $nam (@{$key})
  { $buf .= ($typ && $nam !~ m/^<\w+>$/) ? &$typ($nam) : qq{``$nam``};
    $buf .= q{|}.($flg ? join(q{, }, @{$lin->{$nam}})
                       : join(q{, }, sort {$a <=> $b} @{$lin->{$nam}})).qq{\n};
  }
  return $buf.qq{\n}.$RPT_NXT;
}

sub _dsp_name
{ my ($ttl) = @_;

  return qq{.R '$ttl'\n};
}

sub _dsp_text
{ my ($pre, $txt, $nxt) = @_;

  $txt =~ s/\n{2,}/\n\\040\n/g;
  $txt =~ s/(\n|\\n)/\n\n.I '$pre'\n/g;
  return qq{.I '$pre'\n$txt\n\n}.($nxt ? qq{.N $nxt\n} : q{});
}

sub _dsp_table
{ my ($ttl) = @_;

  return qq{.M 2 '$ttl'\n};
}

sub _dsp_title
{ my ($ttl) = @_;

  return qq{.T '$ttl'\n};
}

sub _lnk_api
{ my ($nam) = @_;
  my ($lnk);

  $lnk = $nam;
  $lnk =~ s{::}{/}g;
  return q{!!api:}.$lnk.q{!}.$nam.q{!!};
}

sub _lnk_package
{ my ($nam) = @_;

  $nam =~ m/([^:]*)$/;
  return q{!!run:}.$1.q{!}.$nam.q{!!};  ## no critic (Capture)
}

# Analyse recursively the code
sub _xref_code
{ my ($xrf, $blk) = @_;
  my ($cod, $lin);

  foreach my $spc (@{$blk->{'_cod'}})
  { $lin = $spc->[$SPC_LIN];
    if (defined($spc->[$SPC_REF]))
    { $cod = $spc->[$SPC_COD];
      if ($cod =~ m/^\d+\.\s*code\b/)
      { push(@{$xrf->{'cdd'}->{'SDCL.'.$spc->[$SPC_REF]}}, $lin);
      }
      elsif ($cod =~ m/^\d+\.\s*java\b/)
      { push(@{$xrf->{'cdd'}->{'Java.'.$spc->[$SPC_REF]}}, $lin);
      }
      elsif ($cod =~ m/^\d+\.\s*macro\b/)
      { push(@{$xrf->{'def'}->{$spc->[$SPC_REF]}}, $lin);
      }
      elsif ($cod =~ m/^\d+\.\s*run\b/)
      { if (ref($spc->[$SPC_REF]))
        { push(@{$xrf->{'run'}->{'<Ref>'}}, $lin);
        }
        else
        { my ($nam, $pkg);

          $pkg = $blk->{'_pkg'};
          $nam = $pkg->{'lng'}->norm_package($pkg->{'grp'}, $spc->[$SPC_REF]);
          push(@{$xrf->{'run'}->{defined($nam) ? $nam : $spc->[$SPC_REF]}},
            $lin);
        }
      }
      elsif ($cod =~ m/^\d+\.\s*(append|set)\b/)
      { _xref_set($xrf, $spc->[$SPC_VAL], $lin);
      }
      else
      { _xref_value($xrf, $spc->[$SPC_REF], $lin);
      }
    }
    _xref_value($xrf, $spc->[$SPC_VAL], $lin);
    _xref_code($xrf, $spc->[$SPC_BLK]) if ref($spc->[$SPC_BLK]);
  }
  return;
}

# Analyse append/set text
sub _xref_set
{ my ($xrf, $obj, $lin) = @_;
  my ($val, %tbl);

  $val = $obj->{'val'};
  %tbl = map {$_ => 1}
    $val =~ m/___Macro_(\w+)\050\d+\051___/g,
    $val =~ m/\!\!call\s+(\w+)\050\d+\051\s*$/g,
    $val =~ m/^#\s*CALL\s+(\w+)\050\d+\051\s*$/g,
    $val =~ m/^#\s*MACRO\s+(\w+)\050\d+\051\s*$/g;
  foreach my $nam (keys(%tbl))
  { push(@{$xrf->{'mac'}->{$nam}}, $lin);
  }
  return;
}

# Analyse recursively a value
sub _xref_value  ## no critic (Complex)
{ my ($xrf, $obj, $lin) = @_;
  my ($nam, $ref, $val);

  $ref = ref($obj);
  if ($ref eq 'RDA::Value::Operator')
  { $val = $obj->is_operator;
    if ($val eq '.macro.')
    { $nam = $obj->{'nam'};
      $nam =~ s/^caller://;
      push(@{$xrf->{'mac'}->{$nam}}, $lin);
      _xref_value($xrf, $val, $lin) if ref($val = $obj->{'arg'});
    }
    elsif ($val eq '.method.')
    { if (exists($obj->{'als'}))
      { push(@{$xrf->{'als'}->{$obj->{'als'}}}, $lin);
      }
      else
      { push(@{$xrf->{'met'}->{$obj->{'nam'}}}, $lin);
      }
      _xref_value($xrf, $val, $lin) if ref($val = $obj->{'arg'});
      _xref_value($xrf, $val, $lin) if ref($val = $obj->{'par'});
    }
    else
    { push(@{$xrf->{'opr'}->{$val}}, $lin) if $val !~ m/^\./;
      foreach my $key (keys(%{$obj}))
      { _xref_value($xrf, $obj->{$key}, $lin) unless $key =~ m/^_/;
      }
    }
  }
  elsif ($ref eq 'RDA::Value::Array'
      || $ref eq 'RDA::Value::List'
      || $ref eq 'ARRAY')
  { foreach my $ptr (@{$obj})
    {_xref_value($xrf, $ptr, $lin);
    }
  }
  elsif ($ref eq 'RDA::Value::Assoc'
      || $ref eq 'RDA::Value::Hash'
      || $ref eq 'HASH')
  { foreach my $ptr (values(%{$obj}))
    { _xref_value($xrf, $ptr, $lin);
    }
  }
  elsif ($ref eq 'RDA::Value::Code')
  { if (exists($obj->{'cod'}))
    { _xref_value($xrf, $obj->{'cod'}, $lin)
    }
    else
    { push(@{$xrf->{'cod'}->{$obj->{'lng'}.$DOT.$obj->{'nam'}}}, $lin);
      _xref_value($xrf, $val, $lin) if ref($val = $obj->{'arg'});
    }
  }
  elsif ($ref eq 'RDA::Value::Property')
  { push(@{$xrf->{'prp'}->{($obj->{'grp'} eq $DSH)
      ? $obj->{'nam'} : $obj->{'grp'}.$DOT.$obj->{'nam'}}}, $lin);
    _xref_value($xrf, $val, $lin) if ref($val = $obj->{'dft'});
  }
  return;
}

# --- Parsing routines -------------------------------------------------------

# Get an alias definition
sub _get_alias
{ my ($slf, $spc, $str) = @_;
  my ($nam, $val);

  die get_string('BAD_ALIAS') unless $$str =~ s/^(\w+)\s+//;
  $nam = $1;
  $$str =~ s/=\s*//;
  die get_string('BAD_REPLACE')
    unless ($val = $slf->parse_value($str))->is_method;
  $slf->{'_pkg'}->{'als'}->{$nam} = $val;
  return;
}

# Get a break/next condition
sub _get_break
{ my ($slf, $spc, $str) = @_;
  my ($nam);

  die get_string('NO_LOOP') unless exists($slf->{'_nam'});
  if ($$str =~ s/^\<([A-Za-z]\w+)\>\s*//)
  { $spc->[$SPC_OBJ] = $nam = lc($1);
    die get_string('BAD_LOOP')
      unless grep {$_ eq $nam} @{$slf->{'_nam'}};
  }
  else
  { $spc->[$SPC_OBJ] = $slf->{'_nam'}->[-1];
  }
  $spc->[$SPC_REF] = ($$str =~ s/^(\!\?{0,2}|\?{1,2})\s*//) ? $1 : q{};
  $spc->[$SPC_VAL] = $slf->parse_value($str) || $VAL_ONE;
  return;
}

# Get a macro call
sub _get_call
{ my ($slf, $spc, $str) = @_;
  my ($var);

  die get_string('BAD_CALL')
    unless ref($var = $slf->parse_value($str)) && $var->is_call;
  $spc->[$SPC_VAL] = $var;
  return;
}

# Get a class name
sub _get_class
{ my ($slf, $spc, $str) = @_;

  for (;;)  ## no critic (Loop)
  { if ($$str =~ s/^(RDA::Object::[A-Z]\w+)\s*//i)
    { load_class($slf->{'_pkg'}, $1, 1, $1);
    }
    elsif ($$str =~ s/^([A-Z]\w+)\s*//i)
    { load_class($slf->{'_pkg'}, $1, 1, "RDA::Object::$1");
    }
    elsif ($$str =~ s/(([\$\@\%])\133\w+\135)\s*//)
    { $slf->{'_pkg'}->{'glb'}->{$1} = 0;
    }
    last unless $$str =~ s/^,\s*//;
  }
  return;
}

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

  return
    ($str =~ m/^(\$)\173((\w+\.)*\w+)\175$/) ?
      RDA::Value::Property->new($slf, $1, $2) :
    ($str =~ m/^\$\133\w+\135$/) ?
      RDA::Value::Global->new($slf->{'ctx'}, $str) :
    new_text($str);
}

sub load_class  ## no critic (Complex)
{ my ($slf, $nam, $flg, @cls) = @_;
  my ($dsc, $err, $glb, $ref, $rnk, $tbl, $var);

  foreach my $cls (@cls)
  { if (exists($slf->{'use'}->{$cls}))
    { $dsc = $slf->{'use'}->{$cls};
      if ($flg)
      { $slf->{'_use'}->{$cls} = 1;
        if (exists($dsc->{'top'}))
        { $var = q{$[}.$dsc->{'top'}.q{]};  ## no critic (Interpolation)
          $slf->{'cls'}->{$var} = new_class($slf, $dsc)
            unless exists($slf->{'cls'}->{$var});
        }
      }
      return $dsc;
    }
    eval "require $cls";
    unless ($err = $@)
    { $dsc = {eval "\%${cls}::SDCL"};  ## no critic (Eval)
      die get_string('BAD_OBJECT', $cls, $@) if $@;
      $dsc->{'cls'} = $cls;
      $dsc->{'rnk'} = $rnk = 10;
      $slf->{'use'}->{$cls} = $dsc;
      $slf->{'_use'}->{$cls} = $glb = $dsc->{'flg'} ? 1 : $flg;

      # Treat dependencies
      if (exists($dsc->{'dep'}))
      { foreach my $key (@{$dsc->{'dep'}})
        { $ref = load_class($slf, $key, 0, $key);
          $rnk = $ref->{'rnk'} + 10
            unless $rnk > $ref->{'rnk'};  ## no critic (Unless)
        }
      }

      # Load the synonyms
      if (exists($dsc->{'syn'}))
      { foreach my $key (@{$dsc->{'syn'}})
        { $slf->{'use'}->{$key} = $ref = {%{$dsc}};
          $slf->{'_use'}->{$key} = 0;
          delete($ref->{'beg'});
          delete($ref->{'end'});
        }
      }

      # Extend the syntax
      if (exists($dsc->{'cmd'}))
      { foreach my $key (keys(%{$dsc->{'cmd'}}))
        { $slf->{'cmd'}->{$key} = $dsc->{'cmd'}->{$key};
        }
      }
      $dsc->{'met'} = {} unless ref($dsc->{'met'}) eq 'HASH';
      if ($glb && exists($dsc->{'top'}))
      { $var = q{$[}.$dsc->{'top'}.q{]};  ## no critic (Interpolation)
        $slf->{'cls'}->{$var} = new_class($slf, $dsc)
          unless exists($slf->{'cls'}->{$var});
      }
      if (exists($dsc->{'inc'}))
      { foreach my $key (@{$dsc->{'inc'}})
        { $ref = load_class($slf, $key, 0, $key);
          $rnk = $ref->{'rnk'} + 10
            unless $rnk > $ref->{'rnk'};  ## no critic (Unless)
          foreach my $fct (keys(%{$ref->{'met'}}))
          { $dsc->{'met'}->{$fct} = $ref->{'met'}->{$fct}
              unless exists($dsc->{'met'}->{$fct});
          }
        }
        delete($dsc->{'inc'});
      }

      # Load the aliases
      if (exists($dsc->{'als'}))
      { foreach my $key (keys(%{$dsc->{'als'}}))
        { my ($obj, $met, @arg) = @{$dsc->{'als'}->{$key}};
          $slf->{'als'}->{$key} =
            ($obj =~ m/^(\$)\173((\w+\.)*\w+)\175$/) ?
              $slf->define_operator(['.method.'], $slf,
                RDA::Value::Property->new($slf, $1, $2),
                $met,
                RDA::Value::List->new(map {_load_arg($slf, $_)} @arg)) :
            exists($slf->{'cls'}->{$obj}) ?
              $slf->define_operator(['.method.'], $slf,
                $slf->{'cls'}->{$obj},
                $met,
                RDA::Value::List->new(map {_load_arg($slf, $_)} @arg)) :
            $dsc->{'als'}->{$key};
        }
      }

      # Store the rank
      $dsc->{'rnk'} = $rnk;

      # Treat subclasses
      if (exists($dsc->{'det'}))
      { if (ref($tbl = $dsc->{'det'}) eq 'CODE')
        { foreach my $key (&$tbl($slf))
          { $ref = load_class($slf, $key, 0, $key);
          }
        }
        else
        { foreach my $key (@{$tbl})
          { $ref = load_class($slf, $key, 0, $key);
          }
        }
      }

      # Perform class initialization and return
      &{$dsc->{'use'}}($slf) if exists($dsc->{'use'});
      return $dsc;
    }
  }
  die get_string('UNKNOWN_OBJECT', $nam, $err);
}

# Get a named block declaration
sub _get_code
{ my ($slf, $spc, $str) = @_;

  die get_string('BAD_NAME') unless $$str =~ s/^([A-Za-z]\w*)\s*//;
  $spc->[$SPC_REF] = $1;
  $spc->[$SPC_VAL] = $slf->parse_value($str) if $$str =~ s/=\s*//;
  return;
}

# Get a condition
sub _get_cond
{ my ($slf, $spc, $str) = @_;

  $spc->[$SPC_REF] = ($$str =~ s/^(\!\?{0,2}|\?{1,2})\s*//) ? $1 : q{};
  $spc->[$SPC_VAL] = $slf->parse_value($str) || $VAL_ONE;
  return;
}

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

  $spc->[$SPC_OBJ] = $slf->{'_ifc'} = ++$slf->{'_pkg'}->{'_ifc'};
  $spc->[$SPC_REF] = ($$str =~ s/^(\!\?{0,2}|\?{1,2})\s*//) ? $1 : q{};
  $spc->[$SPC_VAL] = $slf->parse_value($str) || $VAL_ONE;
  return;
}

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

  die get_string('NO_IF') unless $slf->{'_ifc'};
  $spc->[$SPC_OBJ] = $slf->{'_ifc'};
  $spc->[$SPC_REF] = ($$str =~ s/^(\!\?{0,2}|\?{1,2})\s*//) ? $1 : q{};
  $spc->[$SPC_VAL] = $slf->parse_value($str) || $VAL_ONE;
  return;
}

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

  die get_string('NO_IF') unless $slf->{'_ifc'};
  $spc->[$SPC_OBJ] = $slf->{'_ifc'};
  return;
}

# Get a decrement
sub _get_decr
{ my ($slf, $spc, $str) = @_;

  $spc->[$SPC_VAL] = $slf->define_operator(['decr'], $slf, 'decr',
    $slf->parse_list($str));
  return;
}


# Get a variable list for a delete command
sub _get_delete
{ my ($slf, $spc, $str) = @_;

  $spc->[$SPC_VAL] = $slf->define_operator(['delete'], $slf, 'delete',
    $slf->parse_list($str));
  return;
}

# Get the parameters of a 'die' command
sub _get_die
{ my ($slf, $spc, $str) = @_;

  $spc->[$SPC_REF] = ($$str =~ s/^(a(ll)?|m(odule)?|s(ection)?),\s*//i)
    ? uc(substr($1, 0, 1))
    : 'A';
  _get_list(@_);
  return;
}

# Get the parameters of a 'for' command
sub _get_for
{ my ($slf, $spc, $str) = @_;
  my ($cnt, $rec);

  # Get the loop name when present
  $spc->[$SPC_OBJ] = ($$str =~ s/^\<([A-Za-z]\w+)\>\s+//) ? lc($1) : q{};

  # Get the for variable
  die get_string('FOR_VAR')
    unless ($rec = $slf->parse_value($str)) && $rec->is_scalar_lvalue;
  $spc->[$SPC_REF] = $rec;

  # Get the for list
  $spc->[$SPC_VAL] = $rec = $slf->parse_sub_list($str);
  $cnt = @{$rec};
  die get_string('FOR_FORMAT') if $cnt < 2 || $cnt > 3;
  return;
}

# Get a global variable
sub _get_global
{ my ($slf, $spc, $str) = @_;
  my ($typ);

  die get_string('GLOBAL_FORMAT')
    unless $$str =~ s/([\$\@\%]\133\w+\135)\s*//;
  $slf->{'_pkg'}->{'glb'}->{$spc->[$SPC_REF] = $1} = -1;
  $spc->[$SPC_VAL] = $slf->parse_value($str) if $$str =~ s/=\s*//;
  return;
}

# Get an increment
sub _get_incr
{ my ($slf, $spc, $str) = @_;

  $spc->[$SPC_VAL] = $slf->define_operator(['incr'], $slf, 'incr',
    $slf->parse_list($str));
  return;
}

# Get a list
sub _get_list
{ my ($slf, $spc, $str) = @_;

  $spc->[$SPC_VAL] = $slf->parse_list($str);
  return;
}

# Get the parameters of a 'loop' command
sub _get_loop
{ my ($slf, $spc, $str) = @_;
  my ($rec);

  # Get the loop name
  $spc->[$SPC_OBJ] = ($$str =~ s/^\<([A-Za-z]\w+)\>\s*//) ? lc($1) : q{};

  # Get the loop variable
  die get_string('LOOP_VAR')
    unless ($rec = $slf->parse_value($str)) && $rec->is_scalar_lvalue;
  $spc->[$SPC_REF] = $rec;

  # Get the loop list
  $spc->[$SPC_VAL] = $slf->parse_sub_list($str);
  return;
}

# Get a name
sub _get_name
{ my ($slf, $spc, $str) = @_;

  die die get_string('BAD_NAME') unless $$str =~ s/^([A-Za-z]\w*)\s*//;
  $spc->[$SPC_REF] = $1;
  return;
}

# Check that no argument has been provided
sub _get_none
{
}

# Get an option list
sub _get_options
{ my ($slf, $spc, $str) = @_;

  die get_string('BAD_OPTIONS') unless $slf->{'oid'} eq $DSH;
  $slf = $slf->{'_pkg'};
  die get_string('DUP_OPTIONS') if exists($slf->{'opt'});
  $slf->{'opt'} = ($$str =~ s/^'?(([A-Za-z][:\*]?)+)'?\s*//) ? $1 : q{};
  return;
}

# Get a package call
sub _get_run
{ my ($slf, $spc, $str) = @_;

  if ($$str =~ s/^\&\173\s*//)
  { $spc->[$SPC_REF] = $slf->parse_value($str);
    die get_string('BAD_RUN') unless $$str =~ s/^\175\s*//;
  }
  elsif ($$str =~ s/^((\w+\:)?\w+(\-\w+)*)\s*//)
  { $spc->[$SPC_REF] = $1;
  }
  else
  { die get_string('RUN_NAME');
  }
  $spc->[$SPC_VAL] = $slf->parse_sub_list($str);
  return;
}

# Get a section declaration
sub _get_section
{ my ($slf, $spc, $str) = @_;

  die get_string('BAD_NAME') unless $$str =~ s/^([A-Za-z]\w*)\s*//;
  $spc->[$SPC_REF] = $1;
  $slf->{'_pkg'}->{'_lin'} = $1 if $$str =~ s/^(\d+)\s*//;
  return;
}

# Set thread specification
sub _get_thread
{ my ($slf, $spc) = @_;

  $spc->[$SPC_REF] = 1;
  _get_list(@_);
  return;
}

# Get a single value
sub _get_value
{ my ($slf, $spc, $str) = @_;

  $spc->[$SPC_VAL] = $slf->parse_value($str);
  return;
}

# Assemble the lines of a text block
sub _merge_txt
{ my ($slf, $spc) = @_;
  $spc->[$SPC_VAL] = new_text(join(qq{\n}, @{$spc->[$SPC_VAL]}));
  return;
}

# Define or assign a variable or a list of variables
sub get_var_def
{ my ($slf, $spc, $str) = @_;
  my ($rec);

  die get_string('VAR_FORMAT') unless ($rec = $slf->parse_value($str));
  $spc->[$SPC_VAL] = ($rec->is_operator eq '.assign.')
    ? $rec
    : $slf->define_operator(['.assign.'], $rec, $rec->is_scalar_lvalue
        ? $VAL_UNDEF
        : RDA::Value::List->new);
  return;
}

# Get a variable list
sub get_var_list
{ my ($slf, $spc, $str) = @_;
  my @tbl;

  die get_string('BAD_VARIABLE') unless $$str =~ s/^([\$\@\%]\w+)\s*//;
  do
  { push(@tbl, $1);
  } while $$str =~ s/^,\s*([\$\@\%]\w+)\s*//;
  $spc->[$SPC_VAL] = [@tbl];
  return;
}

# Get a variable followed by a text block
sub get_var_txt
{ my ($slf, $spc, $str) = @_;
  my $rec;

  $spc->[$SPC_VAL] = [];
  if (ref($rec = $slf->parse_value($str)))
  { die get_string('BAD_LVALUE') unless $rec->is_scalar_lvalue;
    $spc->[$SPC_REF] = $rec;
    $$str =~ s/^\=?\s*//;
  }
  return;
}

# Get the parameters of a 'wait' command
sub _get_wait
{ my ($slf, $spc, $str) = @_;

  $spc->[$SPC_REF] = ($$str =~ s/^(a(ll)?|u(nprotected)?),\s*//i)
    ? uc(substr($1, 0, 1))
    : 'A';
  $spc->[$SPC_VAL] = $slf->parse_value($str);
  return;
}

# Get a while/once condition
sub _get_while
{ my ($slf, $spc, $str) = @_;

  $spc->[$SPC_OBJ] = ($$str =~ s/^\<([A-Za-z]\w+)\>\s*//) ? lc($1) : q{};
  $spc->[$SPC_REF] = ($$str =~ s/^(\!\?{0,2}|\?{1,2})\s*//) ? $1 : q{};
  $spc->[$SPC_VAL] = $slf->parse_value($str) || $VAL_ONE;
  return;
}

# Parse a list of values between parentheses
sub parse_sub_list
{ my ($slf, $str) = @_;
  my $rec;

  # Get the sublist
  die get_string('START_PARENTHESIS') unless $$str =~ s/^\050\s*//;
  $rec = $slf->parse_list($str, q{)});
  die get_string('END_PARENTHESIS') unless $$str =~ s/^\051\s*//;

  # Return the list
  return $rec;
}

# Parse a list of values
sub parse_list
{ my ($slf, $str, $del) = @_;
  my ($itm, @tbl);

  $del = q{#} unless defined($del);
  if (length($$str) > 0 && substr($$str, 0, 1) ne $del
    && ref($itm = $slf->parse_value($str)))
  { # Get the first list element, merging sublists
    if ($itm->is_list)
    { push(@tbl, @{$itm});
    }
    else
    { push(@tbl, $itm);
    }

    # Get next list elements, merging sublists
    while ($$str =~ s/^\s*(,|=>)\s*//)
    { last unless ref($itm = $slf->parse_value($str));
      if ($itm->is_list)
      { push(@tbl, @{$itm});
      }
      else
      { push(@tbl, $itm);
      }
    }
  }
  return RDA::Value::List->new(@tbl);
}

# Parse a value
sub parse_value  ## no critic (Complex)
{ my ($slf, $str, $del) = @_;
  my ($arg, $mod, $nam, $rec, $typ);

  # Extract a value
  if ($$str =~ s/^'([^\']*)'\s*//)
  { $rec = new_text($1);
  }
  elsif ($$str =~ s/^"([^\"]*)"\s*//)
  { $arg = $slf->resolve_text($1);
    if ($arg =~ m/\$\173.*\175/)
    { $rec = resolve_string($slf, \$arg);
    }
    else
    { $arg =~ s/(\\[0-3][0-7]{2}|\\0x[0-9A-Fa-f]{2})/chr(oct(substr($1,1)))/eg;
      $arg =~ s/\\n/\n/g;
      $rec = new_text($arg);
    }
  }
  elsif ($$str =~ s/^([-+])?(0x[\dA-Fa-f]+)\s*// ||
         $$str =~ s/^([-+])?0o([0-7]+)\s*//)
  { $rec = ($1 && $1 eq $DSH)
      ? new_number(- oct($2))
      : new_number(oct($2));
  }
  elsif ($$str =~ s/^([-+]?\d+(\.\d*)?([eE][\+\-]?\d+)?)\s*//)
  { $rec = new_number(0 + $1);
  }
  elsif ($$str =~ s/^\$([1-9]\d*)\s*//)
  { $rec = $slf->define_operator(['.index.'],
      RDA::Value::Internal->new($slf->{'ctx'}, 'matches'),
      RDA::Value::List->new(new_number($1 - 1)));
  }
  elsif ($$str =~ s/^\$(\w+)\s*\133\s*//)
  { $nam = "\@$1";
    $arg = $slf->parse_list($str, "\135");
    die get_string('NO_INDEX') unless @{$arg};
    $rec = $slf->define_operator(['.index.'],
      RDA::Value::Variable->new($slf->{'ctx'}, $nam), $arg);
    die get_string('BAD_INDEX') unless $$str =~ s/^\135\s*//;
  }
  elsif ($$str =~ s/^\$(\w+)\s*\173\s*//)
  { $nam = "\%$1";
    $arg = $slf->parse_list($str, "\175");
    die get_string('NO_KEY') unless @{$arg};
    $rec = $slf->define_operator(['.key.'],
      RDA::Value::Variable->new($slf->{'ctx'}, $nam), $arg);
    die get_string('BAD_KEY') unless $$str =~ s/^\175\s*//;
  }
  elsif ($$str =~ s/^([\$\@\%]\133\w+\135)\s*//)
  { if (exists($slf->{'_pkg'}->{'cls'}->{$1}))
    { $rec = $slf->{'_pkg'}->{'cls'}->{$1};
    }
    elsif (exists($slf->{'_pkg'}->{'glb'}->{$1}))
    { $rec = RDA::Value::Global->new($slf->{'ctx'}, $1);
    }
    else
    { die get_string('BAD_GLOBAL', $1);
    }
  }
  elsif ($$str =~ s/^\$\173\s*//)
  { $mod = 'V';
    $typ = q{$};
    if ($$str =~ s/^((\w+\/)?(\w+\.)*\w+\.?)(\$)/$4/)
    { $nam = resolve_name($slf, [new_text($1)], $str);
      $mod = $1 if $$str =~ s/^\/\s*([A-Za-z]{1,2})\b\s*//;
      $arg = ($$str =~ s/^:\s*//) ? $slf->parse_value($str, "\175") : undef;
      $rec = RDA::Value::Property->new_dynamic($slf, $typ, $nam, $mod, $arg,
        1, q{});
      die get_string('END_PROPERTY') unless $$str =~ s/^\175\s*//;
    }
    elsif ($$str =~ s/^((\w+\/)?(\w+\.)*[A-Za-z]_\w+)\s*([\/\:\175])/$4/)
    { $nam = $1;
      $mod = $1 if $$str =~ s/^\/\s*([A-Za-z]{1,2})\b\s*//;
      $arg = ($$str =~ s/^:\s*//) ? $slf->parse_value($str, "\175") : undef;
      $rec = RDA::Value::Property->new($slf, $typ, $nam, $mod, $arg);
      die get_string('END_PROPERTY') unless $$str =~ s/^\175\s*//;
    }
    elsif ($$str =~ s/^((\w+\/)?(\w+\.)*\w+)\s*\/\s*([Ii])\s*([\:\175])/$5/)
    { $nam = $1;
      $mod = $4;
      $arg = ($$str =~ s/^:\s*//) ? $slf->parse_value($str, "\175") : undef;
      $rec = RDA::Value::Property->new($slf, $typ, $nam, $mod, $arg);
      die get_string('END_PROPERTY') unless $$str =~ s/^\175\s*//;
    }
    elsif ($$str =~ s/^((\w+\.)*\w+(\(\w+\))?)\s*([\/\:\175])/$4/)
    { $nam = $1;
      $mod = $1 if $$str =~ s/^\/\s*([A-Za-z]{1,2})\b\s*//;
      $arg = ($$str =~ s/^:\s*//) ? $slf->parse_value($str, "\175") : undef;
      $rec = RDA::Value::Property->new($slf, $typ, $nam, $mod, $arg);
      die get_string('END_PROPERTY') unless $$str =~ s/^\175\s*//;
    }
    elsif ($$str =~ s/^\-\.(\$)/$1/)
    { $nam = resolve_name($slf, [], $str);
      $mod = $1 if $$str =~ s/^\/\s*([A-Za-z]{1,2})\b\s*//;
      $arg = ($$str =~ s/^:\s*//) ? $slf->parse_value($str, "\175") : undef;
      $rec = RDA::Value::Property->new_dynamic($slf, $typ, $nam, $mod, $arg,
        1, q{});
      die get_string('END_PROPERTY') unless $$str =~ s/^\175\s*//;
    }
    elsif ($$str =~ s/^<\s*//)
    { $nam = $slf->parse_list($str, q{>});
      die get_string('NO_DYNAMIC') unless @{$nam};
      die get_string('BAD_DYNAMIC') unless $$str =~ s/^>\s*//;
      $mod = $1 if $$str =~ s/^\/\s*([A-Za-z]{1,2})\b\s*//;
      $arg = ($$str =~ s/^:\s*//) ? $slf->parse_value($str, "\175") : undef;
      $rec = RDA::Value::Property->new_dynamic($slf, $typ, $nam, $mod, $arg,
        1);
      die get_string('END_PROPERTY') unless $$str =~ s/^\175\s*//;
    }
  }
  elsif ($$str =~ s/^\@\173\s*//)
  { $mod = 'V';
    $typ = q{@};
    if ($$str =~ s/^last\s*\175\s*//)
    { $rec = $slf->define_operator(['.list.'],
        RDA::Value::Internal->new($slf->{'ctx'}, 'last'));
    }
    elsif ($$str =~ s/^((\w+\/)?(\w+\.)*\w+\.?)(\$)/$4/)
    { $nam = resolve_name($slf, [new_text($1)], $str);
      $mod = $1 if $$str =~ s/^\/\s*([A-Za-z])\b\s*//;
      $arg = ($$str =~ s/^:\s*//) ? $slf->parse_value($str, "\175") : undef;
      $rec = RDA::Value::Property->new_dynamic($slf, $typ, $nam, $mod, $arg,
        1, q{});
      die get_string('END_PROPERTY') unless $$str =~ s/^\175\s*//;
    }
    elsif ($$str =~ s/^((\w+\/)?(\w+\.)*[A-Za-z]_\w+)\s*([\/\:\175])/$4/)
    { $nam = $1;
      $mod = $1 if $$str =~ s/^\/\s*([A-Za-z])\b\s*//;
      $arg = ($$str =~ s/^:\s*//) ? $slf->parse_value($str, "\175") : undef;
      $rec = RDA::Value::Property->new($slf, $typ, $nam, $mod, $arg);
      die get_string('END_PROPERTY') unless $$str =~ s/^\175\s*//;
    }
    elsif ($$str =~ s/^((\w+\.)*\w+)\s*([\/\:\175])/$3/)
    { $nam = $1;
      $mod = $1 if $$str =~ s/^\/\s*([A-Za-z])\b\s*//;
      $arg = ($$str =~ s/^:\s*//) ? $slf->parse_value($str, "\175") : undef;
      $rec = RDA::Value::Property->new($slf, $typ, $nam, $mod, $arg);
      die get_string('END_PROPERTY') unless $$str =~ s/^\175\s*//;
    }
    elsif ($$str =~ s/^\-+\.(\$)/$1/)
    { $nam = resolve_name($slf, [], $str);
      $mod = $1 if $$str =~ s/^\/\s*([A-Za-z])\b\s*//;
      $arg = ($$str =~ s/^:\s*//) ? $slf->parse_value($str, "\175") : undef;
      $rec = RDA::Value::Property->new_dynamic($slf, $typ, $nam, $mod, $arg,
        1, q{});
      die get_string('END_PROPERTY') unless $$str =~ s/^\175\s*//;
    }
    elsif ($$str =~ s/^<\s*//)
    { $nam = $slf->parse_list($str, q{>});
      die get_string('NO_DYNAMIC') unless @{$nam};
      die get_string('BAD_DYNAMIC') unless $$str =~ s/^>\s*//;
      $mod = $1 if $$str =~ s/^\/\s*([A-Za-z])\b\s*//;
      $arg = ($$str =~ s/^:\s*//) ? $slf->parse_value($str, "\175") : undef;
      $rec = RDA::Value::Property->new_dynamic($slf, $typ, $nam, $mod, $arg,
        1);
      die get_string('END_PROPERTY') unless $$str =~ s/^\175\s*//;
    }
    else
    { $rec = $slf->define_operator(['.list.'], $slf->parse_value($str, "\175"));
      die get_string('END_BRACE') unless $$str =~ s/^\175\s*//;
    }
  }
  elsif ($$str =~ s/^\%\173\s*//)
  { $rec = $slf->define_operator(['.hash.'], $slf->parse_value($str, "\175"));
    die get_string('END_BRACE') unless $$str =~ s/^\175\s*//;
  }
  elsif ($$str =~ s/^([\$\@\%]\w+)\s*//)
  { $rec = RDA::Value::Variable->new($slf->{'ctx'}, $1);
  }
  elsif ($$str =~ s/^\\([\$\@\%]\w+)\s*//)
  { $rec = RDA::Value::Pointer->new($slf->{'ctx'}, $1);
  }
  elsif ($$str =~ s/^\&((\w+)\.)?(\w+)\s*(\050(\s*eval:)?\s*)?//)
  { $typ = defined($1) ? $2 : 'SDCL';
    $nam = $3;
    if ($4)
    { $arg = $5;
      $rec = RDA::Value::Code->new($slf, $typ, $nam,
        $slf->parse_list($str, q{)}), $arg);
      die get_string('END_CODE') unless $$str =~ s/^\051\s*//;
    }
    else
    { $rec = RDA::Value::Code->new($slf, $typ, $nam);
    }
  }
  elsif ($$str =~ s/^(\w+)\s*\050\s*//)
  { $nam = $1;
    $arg = $slf->parse_list($str, q{)});
    if (exists($slf->{'_pkg'}->{'als'}->{$nam}))
    { $rec = (ref($rec = $slf->{'_pkg'}->{'als'}->{$nam}) eq 'ARRAY')
        ? $slf->define_operator(['.alias.'], $slf, $rec, $arg)
        : $rec->clone($arg);
      $rec->set_info('als', $nam);
    }
    else
    { $rec = $slf->define_operator([$nam, '.macro.'], $slf, $nam, $arg);
    }
    die get_string('END_MACRO') unless $$str =~ s/^\051\s*//;
  }
  elsif ($$str =~ s/^(caller:\w+)\s*\050\s*//)
  { $nam = $1;
    $arg = $slf->parse_list($str, q{)});
    $rec = $slf->define_operator(['.macro.'], $slf, $nam, $arg);
    die get_string('END_MACRO') unless $$str =~ s/^\051\s*//;
  }
  elsif ($$str =~ s/^(\w+)\s*\=>\s*/,/)
  { $rec = new_text($1);
  }
  elsif ($$str =~ s/^true\s*//)
  { $rec = $VAL_ONE;
  }
  elsif ($$str =~ s/^false\s*//)
  { $rec = $VAL_ZERO;
  }
  elsif ($$str =~ s/^undef\s*//)
  { $rec = $VAL_UNDEF;
  }
  elsif ($$str =~ s/^([a-z]+)\s*//)
  { $nam = $1;
    if (exists($tb_int{$nam}))
    { $rec = RDA::Value::Internal->new($slf->{'ctx'}, $nam);
    }
    elsif (exists($tb_off{$nam}))
    { $rec = RDA::Value::Internal->new($slf->{'ctx'}, 'last');
      $rec = $slf->define_operator(['.array.'], RDA::Value::List->new($rec));
      $rec = $slf->define_operator(['.index.'], $rec, $tb_off{$nam});
    }
    else
    { die get_string('BAD_WORD', $nam);
    }
  }
  elsif ($$str =~ m/^\050/)
  { $rec = $slf->parse_sub_list($str);
  }
  elsif ($$str =~ s/^\133\s*//)
  { $rec = $slf->define_operator(['.array.'], $slf->parse_list($str, "\135"));
    die get_string('END_BRACKET') unless $$str =~ s/^\135\s*//;
  }
  elsif ($$str =~ s/^\173\s*//)
  { $rec = $slf->define_operator(['.assoc.'], $slf->parse_list($str, "\175"));
    die get_string('END_BRACE') unless $$str =~ s/^\175\s*//;
  }
  elsif ($$str !~ m/^(?:#.*)?$/)
  { die get_string('BAD_VALUE');
  }

  # Extract operators
  for (;;)  ## no critic (Loop)
  { if ($$str =~ s/^\-\>\s*\133\s*//)
    { $arg = $slf->parse_list($str, "\135");
      die get_string('NO_INDEX') unless @{$arg};
      $rec = $slf->define_operator(['.index.'], $rec, $arg);
      die get_string('BAD_INDEX')
        unless $$str =~ s/^\135\s*//;
    }
    elsif ($$str =~ s/^\-\>\s*\173\s*//)
    { $arg = $slf->parse_list($str, "\175");
      die get_string('NO_KEY') unless @{$arg};
      $rec = $slf->define_operator(['.key.'], $rec, $arg);
      die get_string('BAD_KEY') unless $$str =~ s/^\175\s*//;
    }
    elsif ($$str =~ s/^\-\>\s*(\w+)\s*\050\s*//)
    { $nam = $1;
      $rec = $slf->define_operator(['.method.'],
        $slf, $rec, $nam, $slf->parse_list($str, q{)}));
      die get_string('END_METHOD') unless $$str =~ s/^\051\s*//;
    }
    elsif ($$str =~ s/^\-\>\s*(\w+)\s*//)
    { $nam = $1;
      $rec = $slf->define_operator(['.method.'],
        $slf, $rec, $nam, RDA::Value::List->new);
    }
    elsif ($$str =~ m/^\=\>\s*/)
    { last;
    }
    elsif ($$str =~ s/^\=\s*//)
    { $rec = $slf->define_operator(['.assign.'], $rec,
        $slf->parse_value($str));
    }
    else
    { last;
    }
  }

  # Return the value found, otherwise, undef
  return $rec;
}

# Resolve property name
sub resolve_name
{ my ($slf, $tbl, $str) = @_;
  my ($dft, $nam, $rec);

  for (;;)  ## no critic (Loop)
  { if ($$str =~ s/^\$\173\s*:\s*//)
    { $dft = $slf->parse_value($str, "\175");
      die get_string('END_PROPERTY')
        unless $$str =~ s/^\175//;
      push(@{$tbl}, $dft);
    }
    elsif ($$str =~ s/^\$\173//)
    { die get_string('BAD_PROPERTY')
        unless $$str =~ s/^((\w+\.)*\w+)\s*([\$\:\175])/$3/;
      $nam = $1;
      if ($3 eq q{$})
      { $nam = resolve_name($slf, [new_text($nam)],
          $str);
        $dft = ($$str =~ s/^:\s*//) ? $slf->parse_value($str, "\175") : undef;
        $rec = RDA::Value::Property->new_dynamic($slf, q{$}, $nam, 'V', $dft,
          1, q{});
      }
      else
      { $dft = ($$str =~ s/^:\s*//) ? $slf->parse_value($str, "\175") : undef;
        $rec = RDA::Value::Property->new($slf, q{$}, $nam, 'V', $dft);
      }
      die get_string('END_PROPERTY')
        unless $$str =~ s/^\175//;
      push(@{$tbl}, $rec);
    }
    elsif ($$str =~ s/^(\.?(\w+\.)*\w+\.?)//)
    { push(@{$tbl}, new_text($1));
    }
    else
    { last;
    }
  }
  return $tbl;
}

# Resolve properties in a string
sub resolve_string
{ my ($slf, $str) = @_;
  my ($dft, $mod, $nam, $rec, $txt, @tbl);

  while ($$str =~ s/^(.*?)(\$\173)(\w|\-\.)/$3/)
  { if (length($txt = $1))
    { $txt =~ s/(\\[0-3][0-7]{2}|\\0x[0-9A-Fa-f]{2})/chr(oct(substr($1,1)))/eg;
      $txt =~ s/\\n/\n/g;
      push(@tbl, new_text($txt));
    }
    if ($$str =~ s/^(([A-Z]+\/)?(\w+\.)*[A-Za-z]_\w+)\s*([\/\:\175])/$4/)
    { $nam = $1;
      $mod = ($$str =~ s/^\/([A-Za-z]{1,2})\s*([\:\175])/$2/) ? $1 : 'V';
      $dft = ($$str =~ s/^:\s*//) ? $slf->parse_value($str, "\175") : undef;
      $rec = RDA::Value::Property->new($slf, q{$}, $nam, $mod, $dft);
    }
    elsif ($$str =~ s/^((\w+\.)*\w+)\s*([\:\175])/$3/)
    { $nam = $1;
      $dft = ($$str =~ s/^:\s*//) ? $slf->parse_value($str, "\175") : undef;
      $rec = RDA::Value::Property->new($slf, q{$}, $nam, 'V', $dft);
    }
    elsif ($$str =~ s/^\-\.(\$)/$1/)
    { $nam = resolve_name($slf, [], $str);
      $dft = ($$str =~ s/^:\s*//) ? $slf->parse_value($str, "\175") : undef;
      $rec = RDA::Value::Property->new_dynamic($slf, q{$}, $nam, 'V', $dft, 1,
        q{});
    }
    elsif ($$str =~ s/^((\w+\.)*\w+\.?)(\$)/$3/)
    { $nam = resolve_name($slf, [new_text($1)], $str);
      $dft = ($$str =~ s/^:\s*//) ? $slf->parse_value($str, "\175") : undef;
      $rec = RDA::Value::Property->new_dynamic($slf, q{$}, $nam, 'V', $dft, 1,
        q{});
    }
    else
    { die get_string('BAD_PROPERTY')
    }
    die get_string('END_PROPERTY')
      unless $$str =~ s/^\175//;
    push(@tbl, $rec);
  }
  if (length($$str))
  { $$str =~ s/(\\[0-3][0-7]{2}|\\0x[0-9A-Fa-f]{2})/chr(oct(substr($1,1)))/eg;
    $$str =~ s/\\n/\n/g;
    push(@tbl, new_text($$str));
    $$str = q{};
  }
  return ((scalar @tbl) > 1)
    ? $slf->define_operator(['concat'], $slf, 'concat',
        RDA::Value::List->new(@tbl))
    : $tbl[0];
}

# --- Execution routines -----------------------------------------------------

# Append a text to a scalar variable
sub _exe_append
{ my ($slf, $spc) = @_;
  my ($txt, $var);

  $var = $spc->[$SPC_REF];
  $txt = join(qq{\n}, $var->eval_as_string, $spc->[$SPC_VAL]->eval_as_string);
  $slf->{'ctx'}->set_internal('val',
    $var->assign_value(new_text($txt), 1));

  # Indicate the successful completion
  return $CONT;
}

# Interrupt a loop
sub _exe_break
{ my ($slf, $spc) = @_;
  my ($ctx, $val);

  $ctx = $slf->{'ctx'};

  # Evaluate the condition
  $val = $ctx->set_internal('val', $spc->[$SPC_VAL]->eval_value(1));
  $val = ($spc->[$SPC_REF] =~ m/\?\?/) ? length($val->as_scalar) :
         ($spc->[$SPC_REF] =~ m/\?/)   ? defined($val->as_scalar) :
                                         $val->as_scalar;
  $val = !$val if $spc->[$SPC_REF] =~ m/\!/;

  # Take the appropriate action
  return $CONT unless $val;
  $ctx->{'nam'} = $spc->[$SPC_OBJ];
  return $RET_BRK;
}

# Evaluate an expression
sub _exe_calc
{ my ($slf, $spc) = @_;

  $slf->{'ctx'}->set_internal('val', $spc->[$SPC_VAL]->eval_value)
    if defined($spc->[$SPC_VAL]);

  # Indicate the successful completion
  return $CONT;
}

# Define a named block
sub _exe_code
{ my ($slf, $spc) = @_;
  my ($blk);

  # Register the named block
  $blk = $spc->[$SPC_BLK];
  $blk->{'val'} = $spc->[$SPC_VAL]->eval_value
    if defined($spc->[$SPC_VAL]);
  $blk->{'ctx'} = $slf->{'ctx'}->set_code($spc->[$SPC_REF], $spc->[$SPC_BLK]);

  # Indicate the successful completion
  return $CONT;
}

# Display some debugging information
sub _exe_debug
{ my ($slf, $spc) = @_;

  # Display the debug information
  $slf = $slf->get_top;
  $slf->get_display->dsp_line($spc->[$SPC_VAL]->eval_as_line, 1)
    if $slf->{'dbg'};

  # Indicate the successful completion
  return $CONT;
}

# Evaluate a definition
sub _exe_define
{ my ($slf, $spc) = @_;

  $spc->[$SPC_VAL]->eval_value if defined($spc->[$SPC_VAL]);

  # Indicate the successful completion
  return $CONT;
}

# Echo some information
sub _exe_die
{ my ($slf, $spc) = @_;
  my ($err);

  # Set the die message and start propagating the die
  $err = $spc->[$SPC_VAL]->eval_value(1);
  $slf->get_package('agt')->add_errors(shift(@{$err})->as_data)
    if ref($err->[0]) eq 'RDA::Value::Array';
  $slf->{'_pkg'}->{'die'} = $err->as_line;
  die $tb_die{$spc->[$SPC_REF]};
}

# Dump some information
sub _exe_dump
{ my ($slf, $spc) = @_;

  # Dump the information
  $slf = $slf->get_top;
  $slf->get_display->dsp_data(join(q{},
    map {$_->as_dump} @{$spc->[$SPC_VAL]->eval_value}).qq{\n})
    unless $slf->{'out'};

  # Indicate the successful completion
  return $CONT;
}

# Echo some information
sub _exe_echo
{ my ($slf, $spc) = @_;

  # Echo the line
  $slf = $slf->get_top;
  $slf->get_display->dsp_line($spc->[$SPC_VAL]->eval_as_line, 1)
    unless $slf->{'out'};

  # Indicate the successful completion
  return $CONT;
}

# Do an if condition
sub _exe_else
{ my ($slf, $spc) = @_;
  my $val;

  # Get the last condition, but prevent further matches
  return $slf->{'ctx'}->end_cond($spc->[$SPC_OBJ])
    ? $CONT
    : $spc->[$SPC_BLK]->_exec_code;
}

# Do an eval
sub _exe_eval
{ my ($slf, $spc) = @_;
  my ($ret);

  # Execute the eval block
  $slf->{'ctx'}->set_internal('err', RDA::Value::List->new);
  eval {$ret = $spc->[$SPC_BLK]->_exec_code($slf)};
  if ($@)
  { die $@ if $@ =~ $DIE && $1 ne 'B';
    $ret = $ERROR;
  }
  return $ret unless $ret < 0;  ## no critic (Unless)

  # Catch errors and restore the previous context
  $slf->{'ctx'}->set_internal('err',
    RDA::Value::List::new_from_data($slf->pop_errors));

  # Indicate the completion status
  return $CONT;
}

# Do an elsif condition
sub _exe_elsif
{ my ($slf, $spc) = @_;
  my ($ctx, $val);

  # Check the last condition
  $ctx = $slf->{'ctx'};
  return $CONT if $ctx->get_cond($spc->[$SPC_OBJ]);

  # Evaluate the condition
  $val = $ctx->set_internal('val', $spc->[$SPC_VAL]->eval_value(1));
  $val = ($spc->[$SPC_REF] =~ m/\?\?/) ? length($val->as_scalar) :
         ($spc->[$SPC_REF] =~ m/\?/)   ? defined($val->as_scalar) :
                                         $val->as_scalar;
  $val = !$val if $spc->[$SPC_REF] =~ m/\!/;
  $ctx->set_cond($spc->[$SPC_OBJ], $val);

  # When fullfilled, execute it
  return $val ? $spc->[$SPC_BLK]->_exec_code : $CONT;
}

# Do a for
sub _exe_for
{ my ($slf, $spc) = @_;
  my ($blk, $ctx, $cur, $inc, $lim, $nam, $ret, $var);

  $ctx = $slf->{'ctx'};
  $blk = $spc->[$SPC_BLK];
  $nam = $spc->[$SPC_OBJ];
  $var = $spc->[$SPC_REF];
  ($cur, $lim, $inc) = @{$spc->[$SPC_VAL]};
  $cur = $cur->eval_as_number;
  $lim = $lim->eval_as_number;
  $inc = defined($inc) ? $inc->eval_as_number : 1;
  if ($inc >= 0)
  { for (; $cur <= $lim ; $cur += $inc)  ## no critic (Loop)
    { # Update the loop variable
      $ctx->set_internal('val',
        $var->assign_value(new_number($cur), 1));

      # Execute the loop iteration
      $ret = $blk->_exec_code;
      if ($ret == $RET_NXT)
      { return $ret unless $nam eq $ctx->{'nam'};
      }
      elsif ($ret == $RET_BRK)
      { return $ret unless $nam eq $ctx->{'nam'};
        last;
      }
      elsif ($ret == $RET_RET || $ret == $ERROR)
      { return $ret;
      }

      # Prepare for the next iteration
      $ctx->trace($spc->[$SPC_COD].' **') if $ctx->{'trc'};
    }
  }
  else
  { for (; $cur >= $lim ; $cur += $inc)  ## no critic (Loop)
    { # Update the loop variable
      $ctx->set_internal('val',
        $var->assign_value(new_number($cur), 1));

      # Execute the loop iteration
      $ret = $blk->_exec_code;
      if ($ret == $RET_NXT)
      { return $ret unless $nam eq $ctx->{'nam'};
      }
      elsif ($ret == $RET_BRK)
      { return $ret unless $nam eq $ctx->{'nam'};
        last;
      }
      elsif ($ret == $RET_RET || $ret == $ERROR)
      { return $ret;
      }

      # Prepare for the next iteration
      $ctx->trace($spc->[$SPC_COD].' **') if $ctx->{'trc'};
    }
  }

  # Indicate the successful completion
  return $CONT;
}

# Define a global variable
sub _exe_global
{ my ($slf, $spc) = @_;
  my ($val, $var);

  # Define a global variable
  $var = $spc->[$SPC_REF];
  if (defined($val = $spc->[$SPC_VAL]))
  { $val = $slf->{'ctx'}->set_internal('val', $val->eval_value);
    $val = RDA::Value::Hash::new_from_list($val->is_list ? [@{$val}] : [$val])
      if $var =~m/^%/;
  }
  $slf->{'ctx'}->set_object($var, $val);

  # Indicate the successful completion
  return $CONT;
}

# Do an if condition
sub _exe_if
{ my ($slf, $spc) = @_;
  my ($ctx, $val);

  # Evaluate the condition
  $ctx = $slf->{'ctx'};
  $val = $ctx->set_internal('val', $spc->[$SPC_VAL]->eval_value(1));
  $val = ($spc->[$SPC_REF] =~ m/\?\?/) ? length($val->as_scalar) :
         ($spc->[$SPC_REF] =~ m/\?/)   ? defined($val->as_scalar) :
                                         $val->as_scalar;
  $val = !$val if $spc->[$SPC_REF] =~ m/\!/;
  $ctx->set_cond($spc->[$SPC_OBJ], $val);

  # When fullfilled, execute it
  return $val ? $spc->[$SPC_BLK]->_exec_code($slf) : $CONT;
}

# Import some variables from upper levels
sub _exe_import
{ my ($slf, $spc) = @_;

  # Import the variables
  $slf->{'ctx'}->import_variables(@{$spc->[$SPC_VAL]});

  # Indicate the successful completion
  return $CONT;
}

# Execute a block in a separate process
sub _exe_job
{ my ($slf, $spc) = @_;
  my ($arg, $col, $flg, $job, $lck, $pid, $top);

  # Start a new job
  $top = $slf->get_top;
  $col = $top->get_collector;
  $job = $col->get_job;

  # Close reports
  $top->{'OUT'}->close if exists($top->{'OUT'});

  # Delete any previous kill announcement
  $arg = $col->prefix_job('.kil');
  1 while unlink($arg);

  # Create a separate process to execute the block
  $arg = $arg->eval_value if defined($arg = $spc->[$SPC_VAL]);
  $flg = $spc->[$SPC_REF];
  $lck = $top->get_lock;
  if (!defined($pid = _fork($top, $flg)))
  { my ($bkp, $buf, $err, $out, $tgt);

    # Prepare the lock context
    eval {$lck->init(0)} if $lck;

    # Execute the block in main process
    delete($top->{'def'});
    $err = $slf->purge_errors;
    $col->suspend($flg);
    $out = _exec_job($slf, $spc->[$SPC_BLK], $arg, $top, $job, $flg, 0);
    $col->resume(1);
    $top->{'_thr'} = -1;
    if ($out)
    { $top->{'OUT'}->load(RDA::Handle::Memory->new($out));
      $top->{'OUT'}->check_free(0);
    }
    delete($top->{'def'});
    if ($slf->has_errors)
    { $buf = get_string('ERR_THREAD').$slf->dump_errors.qq{\n};
      syswrite($RDA::Text::TRACE, $buf, length($buf));
    }
    $slf->purge_errors;
    $slf->add_errors(@{$err});

    # Restore the lock context
    eval {$lck->end(0)} if $lck;
  }
  elsif (!$pid)
  { my ($aux, $fil);

    # Prepare the lock context
    eval {$lck->init($flg)} if $lck;

    # Clear previous transfer files
    if ($flg)
    { $fil = $col->prefix_job(q{_}.$job);
      1 while unlink("$fil.cfg");
      1 while unlink("$fil.out");
      1 while unlink("$fil.pro");
      1 while unlink("$fil.use");
    }

    # Reset libraries requiring thread preparation
    $col->suspend($flg, 1);
    $col->reset_usage;
    $col->set_info('aux', $aux = {
      blk => $slf,
      fil => $fil,
      job => $job,
      lck => $lck,
      top => $top});
    foreach my $lib ($slf->{'_pkg'}->{'lng'}->get_libraries('thread'))
    { $lib->reset;
    }

    # Execute the block in a child process
    $slf->purge_errors;
    $aux->{'buf'} =
      _exec_job($slf, $spc->[$SPC_BLK], $arg, $top, $job, $flg, 1);

    # Terminate the job execution
    $flg ? _end_thread($col) : _end_job($col);
    die $DIE_X;
  }
  elsif ($flg)
  { $top->{'_thr'} = 1;
    $top->{'_pid'}->{$pid} = $job;
  }

  # Indicate the successful completion
  return $CONT;
}

sub _end_job
{ my ($col) = @_;
  my ($lck);

  # Remove lock files
  eval {$lck->end(1)} if ($lck = $col->get_info('aux')->{'lck'});
  return;
}

sub _end_thread
{ my ($col) = @_;
  my ($ctl, $fil, $ofh, $str, $tbl);

  # Initialization
  $ctl = $col->get_info('aux');
  $fil = $ctl->{'fil'};

  # Save the definition changes
  if (($str = $col->extract)
    && ($ofh = IO::File->new)->open("$fil.cfg", $CREATE, $TMP_PERMS))
  { $ofh->syswrite($str, length($str));
    $ofh->close;
  }

  # Save the index and share definitions
  if (($str = $ctl->{'buf'})
    && ($ofh = IO::File->new)->open("$fil.out", $CREATE, $TMP_PERMS))
  { $ofh->syswrite($str, length($str));
    $ofh->close;
  }

  # Save the library usage
  if (($str = $col->extract_usage)
    && ($ofh = IO::File->new)->open("$fil.use", $CREATE, $TMP_PERMS))
  { $ofh->syswrite($str, length($str));
    $ofh->close;
  }

  # Remove lock files
  eval {$ctl->{'lck'}->end(1)} if $ctl->{'lck'};
  return;
}

sub _exec_job
{ my ($slf, $blk, $arg, $top, $job, $flg, $frk) = @_;
  my ($bkp, $buf, $ctx, $dsc, $msg, $out);

  $buf = q{};
  $ctx = $blk->{'ctx'}->push_context($slf, $slf->{'ctx'});
  $dsc = $flg ? 'thread' : 'job';
  $top->{'COL'}->set_job($job);
  $top->{'REM'}->suspend($frk) if exists($top->{'REM'});
  if (exists($top->{'OUT'}))
  { $out = $top->{'OUT'};
    $bkp = $out->suspend($job, $frk);
    eval {$blk->_exec_block($dsc, $arg)};
    if ($@)
    { if ($@ =~ $DIE)
      { $slf->add_error($msg)
          if defined($msg = delete($slf->{'_pkg'}->{'die'}));
      }
      else
      { $slf->abort_block($@);
      }
    }
    $buf = $out->extract if $flg;
    $out->resume($bkp);
  }
  else
  { eval {$blk->_exec_block($dsc, $arg)};
    if ($@)
    { if ($@ =~ $DIE)
      { $slf->add_error($msg)
          if defined($msg = delete($slf->{'_pkg'}->{'die'}));
      }
      else
      { $slf->abort_block($@);
      }
    }
  }
  $ctx->pop_context;
  $top->{'REM'}->resume($frk) if exists($top->{'REM'});
  $top->{'COL'}->clear_job;

  # Return the index and share definitions.
  return $buf;
}

sub _fork
{ my ($top, $typ) = @_;
  my ($flg, $pid);

  # Abort when can't fork
  return unless ($flg = $top->{'RDA'}->can_fork);

  # Create the thread process
  return unless defined($pid = fork());
  unless ($pid)
  { # For a thread or when fork is emulated, a child process is sufficient
    return 0 if $typ || $flg < 0;

    # Make a double fork to have an independant child process
    exit(1) unless defined($pid = fork());
    exit(0) if $pid;
    return 0;
  }

  # Must not wait for a thread or when fork is emulated
  return $pid if $typ || $flg < 0;

  # In the parent process, wait for the grand child process fork
  waitpid($pid, 0);
  return $? ? undef : 1;
}

# Keep some variables
sub _exe_keep
{ my ($slf, $spc) = @_;

  # Keep all variables from the list
  $slf->{'ctx'}->keep_variables(@{$spc->[$SPC_VAL]});

  # Indicate the successful completion
  return $CONT;
}

# Do a loop
sub _exe_loop
{ my ($slf, $spc) = @_;
  my ($blk, $ctx, $nam, $rec, $ret, $var);

  $ctx = $slf->{'ctx'};
  $blk = $spc->[$SPC_BLK];
  $nam = $spc->[$SPC_OBJ];
  $var = $spc->[$SPC_REF];
  $rec = $spc->[$SPC_VAL]->eval_value;
  foreach my $cur (@{$rec})
  { # Update the loop variable
    $ctx->get_internal('val', $var->assign_value($cur, 1));

    # Execute the loop iteration
    $ret = $blk->_exec_code;
    if ($ret == $RET_NXT)
    { return $ret unless $nam eq $ctx->{'nam'};
    }
    elsif ($ret == $RET_BRK)
    { return $ret unless $nam eq $ctx->{'nam'};
      last;
    }
    elsif ($ret == $RET_RET || $ret == $ERROR)
    { return $ret;
    }

    # Prepare for the next iteration
    $ctx->trace($spc->[$SPC_COD].' **') if $ctx->{'trc'};
  }

  # Indicate the successful completion
  return $CONT;
}

# Define a macro
sub _exe_macro
{ my ($slf, $spc) = @_;

  # Register the macro
  $slf->{'_pkg'}->{'_lib'}->define($spc->[$SPC_REF], $spc->[$SPC_BLK]);

  # Indicate the successful completion
  return $CONT;
}

# Interrupt the current loop iteration and start the next one
sub _exe_next
{ my ($slf, $spc) = @_;
  my ($ctx, $val);

  $ctx = $slf->{'ctx'};

  # Evaluate the condition
  $val = $ctx->set_internal('val', $spc->[$SPC_VAL]->eval_value(1));
  $val = ($spc->[$SPC_REF] =~ m/\?\?/) ? length($val->as_scalar) :
         ($spc->[$SPC_REF] =~ m/\?/)   ? defined($val->as_scalar) :
                                         $val->as_scalar;
  $val = !$val if $spc->[$SPC_REF] =~ m/\!/;

  # Take the appropriate action
  return $CONT unless $val;
  $ctx->{'nam'} = $spc->[$SPC_OBJ];
  return $RET_NXT;
}

# Do an once loop
sub _exe_once
{ my ($slf, $spc) = @_;
  my ($blk, $ctx, $ret, $val);

  $blk = $spc->[$SPC_BLK];
  $ctx = $slf->{'ctx'};

  # Evaluate the condition
  $val = $ctx->set_internal('val', $spc->[$SPC_VAL]->eval_value(1));
  $val = ($spc->[$SPC_REF] =~ m/\?\?/) ? length($val->as_scalar) :
         ($spc->[$SPC_REF] =~ m/\?/)   ? defined($val->as_scalar) :
                                         $val->as_scalar;
  $val = !$val if $spc->[$SPC_REF] =~ m/\!/;

  # Execute the loop once
  if ($val)
  { $ret = $blk->_exec_code;
    if ($ret == $RET_NXT || $ret == $RET_BRK)
    { return $ret unless $spc->[$SPC_OBJ] eq $ctx->{'nam'};
    }
    elsif ($ret == $RET_RET || $ret == $ERROR)
    { return $ret;
    }
  }

  # Indicate the successful completion
  return $CONT;
}

# Execute a protected block
sub _exe_protect
{ my ($slf, $spc) = @_;
  my ($col, $err, $job, $kaf, $paf, $ret, $top);

  # Abort when not in thread
  $top = $slf->get_top;
  $col = $top->get_collector;
  die get_string('ERR_PROTECT') unless ($job = $col->get_info('job'));
  die get_string('BAD_PROTECT') if $top->{'pro'};

  # Set the protection
  $kaf = $col->prefix_job('.kil');
  $paf = _touch($col->prefix_job("_$job.pro"));
  die $DIE_X if -f $kaf;

  # Execute the protected block
  $top->{'pro'} = 1;
  eval {$ret = $spc->[$SPC_BLK]->_exec_code($slf)};
  $err = $@;
  $top->{'pro'} = 0;

  # Remove the protection
  1 while unlink($paf);
  die $DIE_X if -f $kaf;

  # Indicate the completion status
  return $ret unless $err;
  die $err if $err =~ $DIE && $1 ne 'B';
  return $ERROR;
}

sub _touch
{ my ($fil) = @_;
  my ($ofh);

  $ofh = IO::File->new;
  $ofh->open($fil, $CREATE, $TMP_PERMS) && $ofh->close;
  return $fil;
}

# Recover aborted threads
sub _exe_recover
{ my ($slf, $spc) = @_;
  my ($val);

  # Evaluate the condition
  $val = $slf->{'ctx'}->set_internal('val', $spc->[$SPC_VAL]->eval_value(1));
  $val = ($spc->[$SPC_REF] =~ m/\?\?/) ? length($val->as_scalar) :
         ($spc->[$SPC_REF] =~ m/\?/)   ? defined($val->as_scalar) :
                                         $val->as_scalar;
  $val = !$val if $spc->[$SPC_REF] =~ m/\!/;

  # When fullfilled, execute it
  $slf->get_collector->load_job($val ? 'rec' : 'clr');

  # Indicate the successful completion
  return $CONT;
}

# Terminate the current context execution
sub _exe_return
{ my ($slf, $spc) = @_;

  $slf->{'ctx'}->set_internal('val', $spc->[$SPC_VAL]->eval_value)
    if defined($spc->[$SPC_VAL]);

  # Return to the previous context
  return $RET_RET;
}

# Execute a package
sub _exe_run  ## no critic (Complex)
{ my ($slf, $spc) = @_;
  my ($agt, $blk, $err, $lng, $nam, $obj, $pkg, $ret, $tbl, @sct);

  # Load the block
  $nam = $nam->eval_as_string if ref($nam = $spc->[$SPC_REF]);
  ($nam, @sct) = split(/\-/, $nam);
  return $CONT unless defined($nam) && length($nam);
  $pkg = $slf->{'_pkg'};
  $agt = $pkg->{'agt'};
  $lng = $pkg->{'lng'};
  eval {
    if ($blk = $lng->find_package($nam, $pkg->{'grp'}))
    { $pkg->{'_run'}->{$nam} = $blk->{'_par'}
        if exists($pkg->{'_run'}) && exists($blk->{'_par'});
      $blk->{'_run'} = {};
    }
    else
    { $blk = exists($pkg->{'dir'})
        ? $lng->load_file($nam, $pkg->{'dir'})
        : $lng->search_package($pkg->{'grp'}, $nam);
    }
    };
  if ($@)
  { die $@ if $@ =~ $DIE;
    $agt->abort($@, get_string('ERR_RUN', $nam));
  }
  $agt->abort(get_string('NO_PACKAGE', $nam)) unless defined($blk);

  # Execute the associated code block
  delete($blk->{'_lib'});
  eval {$ret = $blk->exec_package($slf, get_string('ERR_RUN', $nam),
    \&_check_run_die, $spc->[$SPC_VAL], @sct)};

  # Propagate a die
  if ($@)
  { $err = $agt->last_error;
    die $@ unless $err =~ $DIE;
    $agt->pop_error;
    $pkg->{'die'} = $blk->{'_pkg'}->{'die'};
    die $err;
  }

  # Keep or free the block memory
  if ($blk->{'ctx'}->check_variable('$KEEP_BLOCK')) ## no critic (Interpolation)
  { delete($blk->{'_run'});
    $lng->keep_package($blk);
  }
  else
  { # Resynchronize the calling block
    $obj = $slf->get_top;
    $obj->{'OUT'}->deprefix($blk) if exists($obj->{'OUT'});

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

    # Delete the block
    $lng->remove_package($blk);
  }

  # Propagate any error
  $agt->abort([$pkg->pop_error], get_string('ERR_RUN', $nam)) if $ret;

  # Indicate the successful completion
  return $CONT;
}

sub _check_run_die
{ my ($slf, $err) = @_;

  die $err if $err =~ $DIE && $1 ne 'B';
  return $ERROR;
}

# Assign a text to a scalar variable
sub _exe_set
{ my ($slf, $spc) = @_;

  $slf->{'ctx'}->set_internal('val',
    $spc->[$SPC_REF]->assign_value($spc->[$SPC_VAL]));

  # Indicate the successful completion
  return $CONT;
}

# Suspend the data collection
sub _exe_sleep
{ my ($slf, $spc) = @_;
  my $val;

  $val = defined($spc->[$SPC_VAL])
    ? $slf->{'ctx'}->set_internal('val',
                                  $spc->[$SPC_VAL]->eval_value)->as_number
    : 1;
  eval "sleep($val)" if $val > 0;  ## no critic (Eval)

  # Indicate the successful completion
  return $CONT;
}

# Execute a test package
sub _exe_test
{ my ($slf, $spc) = @_;
  my ($blk, $cls, $col, $lib, $lng, $nam, $pkg, $ret, $sct, $tgt, $yes,
      @sct, %bkp);

  # Validate the package name
  $nam = $nam->eval_as_string if ref($nam = $spc->[$SPC_REF]);
  ($nam, @sct) = split(/\-/, $nam);
  return $CONT unless defined($nam) && length($nam);
  die get_string('BAD_TEST', $nam) unless $nam =~ $RE_TST;
  $cls = $tb_cls{$3};
  push(@sct, $tb_sct{$3}) unless @sct;

  # Load the block
  $pkg = $slf->{'_pkg'};
  $lng = $pkg->{'lng'};
  $col = $pkg->get_collector;
  eval {$blk = exists($pkg->{'dir'})
    ? $lng->load_file($nam, $pkg->{'dir'}, $cls)
    : $lng->search_package($pkg->{'grp'}, $nam, $cls)};
  $pkg->{'agt'}->abort($@, get_string('ERR_TEST', $nam)) if $@;
  $pkg->{'agt'}->abort('NO_PACKAGE', $nam) unless defined($blk);

  # Execute the associated code block
  $tgt = $col->get_target;
  $bkp{'tgt'} = $tgt->suspend;
  $bkp{'lib'} = $lng->suspend;
  $col->suspend;
  $yes = $col->set_isolated(1);
  $col->get_info('run')->set_value('TEST.M_CALLER', $pkg->get_oid);
  $blk->{'dbg'} = $pkg->{'dbg'};
  $blk->{'lvl'} = $col->get_trace('TEST') unless $pkg->{'out'};
  $ret = $blk->exec(get_string('ERR_TEST', $nam),
    [grep {defined($_) && !ref($_)} $spc->[$SPC_VAL]->eval_as_array],
    @sct);
  $sct = $blk->get_info('sct', {});
  $col->log('T', $nam, $blk->get_version, $ret,
    join(q{,}, grep {$sct->{$_} > 0} keys(%{$sct})));
  $col->resume;
  $lng->resume($bkp{'lib'});
  $tgt->resume($bkp{'tgt'});

  # Delete the block
  $lng->remove_package($blk);

  # Propagate any error
  $pkg->{'agt'}->abort([$pkg->pop_error], get_string('ERR_TEST', $nam))
    if $ret;

  # Indicate the successful completion
  return $CONT;
}

# Wait that all threads execution is complete
sub _exe_wait  ## no critic (Complex)
{ my ($slf, $spc) = @_;
  my ($cnt, $lck, $kaf, $lim, $pid, $pre, $tbl, $top);

  # Wait for thread completion
  $top = $slf->get_top;
  if ($top->{'_thr'} > 0)
  { # Wait for thread completion within the specified limit
    $lim = (defined($spc) && defined($lim = $spc->[$SPC_VAL]))
      ? check_alarm($lim->eval_as_number)
      : 0;
    $tbl = delete($top->{'_pid'});
    eval {
      # Set the alarm
      local $SIG{'__WARN__'} = sub {};
      local $SIG{'ALRM'}     = sub { die "$ALR\n" } if $lim;

      set_alarm($lim) if $lim;

      # Wait until the thread lock can be get
      eval {
        sleep(1);
        $lck->wait if ($lck = $top->get_lock);
        };
      die $@ if $@ =~ m/^$ALR\n/;

      # Wait for thread completion
      foreach my $pid (keys(%{$tbl}))
      { waitpid($pid, 0);
        delete($tbl->{$pid});
      }

      # Disable the alarm
      clear_alarm() if $lim;
      };

    # Kill the remaining processes after a timeout
    if ($@ =~ m/^$ALR\n/)
    { # Produce the kill announcement
      $pre = $top->get_collector->prefix_job(q{});
      $kaf = "$pre.kil";

      if ($spc->[$SPC_REF] eq 'U')
      { # Kill unprotected threads
        _touch("$pre.kil");
        foreach my $pid (keys(%{$tbl}))
        { if (-f ($pre.'_'.$tbl->{$pid}.'.pro'))
          { $top->{'_pid'}->{$pid} = delete($tbl->{$pid});
            ++$cnt;
          }
          else
          { RDA::Object::Rda->kill_child($pid);
          }
        }
      }
      else
      { # Kill all threads
        foreach my $pid (keys(%{$tbl}))
        { RDA::Object::Rda->kill_child($pid)
        }
      }

      # Remove processes from the process table
      foreach my $pid (keys(%{$tbl}))
      { waitpid($pid, 0);
      }

      # Remove the kill announcement when there are no remaining threads
      unless ($cnt)
      { 1 while unlink($kaf);
      }
    }

    # Consolidate the thread results
    $top->{'COL'}->load_job('end', $top->{'OUT'});
  }
  $top->{'_thr'} = 0 unless $cnt;

  # Indicate the successful completion
  return $CONT;
}

# Do a while loop
sub _exe_while
{ my ($slf, $spc) = @_;
  my ($blk, $ctx, $nam, $ret, $val);

  $blk = $spc->[$SPC_BLK];
  $ctx = $slf->{'ctx'};
  $nam = $spc->[$SPC_OBJ];
  for (;;)  ## no critic (Loop)
  { # Evaluate the condition
    $val = $ctx->set_internal('val', $spc->[$SPC_VAL]->eval_value(1));
    $val = ($spc->[$SPC_REF] =~ m/\?\?/) ? length($val->as_scalar) :
           ($spc->[$SPC_REF] =~ m/\?/)   ? defined($val->as_scalar) :
                                           $val->as_scalar;
    $val = !$val if $spc->[$SPC_REF] =~ m/\!/;
    last unless $val;

    # Execute the loop iteration
    $ret = $blk->_exec_code;
    if ($ret == $RET_NXT)
    { return $ret unless $nam eq $ctx->{'nam'};
    }
    elsif ($ret == $RET_BRK)
    { return $ret unless $nam eq $ctx->{'nam'};
      last;
    }
    elsif ($ret == $RET_RET || $ret == $ERROR)
    { return $ret;
    }

    # Prepare for the next iteration
    $ctx->trace($spc->[$SPC_COD].' **') if $ctx->{'trc'};
  }

  # Indicate the successful completion
  return $CONT;
}

=head1 ERROR METHODS

=head2 S<$h-E<gt>abort_block($text)>

This method stacks the triggering error in the error buffer and aborts the
block execution using the specified error.

=cut

sub abort_block
{ my ($slf, $txt) = @_;
  my ($pkg);

  $pkg = $slf->{'_pkg'};
  $pkg->get_agent->add_error($txt)->alter_error('Sdcl', $pkg->{'oid'},
    $slf->{'_lst'}->[$SPC_LIN]);
  return $ERROR;
}

=head1 AUXILIARY OBJECT METHODS

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

This method returns an empty list.

=cut

sub get_element
{ return ();
}

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

This method generates an error.

=cut

sub set_element
{ die get_string('NO_AUX');
}

1;

__END__

=head1 SEE ALSO

L<RDA::Agent|RDA::Agent>,
L<RDA::Error|RDA::Error>,
L<RDA::Handle::Memory|RDA::Handle::Memory>,
L<RDA::Library::Admin|RDA::Library::Admin>,
L<RDA::Library::Archive|RDA::Library::Archive>,
L<RDA::Library::Buffer|RDA::Library::Buffer>,
L<RDA::Library::Data|RDA::Library::Data>,
L<RDA::Library::Db|RDA::Library::Db>,
L<RDA::Library::Dbi|RDA::Library::Dbi>,
L<RDA::Library::Expr|RDA::Library::Expr>,
L<RDA::Library::File|RDA::Library::File>,
L<RDA::Library::Ftp|RDA::Library::Ftp>,
L<RDA::Library::Html|RDA::Library::Html>,
L<RDA::Library::Http|RDA::Library::Http>,
L<RDA::Library::Product|RDA::Library::Product>,
L<RDA::Library::Remote|RDA::Library::Remote>,
L<RDA::Library::Remote::Unix|RDA::Library::Remote::Unix>,
L<RDA::Library::String|RDA::Library::String>,
L<RDA::Library::Table|RDA::Library::Table>,
L<RDA::Library::Temp|RDA::Library::Temp>,
L<RDA::Library::Value|RDA::Library::Value>,
L<RDA::Library::Windows|RDA::Library::Windows>,
L<RDA::Library::Xml|RDA::Library::Xml>,
L<RDA::Object|RDA::Object>,
L<RDA::Object::Access|RDA::Object::Access>,
L<RDA::Object::Archive|RDA::Object::Archive>,
L<RDA::Object::Buffer|RDA::Object::Buffer>,
L<RDA::Object::Collect|RDA::Object::Collect>,
L<RDA::Object::Content|RDA::Object::Content>,
L<RDA::Object::Cookie|RDA::Object::Cookie>,
L<RDA::Object::Display|RDA::Object::Display>,
L<RDA::Object::Env|RDA::Object::Env>,
L<RDA::Object::Env|RDA::Object::Explorer>,
L<RDA::Object::Ftp|RDA::Object::Ftp>,
L<RDA::Object::Hcve|RDA::Object::Hcve>,
L<RDA::Object::Htm|RDA::Object::Html>,
L<RDA::Object::Index|RDA::Object::Index>,
L<RDA::Object::Inline|RDA::Object::Inline>,
L<RDA::Object::Item|RDA::Object::Item>,
L<RDA::Object::Jar|RDA::Object::Jar>,
L<RDA::Object::Java|RDA::Object::Java>,
L<RDA::Object::Lex|RDA::Object::Lex>,
L<RDA::Object::Lock|RDA::Object::Lock>,
L<RDA::Object::Log|RDA::Object::Log>,
L<RDA::Object::Manifest|RDA::Object::Manifest>,
L<RDA::Object::Message|RDA::Object::Message>,
L<RDA::Object::Mrc|RDA::Object::Mrc>,
L<RDA::Object::Output|RDA::Object::Output>,
L<RDA::Object::Parser|RDA::Object::Parser>,
L<RDA::Object::Pipe|RDA::Object::Pipe>,
L<RDA::Object::Rda|RDA::Object::Rda>,
L<RDA::Object::Remote|RDA::Object::Remote>,
L<RDA::Object::Report|RDA::Object::Report>,
L<RDA::Object::Request|RDA::Object::Request>,
L<RDA::Object::Response|RDA::Object::Response>,
L<RDA::Object::Table|RDA::Object::Table>,
L<RDA::Object::Target|RDA::Object::Target>,
L<RDA::Object::Telnet|RDA::Object::Telnet>,
L<RDA::Object::Toc|RDA::Object::Toc>,
L<RDA::Object::Token|RDA::Object::Token>,
L<RDA::Object::Type|RDA::Object::Type>,
L<RDA::Object::UsrAgent|RDA::Object::UsrAgent>,
L<RDA::Object::View|RDA::Object::View>,
L<RDA::Object::Windows|RDA::Object::Windows>,
L<RDA::Object::Xml|RDA::Object::Xml>,
L<RDA::Options|RDA::Options>,
L<RDA::Operator::Array|RDA::Operator::Array>,
L<RDA::Operator::Hash|RDA::Operator::Hash>,
L<RDA::Operator::Scalar|RDA::Operator::Scalar>,
L<RDA::Operator::Value|RDA::Operator::Value>,
L<RDA::SDCL::Context|RDA::SDCL::Context>,
L<RDA::SDCL::Language|RDA::SDCL::Language>,
L<RDA::SDCL::Value|RDA::SDCL::Value>,
L<RDA::Text|RDA::Text>,
L<RDA::Value::Array|RDA::Value::Array>,
L<RDA::Value::Assoc|RDA::Value::Assoc>,
L<RDA::Value::Code|RDA::Value::Code>,
L<RDA::Value::Global|RDA::Value::Global>,
L<RDA::Value::Hash|RDA::Value::Hash>,
L<RDA::Value::Internal|RDA::Value::Internal>,
L<RDA::Value::List|RDA::Value::List>,
L<RDA::Value::Operator|RDA::Value::Operator>,
L<RDA::Value::Pointer|RDA::Value::Pointer>,
L<RDA::Value::Property|RDA::Value::Property>,
L<RDA::Value::Scalar|RDA::Value::Scalar>,
L<RDA::Value::Variable|RDA::Value::Variable>

=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