# Value.pm: Class Used for Managing Value Operators

package RDA::Operator::Value;

# $Id: Value.pm,v 1.20 2015/10/19 06:19:19 RDA Exp $
# ARCS: $Header: /home/cvs/cvs/RDA_8/src/scripting/lib/RDA/Operator/Value.pm,v 1.20 2015/10/19 06:19:19 RDA Exp $
#
# Change History
# 20151019  MSC  Improve the documentation.

=head1 NAME

RDA::Operator::Value - Class Used for Managing Value Operators

=head1 SYNOPSIS

 require RDA::Operator::Value;

=head1 DESCRIPTION

This package regroups the definition of the value operators.

The following methods are available:

=cut

use strict;

BEGIN
{ use Exporter;
  use RDA::Text qw(get_string);
  use RDA::Object::Rda;
  use RDA::Object::View;
  use RDA::SDCL::Block qw($DIE);
  use RDA::Value::Code;
  use RDA::Value::Hash;
  use RDA::Value::List;
  use RDA::Value::Operator qw(del_error find_error get_error set_error);
  use RDA::Value::Property;
  use RDA::Value::Scalar qw(:value new_number);
}

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

# Define the global private constants

# Define the global private variables
my %tb_grp = (
  a  => \&_grep_a,
  av => \&_grep_av,
  b  => \&_grep_b,
  bv => \&_grep_bv,
  d  => \&_grep_d,
  dv => \&_grep_dv,
  f  => \&_grep_f,
  fv => \&_grep_fv,
  );
my %tb_ini = (
  '.alias.'   => \&_ini_alias,
  '.assign.'  => \&_ini_assign,
  '.macro.'   => \&_ini_macro,
  '.method.'  => \&_ini_method,
  'and'       => \&_ini_and,
  'check'     => \&_ini_check,
  'code'      => \&_ini_code,
  'cond'      => \&_ini_cond,
  'copy'      => \&_ini_copy,
  'defined'   => \&_ini_defined,
  'delete'    => \&_ini_delete,
  'determine' => \&_ini_determine,
  'dump'      => \&_ini_dump,
  'eighth'    => \&_ini_first,
  'eval'      => \&_ini_eval,
  'exists'    => \&_ini_exists,
  'first'     => \&_ini_first,
  'fourth'    => \&_ini_first,
  'fifth'     => \&_ini_first,
  'grep'      => \&_ini_grep,
  'hash'      => \&_ini_hash,
  'list'      => \&_ini_list,
  'map'       => \&_ini_map,
  'member'    => \&_ini_member,
  'missing'   => \&_ini_missing,
  'ninth'     => \&_ini_first,
  'not'       => \&_ini_not,
  'nvl'       => \&_ini_nvl,
  'or'        => \&_ini_or,
  'property'  => \&_ini_property,
  'ref'       => \&_ini_ref,
  'reverse'   => \&_ini_reverse,
  'scalar'    => \&_ini_scalar,
  'second'    => \&_ini_first,
  'seventh'   => \&_ini_first,
  'single'    => \&_ini_single,
  'sixth'     => \&_ini_first,
  'sort'      => \&_ini_sort,
  'tenth'     => \&_ini_first,
  'third'     => \&_ini_first,
  'tsort'     => \&_ini_tsort,
  );
my %tb_off = (
  'first'   => 0,
  'second'  => 1,
  'third'   => 2,
  'fourth'  => 3,
  'fifth'   => 4,
  'sixth'   => 5,
  'seventh' => 6,
  'eighth'  => 7,
  'ninth'   => 8,
  'tenth'   => 9,
  );
my %tb_ref = (
  q{$}                 => RDA::Value::Scalar::new_text('SCALAR'),
  q{@}                 => RDA::Value::Scalar::new_text('ARRAY'),
  q{%}                 => RDA::Value::Scalar::new_text('HASH'),
  q{RDA::Value::Array} => RDA::Value::Scalar::new_text('ARRAY'),
  q{RDA::Value::Assoc} => RDA::Value::Scalar::new_text('HASH'),
  q{RDA::Value::Code}  => RDA::Value::Scalar::new_text('CODE'),
  );
my %tb_srt = (
  ## no critic (Interpolation)
  q{NA} => q{$a->[%d] <=> $b->[%d]},
  q{ND} => q{$b->[%d] <=> $a->[%d]},
  q{SA} => q{$a->[%d] cmp $b->[%d]},
  q{SD} => q{$b->[%d] cmp $a->[%d]},
);

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

=head2 S<$h = RDA::Operator::Value-E<gt>load($tbl)>

This method loads the operator definition in the operator table.

=cut

sub load
{ my ($cls, $tbl) = @_;

  foreach my $nam (keys(%tb_ini))
  { $tbl->{$nam} = $tb_ini{$nam};
  }
  return;
}

=head1 INTERNAL OPERATORS

=head2 S<.alias.($blk,$par,$nam,$arg)>

This operator executes an object method defined through an alias.

=cut

sub _ini_alias
{ my ($blk, $def, $arg) = @_;
  my ($cls, $nam, $par);

  ($cls, $nam) = @{$def};
  return $VAL_UNDEF unless ref($par = shift(@{$arg}));
  return bless {
    arg  => $arg,
    cls  => $cls,
    nam  => $nam,
    par  => $par,
    _blk => $blk,
    _del => \&del_error,
    _fnd => \&_find_alias,
    _get => \&_get_alias,
    _lft => q{},
    _set => \&set_error,
    _typ => '.alias.',
    }, 'RDA::Value::Operator';
}

sub _find_alias
{ my ($val);

  return ($val) if ($val = _get_alias(shift))->is_defined;
  return ();
}

sub _get_alias
{ my ($slf, $flg) = @_;
  my ($cls, $obj);

  $obj = $slf->{'par'}->eval_value(1);
  $obj = $obj->[0] if $obj->is_list;
  return $VAL_UNDEF unless defined($obj);
  $slf->{'_blk'}->get_agent->abort(get_string('NO_OBJECT'))
    unless $obj->has_methods;
  return $obj->eval_method($slf->{'_blk'}, $slf->{'nam'}, $slf->{'arg'}, $flg);
}

=head2 S<.assign.($nam,$arg)>

This operator assigns the value to the specified variables and returns the
value.

=cut

sub _ini_assign
{ my ($var, $val) = @_;

  # Validate the arguments
  die get_string('BAD_ASSIGN') unless $var->is_lvalue;
  die get_string('NO_RVALUE') unless ref($val);

  # Create the operator
  return bless {
    val  => $val,
    var  => $var,
    _del => \&del_error,
    _fnd => \&_find_assign,
    _get => \&_get_assign,
    _lft => \&_left_assign,
    _set => \&set_error,
    _typ => '.assign.',
    }, 'RDA::Value::Operator';
}

sub _find_assign
{ my ($val);

  return ($val) if ($val = _get_assign(shift))->is_defined;
  return ();
}

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

  $val = $slf->{'var'}->assign_value($slf->{'val'});
  return $flg ? $val->eval_value(1) : $val;
}

sub _left_assign
{ return shift->{'val'}->is_lvalue;
}

=head2 S<.macro.($blk,$nam,$arg)>

This operator transforms an array in a list.

=cut

sub _ini_macro
{ my ($blk, $nam, $arg) = @_;

  return bless {
    arg  => $arg,
    nam  => $nam,
    _blk => $blk,
    _del => \&del_error,
    _fnd => \&_find_macro,
    _get => \&_get_macro,
    _lft => q{},
    _set => \&set_error,
    _typ => '.macro.',
    }, 'RDA::Value::Operator';
}

sub _find_macro
{ my ($val);

  return ($val) if ($val = _get_macro(shift))->is_defined;
  return ();
}

sub _get_macro  ## no critic (Return)
{ my ($slf, $flg) = @_;
  my ($agt, $blk, $def, $nam, $val);

  # Determine the macro or library definition
  $nam = $slf->{'nam'};
  if ($nam =~ m/^caller:(.*)$/)
  { $nam = $1;
    $blk = $slf->{'_blk'}->get_current;
  }
  else
  { $blk = $slf->{'_blk'};
  }
  $blk->get_agent->abort(get_string('BAD_MACRO', $nam))
    unless ($def = $blk->get_lib->find_macro($nam));

  # Execute the macro but do not yet evaluate its arguments
  eval {$val = $def->run($nam, $slf->{'arg'}, $blk)};
  return $flg ? $val->eval_value(1) : $val if ref($val);

  # Propagate the error
  $agt = $blk->get_agent;
  if ($@ =~ $DIE)
  { die $@ if $1 ne 'B';
    $agt->abort([$agt->pop_error], get_string('ERR_MACRO', $nam));
  }
  elsif ($@)
  { $agt->abort($@, get_string('ERR_MACRO', $nam));
  }
  $agt->abort(get_string('ERR_MACRO', $nam));
}

=head2 S<.method.($blk,$par,$nam,$arg)>

This operator executes an object method.

=cut

sub _ini_method
{ my ($blk, $par, $nam, $arg) = @_;

  return bless {
    arg  => $arg,
    nam  => $nam,
    par  => $par,
    _blk => $blk,
    _del => \&del_error,
    _fnd => \&_find_method,
    _get => \&_get_method,
    _lft => q{},
    _set => \&set_error,
    _typ => '.method.',
    }, 'RDA::Value::Operator';
}

sub _find_method
{ my ($val);

  return ($val) if ($val = _get_method(shift))->is_defined;
  return ();
}

sub _get_method  ## no critic (Return)
{ my ($slf, $flg) = @_;
  my ($obj);

  $obj = $slf->{'par'}->eval_value(1);
  $obj = $obj->[0] if $obj->is_list;
  return $VAL_UNDEF unless defined($obj);
  return $obj->eval_method($slf->{'_blk'}, $slf->{'nam'}, $slf->{'arg'}, $flg)
    if $obj->has_methods;
  $slf->{'_blk'}->get_agent->abort(get_string($obj->is_object
    ? 'NO_METHOD'
    : 'NO_OBJECT'));
}

=head1 CONDITION RELATED OPERATORS

=head2 S<and(value,...)>

This operator returns 1 when all elements in the argument list are equivalent
to true. Otherwise, it returns 0. It executes code values. When an argument is
false, the remaining arguments are not evaluated.

=cut

sub _ini_and
{ my (undef, $nam, $arg) = @_;

  # Create the operator
  return bless {
    arg  => $arg,
    _del => \&del_error,
    _fnd => \&find_error,
    _get => \&_get_and,
    _lft => q{},
    _set => \&set_error,
    _typ => $nam,
    }, 'RDA::Value::Operator';
}

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

  foreach my $itm (@{$slf->{'arg'}})
  { return $VAL_ZERO unless $itm->eval_as_scalar;
  }
  return $VAL_ONE;
}

=head2 S<copy(value,flag)>

This operator returns a copy of the data structure. When the flag is set, it
evaluates values.

=cut

sub _ini_copy
{ my (undef, $nam, $arg) = @_;
  my ($flg, $val);

  # Validate the argument
  return $VAL_UNDEF, unless ($val = shift(@{$arg}));
  $flg = shift(@{$arg}) || $VAL_ZERO;
  die get_string('EXTRA_ARG', $nam) if @{$arg};

  # Create the operator
  return bless {
    flg  => $flg,
    val  => $val,
    _del => \&del_error,
    _fnd => \&find_error,
    _get => \&_get_copy,
    _lft => q{},
    _set => \&set_error,
    _typ => $nam,
    }, 'RDA::Value::Operator';
}

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

  return $slf->{'val'}->eval_value(1)->copy_value(
    $slf->{'flg'}->eval_as_scalar);
}

=head2 S<defined(value,...)>

This operator returns 1 when all arguments are not undefined. Otherwise, it
returns 0. It executes code values. When an argument is not defined, it does
not evaluate the remaining arguments.

=cut


sub _ini_defined
{ my (undef, $nam, $arg) = @_;
  my ($par);

  # Create the operator
  return bless {
    arg  => $arg,
    _del => \&del_error,
    _fnd => \&find_error,
    _get => \&_get_defined,
    _lft => q{},
    _set => \&set_error,
    _typ => $nam,
    }, 'RDA::Value::Operator';
}

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

  foreach my $itm (@{$slf->{'arg'}})
  { return $VAL_ZERO unless $itm->eval_value(1)->is_defined;
  }
  return $VAL_ONE;
}

=head2 S<not(value)>

This operator returns 1 when the argument is equivalent to false, or otherwise,
0. It executes code values.

=cut


sub _ini_not
{ my (undef, $nam, $arg) = @_;
  my ($val);

  # Validate the arguments
  return $VAL_ZERO unless ref($val = shift(@{$arg}));
  die get_string('EXTRA_ARG', $nam) if @{$arg};

  # Create the operator
  return bless {
    val  => $val,
    _del => \&del_error,
    _fnd => \&find_error,
    _get => \&_get_not,
    _lft => q{},
    _set => \&set_error,
    _typ => $nam,
    }, 'RDA::Value::Operator';
}

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

  return $slf->{'val'}->eval_as_scalar ? $VAL_ZERO : $VAL_ONE;
}

=head2 S<or(value,...)>

This operator returns 1 when at least one element in the argument list is
equivalent to true. Otherwise, it returns 0. It executes code values. When an
argument is true, it does not evaluate the remaining arguments.

=cut

sub _ini_or
{ my (undef, $nam, $arg) = @_;
  my ($par);

  # Create the operator
  return bless {
    arg  => $arg,
    _del => \&del_error,
    _fnd => \&find_error,
    _get => \&_get_or,
    _lft => q{},
    _set => \&set_error,
    _typ => $nam,
    }, 'RDA::Value::Operator';
}

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

  foreach my $itm (@{$slf->{'arg'}})
  { return $VAL_ONE if $itm->eval_as_scalar;
  }
  return $VAL_ZERO;
}

=head1 VALUE RELATED OPERATORS

=head2 S<check(str[,re1,expr1[,...]][default])>

This operator checks for the first matching regular expression. When a match is
found, it evaluates the corresponding expression and it returns the result. You
can define a default return value as an extra argument. If the default value is
omitted, it returns an undefined value. It only evaluates arguments when
required.

The match lists are accessible through the C<matches> internal variable.

=cut

sub _ini_check
{ my ($blk, $nam, $arg) = @_;
  my ($str);

  # Validate the arguments
  return $VAL_UNDEF unless ref($str = shift(@{$arg}));

  # Create the operator
  return bless {
    arg  => $arg,
    str  => $str,
    _blk => $blk,
    _del => \&del_error,
    _fnd => \&_find_check,
    _get => \&_get_check,
    _lft => \&_left_pair,
    _set => \&_set_check,
    _typ => $nam,
    }, 'RDA::Value::Operator';
}

sub _find_check
{ my ($slf, $typ) = @_;
  my ($ctx, $pat, $str, $val, @hit, @tbl);

  $ctx = $slf->{'_blk'}->get_context;
  $str = $slf->{'str'}->eval_as_string;
  @tbl = @{$slf->{'arg'}};
  while (($pat, $val) = splice(@tbl, 0, 2))
  { return $pat->find_object($typ) unless defined($val);
    $pat = RDA::Object::View->is_pattern($pat->eval_as_scalar);
    next unless (@hit = $str =~ $pat);
    $ctx->set_internal('hit', RDA::Value::List::new_from_data(@hit));
    return $val->find_object($typ);
  }
  return ();
}

sub _get_check
{ my ($slf, $flg) = @_;
  my ($ctx, $pat, $str, $val, @hit, @tbl);

  $ctx = $slf->{'_blk'}->get_context;
  $str = $slf->{'str'}->eval_as_string;
  @tbl = @{$slf->{'arg'}};
  while (($pat, $val) = splice(@tbl, 0, 2))
  { return $pat->eval_value($flg) unless defined($val);
    $pat = RDA::Object::View->is_pattern($pat->eval_as_scalar);
    next unless (@hit = $str =~ $pat);
    $ctx->set_internal('hit', RDA::Value::List::new_from_data(@hit));
    return $val->eval_value($flg);
  }
  return $VAL_UNDEF;
}

sub _set_check
{ my ($slf, $typ, @arg) = @_;
  my ($pat, $str, $val, @tbl);

  $str = $slf->{'str'}->eval_as_string;
  @tbl = @{$slf->{'arg'}};
  while (($pat, $val) = splice(@tbl, 0, 2))
  { return $typ ? $pat->assign_item(@arg) : $pat->assign_var(@arg)
      unless defined($val);
    $pat = RDA::Object::View->is_pattern($pat->eval_as_scalar);
    return $typ ? $val->assign_item(@arg) : $val->assign_var(@arg)
      if $str =~ $pat;
  }
  return;
}

=head2 S<code(arg,...)>

This operators constructs a code value based on the specified arguments without
evaluating them.

=cut

sub _ini_code
{ my ($blk, undef, $arg) = @_;

  return RDA::Value::Code::new_code($blk->get_context, $arg);
}

=head2 S<cond([cond1,expr1,...][default])>

This operator evaluates the conditions successively until a true condition is
encountered. It executes code values. When a true condition is found, it
evaluates the corresponding expression and it returns the result. You can
specify a default return value as an extra argument. If the default value is
omitted, it returns an undefined value. It only evaluates arguments when
required.

=cut

sub _ini_cond
{ my (undef, $nam, $arg) = @_;

  # Create the operator
  return bless {
    arg  => $arg,
    _del => \&del_error,
    _fnd => \&_find_cond,
    _get => \&_get_cond,
    _lft => \&_left_pair,
    _set => \&_set_cond,
    _typ => $nam,
    }, 'RDA::Value::Operator';
}

sub _find_cond
{ my ($slf, $typ) = @_;
  my ($cnd, $val, @tbl);

  @tbl = @{$slf->{'arg'}};
  while (($cnd, $val) = splice(@tbl, 0, 2))
  { return $cnd->find_object($typ) unless defined($val);
    return $val->find_object($typ) if $cnd->eval_as_scalar;
  }
  return ();
}

sub _get_cond
{ my ($slf, $flg) = @_;
  my ($cnd, $val, @tbl);

  @tbl = @{$slf->{'arg'}};
  while (($cnd, $val) = splice(@tbl, 0, 2))
  { return $cnd->eval_value($flg) unless defined($val);
    return $val->eval_value($flg) if $cnd->eval_as_scalar;
  }
  return $VAL_UNDEF;
}

sub _set_cond
{ my ($slf, $typ, @arg) = @_;
  my ($cnd, $val, @tbl);

  @tbl = @{$slf->{'arg'}};
  while (($cnd, $val) = splice(@tbl, 0, 2))
  { return $typ ? $cnd->assign_item(@arg) : $cnd->assign_var(@arg)
      unless defined($val);
    return $typ ? $val->assign_item(@arg) : $val->assign_var(@arg)
      if $cnd->eval_as_scalar;
  }
  return;
}

=head2 S<delete(var,...)>

This operator deletes some left values and returns their previous content.

=cut

sub _ini_delete
{ my (undef, $nam, $arg) = @_;

  # Validate the arguments
  die get_string('BAD_DELETE', $nam) unless $arg->is_lvalue;
  $arg = $arg->[0] if (scalar @{$arg}) == 1;

  # Create the operator
  return bless {
    arg  => $arg,
    _del => \&del_error,
    _fnd => \&_find_delete,
    _get => \&_get_delete,
    _lft => q{},
    _set => \&set_error,
    _typ => $nam,
    }, 'RDA::Value::Operator';
}

sub _find_delete
{ my ($val);

  return ($val) if ($val = _get_delete(shift))->is_defined;
  return ();
}

sub _get_delete
{ return shift->{'arg'}->delete_value;
}

=head2 S<determine(value)>

This operator resolve properties in the specified string.

=cut

sub _ini_determine
{ my ($blk, $nam, $arg) = @_;
  my ($par);

  # Validate the arguments
  die get_string('NO_ARG', $nam) unless ref($par = shift(@{$arg}));
  die get_string('EXTRA_ARG', $nam) if @{$arg};

  # Create the operator
  return bless {
    par  => $par,
    _blk => $blk,
    _del => \&del_error,
    _fnd => \&find_error,
    _get => \&_get_determine,
    _lft => q{},
    _set => \&set_error,
    _typ => $nam,
    }, 'RDA::Value::Operator';
}

sub _get_determine
{ my ($slf, $flg) = @_;
  my ($blk, $str);

  $blk = $slf->{'_blk'};
  $str = $slf->{'par'}->eval_as_string;
  1 while ($str =~
    s/\$\{(([A-Z]+\/)?(\w+\.)*\w+)(\/([A-Z]{1,2}))?(\:([^\{\}]*))?\}/
      _eval_prp($blk, $1, defined($4) ? $5 : 'V', defined($6) ? $7 : q{})/egi);
  return RDA::Value::Scalar::new_text($str);
}

sub _eval_prp
{ my ($blk, $nam, $mod, $dft) = @_;

  $nam = "ENV.$nam" unless $nam =~ m/[\/\.]/;
  return RDA::Value::Property->new($blk, q{$}, $nam, $mod,
    RDA::Value::Scalar::new_text($dft))->eval_as_string;
}

=head2 S<dump(value)>

This operator returns the dump of the value specifies as an argument.

=cut

sub _ini_dump
{ my (undef, $nam, $arg) = @_;
  my ($par);

  # Validate the arguments
  die get_string('NO_ARG', $nam) unless ref($par = shift(@{$arg}));
  die get_string('EXTRA_ARG', $nam) if @{$arg};

  # Create the operator
  return bless {
    par  => $par,
    _del => \&del_error,
    _fnd => \&find_error,
    _get => \&_get_dump,
    _lft => q{},
    _set => \&set_error,
    _typ => $nam,
    }, 'RDA::Value::Operator';
}

sub _get_dump
{ return RDA::Value::Scalar::new_text(shift->{'par'}->eval_value->dump);
}

=head2 S<eval(arg,...)>

This operator evaluates each value from the argument list. It executes code
values. It returns the last result.

=cut

sub _ini_eval
{ my (undef, $nam, $arg) = @_;

  # Create the operator
  return bless {
    arg  => $arg,
    _del => \&del_error,
    _fnd => \&find_error,
    _get => \&_get_eval,
    _lft => q{},
    _set => \&set_error,
    _typ => $nam,
    }, 'RDA::Value::Operator';
}

sub _get_eval
{ my ($slf) = @_;
  my ($ret);

  $ret = $VAL_UNDEF;
  foreach my $itm (@{$slf->{'arg'}})
  { $ret = $itm->eval_value(1);
  }
  return $ret;
}

=head2 S<exists($var)>, S<exists($var[value...])>, or S<exists($var{value...})>

This operator indicates when a variable, an array index, or a hash key exists.

=cut

sub _ini_exists
{ my (undef, $nam, $arg) = @_;
  my ($par);

  # Validate the arguments
  die get_string('NO_ARG', $nam) unless ref($par = shift(@{$arg}));
  die get_string('BAD_ASSIGN', $nam) unless $par->is_lvalue;
  die get_string('EXTRA_ARG', $nam) if @{$arg};

  # Create the operator
  return bless {
    par  => $par,
    _del => \&del_error,
    _fnd => \&find_error,
    _get => \&_get_exists,
    _lft => q{},
    _set => \&set_error,
    _typ => $nam,
    }, 'RDA::Value::Operator';
}

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

  my ($obj) = $slf->{'par'}->find_object;
  return defined($obj) ? $VAL_ONE : $VAL_ZERO;
}

=head2 S<first(arg,...)>

This operator evaluates its argument list and returns the first value from that
list or an undefined value when the list is empty. It executes code values.

By analogy, the C<second>, C<third>, C<fourth>, C<fifth>, C<sixth>, C<seventh>,
C<eighth>, C<ninth>, and C<tenth> operators retrieve further items of a list.

=cut

sub _ini_first
{ my (undef, $nam, $arg) = @_;

  # Create the operator
  return bless {
    arg  => $arg,
    _del => \&del_error,
    _fnd => \&_find_first,
    _get => \&_get_first,
    _lft => q{},
    _off => $tb_off{$nam},
    _set => \&set_error,
    _typ => $nam,
    }, 'RDA::Value::Operator';
}

sub _find_first
{ my ($val);

  return ($val) if ($val = _get_first(shift))->is_defined;
  return ();
}

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

  return $slf->{'arg'}->eval_value(1)->[$slf->{'_off'}] || $VAL_UNDEF;
}

=head2 S<grep(@var,cond[,$opt])> or S<grep(%var,cond[,$opt])>

This operator evaluates the specified condition for each array value or the
hash key (setting C<last> to each element). It supports named blocks and
expression arrays as condition. It returns the list value consisting of the
elements for which the expression evaluated to true. It supports the
following option:

=over 9

=item B<    'f' > Stops on the first match.

=item B<    'v' > Inverts the sense of matching to select non-matching value

=back

=head2 S<grep(@var,hash[,$opt])> or S<grep(%var,hash[,$opt])>

This operator returns the array values or the hash keys that correspond to a
key of the filter hash. It ignores undefined array elements. It supports the
following options:

=over 9

=item B<    'f' > Stops on the first match.

=item B<    'v' > Inverts the sense of matching to select non-matching value

=back

=head2 S<grep(@var,$re[,$opt])> or S<grep(%var,$re[,$opt])>

This operator returns the array values or the hash keys that correspond to the
specified pattern. It ignores undefined array elements. It supports the
following options:

=over 9

=item B<    'b' > Considers only the basename part of the value

=item B<    'd' > Considers only the directory part of the value

=item B<    'f' > Stops on the first match.

=item B<    'i' > Ignores case distinctions in both the pattern and the value

=item B<    'v' > Inverts the sense of matching to select non-matching value

=back

=cut

sub _ini_grep
{ my ($blk, $nam, $arg) = @_;
  my ($cnd, $opt, $par, $typ);

  # Validate the arguments
  die get_string('NO_ARG', $nam) unless ref($par = shift(@{$arg}));
  if ($par->is_operator eq '.assign.')
  { $typ = $par->{'var'}->is_lvalue;
    if ($typ eq q{%})
    { $par = $blk->define_operator(['.hset.'], $par->{'var'}, $par->{'val'});
    }
    elsif ($typ ne q{@})
    { die get_string('BAD_ASSIGN', $nam);
    }
  }
  $cnd = shift(@{$arg}) || $VAL_NONE;
  $opt = shift(@{$arg}) || $VAL_NONE;
  die get_string('EXTRA_ARG', $nam) if @{$arg};

  # Create the operator
  return bless {
    cnd  => $cnd,
    ctx  => $blk->{'ctx'},
    opt  => $opt,
    par  => $par,
    _blk => $blk,
    _del => \&del_error,
    _fnd => \&find_error,
    _get => \&_get_grep,
    _lft => q{},
    _set => \&set_error,
    _typ => $nam,
    }, 'RDA::Value::Operator';
}

sub _get_grep  ## no critic (Complex,Return)
{ my ($slf) = @_;
  my ($cnd, $ctx, $fct, $obj, $opt, $val);

  # Get the arguments
  ($obj) = $slf->{'par'}->find_object;
  return RDA::Value::List->new unless defined($obj);
  $cnd = $slf->{'cnd'}->eval_value;
  $opt = $slf->{'opt'}->eval_as_string;

  # Apply code based filter
  return _grep_code($slf, $obj, $cnd, $opt) if $cnd->is_code;

  # Apply hash based filter
  $cnd = $cnd->get_value if $cnd->is_pointer;
  return _grep_hash($slf, $obj, {$cnd->as_data}, $opt) if $cnd->is_list;
  return _grep_hash($slf, $obj, $cnd, $opt)            if $cnd->is_hash;

  # Decode the options
  if (length($cnd = $cnd->as_string))
  { $cnd = RDA::Object::View->is_match($cnd, index($opt, 'i') < 0);
    $fct = (index($opt, 'b') >= 0) ? 'b' :
           (index($opt, 'd') >= 0) ? 'd' :
           'f';
  }
  else
  { $fct = 'a';
  }
  $fct .= 'v' if index($opt, 'v') >= 0;

  # Filter the list
  $fct = $tb_grp{$fct};
  if (index($opt, 'f') < 0)
  { return RDA::Value::List->new(grep {ref($_) && &$fct($_->as_scalar, $cnd)}
      @{$obj}) if $obj->is_array;
    return RDA::Value::List::new_from_data(grep {&$fct($_, $cnd)} keys(%{$obj}))
      if $obj->is_hash || ($obj = $obj->get_hash)->is_hash;
  }
  else
  { if ($obj->is_array)
    { foreach my $itm (@{$obj})
      { return RDA::Value::List->new($itm)
          if ref($itm) && &$fct($itm->as_scalar, $cnd);
      }
      return RDA::Value::List->new;
    }
    if ($obj->is_hash || ($obj = $obj->get_hash)->is_hash)
    { foreach my $key (keys(%{$obj}))
      { return RDA::Value::List::new_from_data($key)
          if &$fct($key, $cnd);
      }
      return RDA::Value::List->new;
    }
  }
  $slf->{'_blk'}->get_agent->abort(get_string('BAD_GREP'));
}

sub _grep_code  ## no critic (Return)
{ my ($slf, $obj, $cnd, $opt) = @_;
  my ($inv, $val);

  $inv = index($opt, 'v') >= 0;
  if (index($opt, 'f') < 0)
  { return RDA::Value::List->new(grep
      {ref($_) && ($inv xor $cnd->eval_code($_)->eval_as_scalar)}
      @{$obj})
      if $obj->is_array;
    return RDA::Value::List::new_from_data(grep
      {$inv xor
       $cnd->eval_code(RDA::Value::Scalar::new_text($_))->eval_as_scalar}
      keys(%{$obj}))
      if $obj->is_hash || ($obj = $obj->get_hash)->is_hash;
  }
  else
  { if ($obj->is_array)
    { foreach my $itm (@{$obj})
      { return RDA::Value::List->new($itm)
          if ref($itm) && ($inv xor $cnd->eval_code($itm)->eval_as_scalar);
      }
      return RDA::Value::List->new;
    }
    if ($obj->is_hash || ($obj = $obj->get_hash)->is_hash)
    { foreach my $key (keys(%{$obj}))
      { $val = RDA::Value::Scalar::new_text($key);
        return RDA::Value::List->new($val)
          if $inv xor $cnd->eval_code($val)->eval_as_scalar;
      }
      return RDA::Value::List->new;
    }
  }
  $slf->{'_blk'}->get_agent->abort(get_string('BAD_GREP'));
}

sub _grep_hash  ## no critic (Return)
{ my ($slf, $obj, $cnd, $opt) = @_;
  my ($inv);

  $inv = index($opt, 'v') >= 0;
  if (index($opt, 'f') < 0)
  { return RDA::Value::List->new(grep
      {ref($_) && ($inv xor exists($cnd->{$_->as_scalar}))}
      @{$obj}) if $obj->is_array;
    return RDA::Value::List::new_from_data(grep
      {$inv xor exists($cnd->{$_})}
      keys(%{$obj}))
      if $obj->is_hash || ($obj = $obj->get_hash)->is_hash;
  }
  else
  { if ($obj->is_array)
    { foreach my $itm (@{$obj})
      { return RDA::Value::List->new($itm)
          if ref($itm) && ($inv xor exists($cnd->{$itm->as_scalar}));
      }
      return RDA::Value::List->new;
    }
    if ($obj->is_hash || ($obj = $obj->get_hash)->is_hash)
    { foreach my $key (keys(%{$obj}))
      { return RDA::Value::List::new_from_data($key)
          if $inv xor exists($cnd->{$key});
      }
      return RDA::Value::List->new;
    }
  }
  $slf->{'_blk'}->get_agent->abort(get_string('BAD_GREP'));
}

sub _grep_a
{ my ($val) = @_;
  return defined($val);
}

sub _grep_av
{ return 0;
}

sub _grep_b
{ my ($val, $re) = @_;
  return defined($val) && RDA::Object::Rda->basename($val) =~ $re;
}

sub _grep_bv
{ my ($val, $re) = @_;
  return defined($val) && RDA::Object::Rda->basename($val) !~ $re;
}

sub _grep_d
{ my ($val, $re) = @_;
  return defined($val) && RDA::Object::Rda->dirname($val) =~ $re;
}

sub _grep_dv
{ my ($val, $re) = @_;
  return defined($val) && RDA::Object::Rda->dirname($val) !~ $re;
}

sub _grep_f
{ my ($val, $re) = @_;
  return defined($val) && $val =~ $re;
}

sub _grep_fv
{ my ($val, $re) = @_;
  return defined($val) && $val !~ $re;
}

=head2 S<hash(start,arg,...)>

This operator transforms the argument list in a hash. It executes the code
values.

=cut

sub _ini_hash
{ my (undef, $nam, $arg) = @_;
  my ($par);

  # Validate the arguments
  die get_string('NO_ARG', $par) unless ref($par = shift(@{$arg}));

  # Create the operator
  return bless {
    arg  => $arg,
    par  => $par,
    _del => \&del_error,
    _fnd => \&_find_hash,
    _get => \&_get_hash,
    _lft => q{},
    _set => \&set_error,
    _typ => $nam,
    }, 'RDA::Value::Operator';
}

sub _find_hash
{ my ($val);

  return ($val) if ($val = _get_hash(shift))->is_defined;
  return ();
}

sub _get_hash
{ my ($slf) = @_;
  my ($cnt);

  $cnt = $slf->{'par'}->eval_as_number;
  return RDA::Value::Hash->new(map {$cnt++ => $_}
                                   @{$slf->{'arg'}->eval_value(1)});
}

=head2 S<list(arg,...)>

This operator returns the argument list after its evaluation. It executes the
code values.

=cut

sub _ini_list
{ my (undef, $nam, $arg) = @_;

  # Create the operator
  return bless {
    arg  => $arg,
    _del => \&del_error,
    _fnd => \&find_error,
    _get => \&_get_list,
    _lft => q{},
    _set => \&set_error,
    _typ => $nam,
    }, 'RDA::Value::Operator';
}

sub _get_list
{ return shift->{'arg'}->eval_value(1);
}

=head2 S<map(@var,code)> or S<map(%var,code)>

This operator evaluates the specified code for each array value or the
hash key (setting C<last> to each element). It supports named blocks and
expression arrays as code. It returns the resulting value list.

=cut

sub _ini_map
{ my ($blk, $nam, $arg) = @_;
  my ($cod, $opt, $par, $typ);

  # Validate the arguments
  die get_string('NO_ARG', $nam) unless ref($par = shift(@{$arg}));
  if ($par->is_operator eq '.assign.')
  { $typ = $par->{'var'}->is_lvalue;
    if ($typ eq q{%})
    { $par = $blk->define_operator(['.hset.'], $par->{'var'}, $par->{'val'});
    }
    elsif ($typ ne q{@})
    { die get_string('BAD_ASSIGN', $nam);
    }
  }
  $cod = shift(@{$arg}) || $VAL_NONE;
  die get_string('EXTRA_ARG', $nam) if @{$arg};

  # Create the operator
  return bless {
    cod  => $cod,
    ctx  => $blk->{'ctx'},
    par  => $par,
    _blk => $blk,
    _del => \&del_error,
    _fnd => \&find_error,
    _get => \&_get_map,
    _lft => q{},
    _set => \&set_error,
    _typ => $nam,
    }, 'RDA::Value::Operator';
}

sub _get_map
{ my ($slf) = @_;
  my ($cod, $obj);

  # Get the arguments
  ($obj) = $slf->{'par'}->find_object;
  return RDA::Value::List->new unless defined($obj);
  $cod = $slf->{'cod'}->eval_value;

  # Apply code
  if ($cod->is_code)
  { return RDA::Value::List->new(map
      {$cod->eval_code($_)} @{$obj})
      if $obj->is_array;
    return RDA::Value::List->new(map
      {$cod->eval_code(RDA::Value::Scalar::new_text($_))} keys(%{$obj}))
      if $obj->is_hash || ($obj = $obj->get_hash)->is_hash;
  }
  else
  { return RDA::Value::List->new(@{$obj})
      if $obj->is_array;
    return RDA::Value::List->new(map
      {RDA::Value::Scalar::new_text($_)} keys(%{$obj}))
      if $obj->is_hash || ($obj = $obj->get_hash)->is_hash;
  }
  return $slf->{'_blk'}->get_agent->abort(get_string('BAD_MAP'));
}

=head2 S<member($val,arg,...)>

This operator indicates if the specified value is present in the list. It
executes the code values.

=cut

sub _ini_member
{ my (undef, $nam, $arg) = @_;
  my ($par);

  # Validate the arguments
  die get_string('NO_ARG', $nam) unless ref($par = shift(@{$arg}));

  # Create the operator
  return bless {
    arg  => $arg,
    par  => $par,
    _del => \&del_error,
    _fnd => \&find_error,
    _get => \&_get_member,
    _lft => q{},
    _set => \&set_error,
    _typ => $nam,
    }, 'RDA::Value::Operator';
}

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

  $val = $slf->{'par'}->eval_as_string;
  foreach my $itm (@{$slf->{'arg'}->eval_value(1)})
  { return $VAL_ONE if $val eq $itm->as_scalar;
  }
  return $VAL_ZERO;
}

=head2 S<missing($var)>, S<missing($var[val...])>, or S<missing($var{val...})>

This operator indicates when a variable, an array index, or a hash key does
not exist.

=cut

sub _ini_missing
{ my (undef, $nam, $arg) = @_;
  my ($par);

  # Validate the arguments
  die get_string('NO_ARG', $nam) unless ref($par = shift(@{$arg}));
  die get_string('BAD_ASSIGN', $nam) unless $par->is_lvalue;
  die get_string('EXTRA_ARG', $nam) if @{$arg};

  # Create the operator
  return bless {
    par  => $par,
    _del => \&del_error,
    _fnd => \&find_error,
    _get => \&_get_missing,
    _lft => q{},
    _set => \&set_error,
    _typ => $nam,
    }, 'RDA::Value::Operator';
}

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

  my ($obj) = $slf->{'par'}->find_object;
  return defined($obj) ? $VAL_ZERO : $VAL_ONE;
}

=head2 S<nvl($arg,...)>

This operator returns the value of the first argument that is not undefined. It
executes code values. The remaining arguments are not evaluated. When no
defined arguments are found, it returns an undefined value.

=cut

sub _ini_nvl
{ my (undef, $nam, $arg) = @_;

  # Create the operator
  return bless {
    arg  => $arg,
    _del => \&del_error,
    _fnd => \&_find_nvl,
    _get => \&_get_nvl,
    _lft => q{},
    _set => \&set_error,
    _typ => $nam,
    }, 'RDA::Value::Operator';
}

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

  foreach my $itm (@{$slf->{'arg'}})
  { return @val if (@val = $itm->find_object($typ));
  }
  return ();
}

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

  foreach my $itm (@{$slf->{'arg'}})
  { return $val if ($val = $itm->eval_value(1))->is_defined;
  }
  return $VAL_UNDEF;
}

=head2 S<property(type,group,name,[mode,[default[,flag]]])>

This operator represents a property with a dynamic name in the specified
group.

=cut

sub _ini_property
{ my ($blk, $nam, $arg) = @_;
  my ($dft, $flg, $grp, $mod, $prp, $typ);

  # Validate the arguments
  die get_string('NO_ARG', $nam)
    unless ref($typ = shift(@{$arg}))
        && ref($grp = shift(@{$arg}))

        && ref($prp = shift(@{$arg}));
  die get_string('BAD_ASSIGN', $nam)
    unless ($typ = $typ->as_scalar) && $typ =~ m/^[\$\@\%]$/;
  $mod = ref($mod = shift(@{$arg})) ? $mod->as_scalar : undef;
  $dft = shift(@{$arg});
  $flg = ref($flg = shift(@{$arg})) ? $flg->as_scalar : undef;
  die get_string('EXTRA_ARG', $nam) if @{$arg};

  # Create the dynamic property
  return RDA::Value::Property->new_dynamic($blk, $typ, [$grp, $prp], $mod, $dft,
    $flg);
}

=head2 S<ref(value)>

This operator returns the object class if the value is a reference to an
object. Otherwise, it returns an empty string. It executes code values.

=cut

sub _ini_ref
{ my (undef, $nam, $arg) = @_;
  my ($par);

  # Validate the arguments
  die get_string('NO_ARG', $nam) unless ref($par = shift(@{$arg}));
  die get_string('EXTRA_ARG', $nam) if @{$arg};

  # Create the operator
  return bless {
    par  => $par,
    _del => \&del_error,
    _fnd => \&find_error,
    _get => \&_get_ref,
    _lft => q{},
    _set => \&set_error,
    _typ => $nam,
    }, 'RDA::Value::Operator';
}

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

  $val = $slf->{'par'}->eval_value;
  return
    ($ref = $val->is_object)          ? RDA::Value::Scalar::new_text($ref) :
    ($ref = $val->is_pointer)         ? $tb_ref{$ref} :
    exists($tb_ref{$ref = ref($val)}) ? $tb_ref{$ref} :
                                        $VAL_NONE;
}

=head2 S<reverse(value,...)>

This operator returns the reverse list of the arguments. It executes code
values.

=cut

sub _ini_reverse
{ my (undef, $nam, $arg) = @_;

  # Create the operator
  return bless {
    arg  => $arg,
    _del => \&del_error,
    _fnd => \&find_error,
    _get => \&_get_reverse,
    _lft => q{},
    _set => \&set_error,
    _typ => $nam,
    }, 'RDA::Value::Operator';
}

sub _get_reverse
{ return RDA::Value::List->new(reverse @{shift->{'arg'}->eval_value(1)});
}

=head2 S<scalar(...)>

This operator evaluates its argument list in a scalar context. It executes code
values.

=cut

sub _ini_scalar
{ my (undef, $nam, $arg) = @_;
  my ($cnt);

  # Determine the treatment
  $cnt = @{$arg};
  return $VAL_ZERO unless $cnt;

  # Create the operator
  return bless {
    arg  => ($cnt > 1) ? $arg : $arg->[0],
    _del => \&del_error,
    _fnd => \&find_error,
    _get => ($cnt > 1) ? \&_get_scalar_list : \&_get_scalar_first,
    _lft => q{},
    _set => \&set_error,
    _typ => $nam,
    }, 'RDA::Value::Operator';
}

sub _get_scalar_first
{ my ($val);

  return ($val = shift->{'arg'}->eval_value(1))->is_list
    ? new_number(scalar @{$val})
    : $val;
}

sub _get_scalar_list
{ return new_number(scalar @{shift->{'arg'}->eval_value(1)});
}

=head2 S<single(arg,...)>

This operator evaluates its argument list and returns the first value from that
list when the list has a single value or an undefined value otherwise. It
executes code values.

=cut

sub _ini_single
{ my (undef, $nam, $arg) = @_;

  # Create the operator
  return bless {
    arg  => $arg,
    _del => \&del_error,
    _fnd => \&_find_single,
    _get => \&_get_single,
    _lft => q{},
    _off => $tb_off{$nam},
    _set => \&set_error,
    _typ => $nam,
    }, 'RDA::Value::Operator';
}

sub _find_single
{ my ($val);

  return ($val) if ($val = _get_single(shift))->is_defined;
  return ();
}

sub _get_single
{ my ($slf) = @_;
  my ($arg, @arg);

  ($arg, @arg) = @{$slf->{'arg'}->eval_value(1)};
  return @arg          ? $VAL_UNDEF :
         defined($arg) ? $arg :
                         $VAL_UNDEF;
}

=head2 S<sort(@var,$opt)> or S<sort(%var,$opt)>

This operator returns the array or hash values sorting according to the
specified sort directive. It assimilates a scalar value to a single element
array.

The sort directive is a comma-separated list of column numbers, possibly
followed by one of the following sort criteria:

=over 10

=item B<    'NA' > Sorts numerically ascending.

=item B<    'ND' > Sorts numerically ascending.

=item B<    'SA' > Sorts in alphabetic order (default).

=item B<    'SD' > Sorts in reverse alphabetic order.

=back

In the sort directive, zero represents the hash key, while numbers greater than
zero represents the respective columns of the value.

=cut

sub _ini_sort
{ my ($blk, $nam, $arg) = @_;
  my ($opt, $par, $typ);

  # Validate the arguments
  die get_string('NO_ARG', $nam) unless ref($par = shift(@{$arg}));
  $opt = shift(@{$arg}) || $VAL_NONE;
  die get_string('EXTRA_ARG', $nam) if @{$arg};

  if ($par->is_operator eq '.assign.')
  { $typ = $par->{'var'}->is_lvalue;
    if ($typ eq q{%})
    { $par = $blk->define_operator(['.hset.'], $par->{'var'}, $par->{'val'});
    }
    elsif ($typ ne q{@})
    { die get_string('BAD_ASSIGN', $nam);
    }
  }

  # Create the operator
  return bless {
    opt  => $opt,
    par  => $par,
    _blk => $blk,
    _del => \&del_error,
    _fnd => \&find_error,
    _get => \&_get_sort,
    _lft => q{},
    _set => \&set_error,
    _typ => $nam,
    }, 'RDA::Value::Operator';
}

sub _get_sort
{ my ($slf) = @_;
  my ($buf, $cnd, $obj, $opt, $sep, @tbl);

  # Get the arguments
  ($obj) = $slf->{'par'}->find_object;
  return RDA::Value::List->new unless defined($obj);
  $opt = $slf->{'opt'}->eval_as_string;

  # Create the sort array
  if ($obj->is_array)
  { @tbl = map {_prepare_sort($_)} @{$obj};
    $opt = '1SA' unless length($opt);
  }
  elsif ($obj->is_hash || ($obj = $obj->get_hash)->is_hash)
  { @tbl = map {_prepare_sort($obj->{$_}, $_)} keys(%{$obj});
    $opt = '0SA' unless length($opt);
  }
  else
  { $slf->{'_blk'}->get_agent->abort(get_string('BAD_SORT'));
  }

  # Decode the options
  $buf = q{};
  $sep = 'sort {';
  foreach my $str (split(/,/, $opt))
  { next unless $str =~ m/^\s*(\d+)([NS][AD])?\s*$/;
    $buf .= $sep.sprintf($tb_srt{$2 || 'SA'}, 1 + $1, 1 + $1);
    $sep = ' || ';
  }

  # Sort the values
  if ($buf)
  { local $^W = 0;
    local $SIG{'__WARN__'} = sub {};

    $buf .= '} @tbl';  ## no critic (Interpolation)
    @tbl = eval $buf;  ## no critic (Eval)
    $slf->{'_blk'}->get_agent->abort($@, get_string('ERR_SORT')) if $@;
  }

  # Return the sorted values
  return RDA::Value::List->new(map {$_->[0]} @tbl);
}

sub _prepare_sort
{ my ($obj, $key) = @_;
  my ($dat);

  return (ref($dat = $obj->eval_as_data) eq 'ARRAY')
    ? [$obj, $key, @{$dat}]
    : [$obj, $key, $dat];
}

=head2 S<tsort(%var,$opt[,$err])>

This operator performs a topological sort of the hash keys. By default, the
values indicate following keys. It supports the following options:

=over 10

=item B<    'a' > Uses an alphabetic order to ensure result stability.

=item B<    'd' > Indicates that the hash values represents dependencies.

=item B<    'n' > Uses a numeric order to ensure result stability.

=back

Cycle detection does not abort the sort when an error message is provided as
an argument. It displays the message when it is not empty and display is
allowed.

=cut

sub _ini_tsort
{ my ($blk, $nam, $arg) = @_;
  my ($err, $opt, $par, $typ);

  # Validate the arguments
  die get_string('NO_ARG', $nam) unless ref($par = shift(@{$arg}));
  $opt = shift(@{$arg}) || $VAL_NONE;
  $err = shift(@{$arg});
  die get_string('EXTRA_ARG', $nam) if @{$arg};

  if ($par->is_operator eq '.assign.')
  { $typ = $par->{'var'}->is_lvalue;
    if ($typ eq q{%})
    { $par = $blk->define_operator(['.hset.'], $par->{'var'}, $par->{'val'});
    }
    elsif ($typ ne q{@})
    { die get_string('BAD_ASSIGN', $nam);
    }
  }

  # Create the operator
  return bless {
    err  => $err,
    opt  => $opt,
    par  => $par,
    _blk => $blk,
    _del => \&del_error,
    _fnd => \&find_error,
    _get => \&_get_tsort,
    _lft => q{},
    _set => \&set_error,
    _typ => $nam,
    }, 'RDA::Value::Operator';
}

sub _get_tsort  ## no critic (Complex)
{ my ($slf) = @_;
  my ($err, $min, $obj, $opt, $ref, $top, $val, @res, @tmp, @top, %tmp);

  # Get the arguments
  ($obj) = $slf->{'par'}->find_object;
  return RDA::Value::List->new unless defined($obj);
  $opt = $slf->{'opt'}->eval_as_string;
  $min = (index($opt, 'a') >= 0) ?  1 :
         (index($opt, 'n') >= 0) ? -1 :
                                    0;

  # Identify isolated elements
  if ($obj->is_hash || ($obj = $obj->get_hash)->is_hash)
  { if (index($opt,'d') >= 0)
    { foreach my $key (@tmp = keys(%{$obj}))
      { if (($ref = ref($val = $obj->{$key}->eval_as_data)) eq 'ARRAY')
        { foreach my $itm (@{$val})
          { push(@{$tmp{$itm}}, $key);
          }
        }
        else
        { die get_string('ERR_TDESC', $key) if $ref;
          $tmp{$val} = [$key] if defined($val);
        }
      }
      @top = grep {!exists($tmp{$_})} @tmp;
    }
    else
    { foreach my $key (keys(%{$obj}))
      { if (($ref = ref($val = $obj->{$key}->eval_as_data)) ne 'ARRAY')
        { die get_string('ERR_TDESC', $key) if $ref;
          $val = defined($val) ? [$val] : [];
        }
        if (scalar @{$val})
        { $tmp{$key} = [@{$val}];
        }
        else
        { push(@top, $key);
        }
      }
    }
  }
  elsif ($obj->is_list)
  { @top = $obj->eval_as_data;
  }
  elsif ($obj->is_array)
  { @top = @{$obj->eval_as_data};
  }
  else
  { $slf->{'_blk'}->get_agent->abort(get_string('BAD_TSORT'));
  }

  # Perform the topological sort
  if ($min > 0)
  { for (;;)  ## no critic (Loop)
    { $top = undef;
      foreach my $itm (@top)
      { $top = $itm unless defined($top) && $top lt $itm; ## no critic (Unless)
      }
      last unless defined($top);
      @top = grep {$_ ne $top} @top;
      push(@res, $top);
      foreach my $key (keys(%tmp))
      { if (@tmp = grep {$_ ne $top} @{$tmp{$key}})
        { $tmp{$key} = [@tmp];
        }
        else
        { push(@top, $key);
          delete($tmp{$key});
        }
      }
    }
  }
  elsif ($min < 0)
  { for (;;)  ## no critic (Loop)
    { $top = undef;
      foreach my $itm (@top)
      { $top = $itm unless defined($top) && $top < $itm; ## no critic (Unless)
      }
      last unless defined($top);
      @top = grep {$_ != $top} @top;
      push(@res, $top);
      foreach my $key (keys(%tmp))
      { if (@tmp = grep {$_ != $top} @{$tmp{$key}})
        { $tmp{$key} = [@tmp];
        }
        else
        { push(@top, $key);
          delete($tmp{$key});
        }
      }
    }
  }
  else
  { while (defined($top = shift(@top)))
    { push(@res, $top);
      foreach my $key (keys(%tmp))
      { if (@tmp = grep {$_ ne $top} @{$tmp{$key}})
        { $tmp{$key} = [@tmp];
        }
        else
        { push(@top, $key);
          delete($tmp{$key});
        }
      }
    }
  }

  # Treat cyclic references
  if (@tmp = keys(%tmp))
  { die get_string('ERR_TSORT') unless defined($slf->{'err'});
    if (length($err = $slf->{'err'}->eval_as_string))
    { $top = $slf->{'_blk'}->get_top;
      $top->get_display->dsp_line($err, 1) unless $top->get_info('oput');
    }
    if ($min > 0)
    { push(@res, sort @tmp);
    }
    elsif ($min < 0)
    { push(@res, sort {$a <=> $b} @tmp);
    }
    else
    { push(@res, @tmp);
    }
  }

  # Return the results
  return RDA::Value::List::new_from_data(@res);
}

# --- Common routines ---------------------------------------------------------

sub _left_pair
{ my ($slf) = @_;
  my ($cnd, $typ, $val, @arg);

  $typ = q{};
  @arg = @{$slf->{'arg'}};
  while (($cnd, $val) = splice(@arg, 0, 2))
  { return _test_pair($cnd, $typ) unless defined($val);
    return q{}                    unless ($typ = _test_pair($val, $typ));
  }
  return $typ;
}

sub _test_pair
{ my ($val, $prv) = @_;
  my ($typ);

  $typ = $val->is_lvalue;
  return !$typ ? q{} : ($prv eq q{} || $prv eq $typ) ? $typ : q{-};
}

1;

__END__

=head1 SEE ALSO

L<RDA::Agent|RDA::Agent>,
L<RDA::Object::Rda|RDA::Object::Rda>,
L<RDA::Object::View|RDA::Object::View>,
L<RDA::SDCL::Block|RDA::SDCL::Block>,
L<RDA::SDCL::Context|RDA::SDCL::Context>,
L<RDA::Text|RDA::Text>,
L<RDA::Value::Array|RDA::Value::Array>,
L<RDA::Value::Assoc|RDA::Value::Assoc>,
L<RDA::Value::Hash|RDA::Value::Hash>,
L<RDA::Value::List|RDA::Value::List>,
L<RDA::Value::Operator|RDA::Value::Operator>,
L<RDA::Value::Scalar|RDA::Value::Scalar>

=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