# Hash.pm: Class Used for Managing Hash Operators

package RDA::Operator::Hash;

# $Id: Hash.pm,v 1.10 2015/02/12 13:14:33 RDA Exp $
# ARCS: $Header: /home/cvs/cvs/RDA_8/src/scripting/lib/RDA/Operator/Hash.pm,v 1.10 2015/02/12 13:14:33 RDA Exp $
#
# Change History
# 20150212  MSC  Add the is_editable method.

=head1 NAME

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

=head1 SYNOPSIS

 require RDA::Operator::Hash;

=head1 DESCRIPTION

This package regroups the definition of the hash operators.

The following methods are available:

=cut

use strict;

BEGIN
{ use Exporter;
  use RDA::Text qw(get_string);
  use RDA::Value::Operator qw(del_error find_error get_error set_error);
  use RDA::Value::Array;
  use RDA::Value::Assoc;
  use RDA::Value::Hash;
  use RDA::Value::List;
  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.10 $ =~ /(\d+)\.(\d+)/);
@ISA     = qw(Exporter);

# Define the global private constants

# Define the global private variables
my %tb_ini = (
  '.assoc.' => \&_ini_assoc,
  '.hash.'  => \&_ini_hash,
  '.hset.'  => \&_ini_hset,
  '.key.'   => \&_ini_key,
  'keys'    => \&_ini_keys,
  'resolve' => \&_ini_resolve,
  'values'  => \&_ini_values,
  );
my %tb_key = (
  q{*}  => \&_keys_all,
  q{IA} => \&_keys_ia,
  q{ID} => \&_keys_id,
  q{KA} => \&_keys_ka,
  q{KD} => \&_keys_kd,
  q{NA} => \&_keys_na,
  q{ND} => \&_keys_nd,
  q{SA} => \&_keys_sa,
  q{SD} => \&_keys_sd,
  );
my %tb_stl = (
  q{*} => q{**},
  q{'} => q{''},
  q{`} => q{``},
  );
my %tb_val = (
  q{IA} => \&_values_ia,
  q{ID} => \&_values_id,
  q{KA} => \&_values_ka,
  q{KD} => \&_values_kd,
  q{NA} => \&_values_na,
  q{ND} => \&_values_nd,
  q{SA} => \&_values_sa,
  q{SD} => \&_values_sd,
  );

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

=head2 S<$h = RDA::Operator::Hash-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 OPERATOR DEFINITIONS

=head2 S<.assoc.($par)>

This operator transforms a list in an associative array.

=cut

sub _ini_assoc
{ my ($arg) = @_;

  return bless {
    arg  => $arg,
    _del => \&del_error,
    _fnd => \&_find_assoc,
    _get => \&_get_assoc,
    _lft => q{},
    _set => \&set_error,
    _typ => '.assoc.',
    }, 'RDA::Value::Operator';
}

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

  return (RDA::Value::Assoc::new_from_list($slf->{'arg'}->eval_value(1)));
}

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

  return RDA::Value::Assoc::new_from_list($slf->{'arg'}->eval_value($flg));
}

=head2 S<.hash.($par)>

This operator transforms an associative array in a hash.

=cut

sub _ini_hash
{ my ($par) = @_;

  return bless {
    par  => $par,
    _del => \&del_error,
    _fnd => \&_find_hash,
    _get => \&_get_hash,
    _lft => q{},
    _set => \&set_error,
    _typ => '.hash.',
    }, 'RDA::Value::Operator';
}

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

  ($val, $trc) = $slf->{'par'}->find_object($typ);
  return ((defined($val) && $val->is_defined)
    ? RDA::Value::Hash::new_from_hash($val->get_hash)
    : RDA::Value::Hash->new, $trc);
}

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

  ($val) = $slf->{'par'}->find_object;
  return (defined($val) && $val->is_defined)
    ? RDA::Value::Hash::new_from_hash($val->get_hash)->eval_value($flg)
    : RDA::Value::List->new;
}

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

This operator assigns the value to the specified hash variable and returns the
variable.

=cut

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

  # Validate the arguments
  die get_string('BAD_LVALUE') unless $var->is_lvalue eq q{%};
  die get_string('NO_RVALUE') unless ref($val);

  # Create the operator
  return bless {
    val  => $val,
    var  => $var,
    _del => \&del_error,
    _fnd => \&_find_hset,
    _get => \&_get_hset,
    _lft => q{%},
    _set => \&set_error,
    _typ => '.hset.',
    }, 'RDA::Value::Operator';
}

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

  $slf->{'var'}->assign_value($slf->{'val'});
  return $slf->{'var'}->find_object($typ);
}

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

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

=head2 S<.key.($par,$arg)>

This operator selects a hash entry. It supports multidimensional hashes.

=cut

sub _ini_key
{ my ($par, $arg) = @_;

  return bless {
    arg  => $arg,
    par  => $par,
    _del => \&_del_key,
    _fnd => \&_find_key,
    _get => \&_get_key,
    _lft => \&_is_editable,
    _set => \&_set_key,
    _typ => '.key.',
    }, 'RDA::Value::Operator';
}

sub _decode_key
{ my ($val) = @_;

  $val = $val->eval_value(1);
  return (map {_decode_key($_)} @{$val}) if $val->is_list;
  return $val->as_string;
}

sub _del_key
{ my ($slf) = @_;
  my ($obj, $off, $trc, @tbl);

  # Validate the indexes
  @tbl = @{$slf->{'arg'}};
  @tbl = map {_decode_key($_)} @tbl;
  $off = pop(@tbl);

  # Get the parent object
  ($obj, $trc) = $slf->{'par'}->find_object(q{%});

  # Find the current object
  foreach my $itm (@tbl)
  { return () unless exists($obj->{$itm}) && $obj->{$itm}->is_defined;
    $obj = $obj->{$itm};
    return () unless $obj->is_hash || ($obj = $obj->get_hash)->is_hash;
  }

  # Delete the value
  return (delete($obj->{$off}), $trc);
}

sub _find_key
{ my ($slf, $typ) = @_;
  my ($obj, $off, $trc, @tbl);

  # Validate the keys
  @tbl = @{$slf->{'arg'}};
  @tbl = map {_decode_key($_)} @tbl;
  $off = pop(@tbl);

  # Find the current object
  ($obj, $trc) = $slf->{'par'}->find_object(q{%});
  if (defined($obj))
  { die get_string('WANT_HASH')
      unless $obj->is_hash || ($obj = $obj->get_hash)->is_hash;
    foreach my $itm (@tbl)
    { unless (exists($obj->{$itm}) && $obj->{$itm}->is_defined)
      { return () unless $typ;
        $obj->{$itm} = RDA::Value::Assoc->new;
      }
      $obj = $obj->{$itm};
      die get_string('WANT_HASH')
        unless $obj->is_hash || ($obj = $obj->get_hash)->is_hash;
    }
  }

  # Treat the last level
  unless ($typ)
  { return ($obj->{$off}) if exists($obj->{$off});
    return ();
  }
  unless (exists($obj->{$off}) && $obj->{$off}->is_defined)
  { $obj->{$off} = ($typ eq q{@}) ? RDA::Value::Array->new :
                   ($typ eq q{%}) ? RDA::Value::Assoc->new :
                                    $VAL_UNDEF;
  }
  return ($obj->{$off}, $trc);
}

sub _get_key
{ my ($slf, $flg) = @_;
  my ($rec, @tbl);

  # Validate the keys
  @tbl = @{$slf->{'arg'}};
  @tbl = map {_decode_key($_)} @tbl;

  # Get the key value
  ($rec) = $slf->{'par'}->find_object;
  foreach my $off (@tbl)
  { return $VAL_UNDEF unless defined($rec) && $rec->is_defined;
    die get_string('WANT_HASH')
      unless $rec->is_hash || ($rec = $rec->get_hash)->is_hash;
    $rec = $rec->{$off};
  }
  return ref($rec) ? $rec->eval_value($flg) : $VAL_UNDEF;
}

sub _set_key
{ my ($slf, $typ, $val, $flg) = @_;
  my ($obj, $off, $trc, @tbl);

  # Adjust the value
  $val = shift(@{$val}) || $VAL_UNDEF if $typ;

  # Validate the keys
  @tbl = @{$slf->{'arg'}};
  @tbl = map {_decode_key($_)} @tbl;
  $off = pop(@tbl);

  # Get the parent object
  ($obj, $trc) = $slf->{'par'}->find_object(q{%});
  die get_string('WANT_HASH')
    unless $obj->is_hash || ($obj = $obj->get_hash)->is_hash;

  # Find the current object
  foreach my $itm (@tbl)
  { $obj->{$itm} = RDA::Value::Assoc->new
      unless exists($obj->{$itm}) && $obj->{$itm}->is_defined;
    $obj = $obj->{$itm};
    die get_string('WANT_HASH')
      unless $obj->is_hash || ($obj = $obj->get_hash)->is_hash;
  }

  # Set the value
  if ($flg)
  { $val += $obj->{$off}->as_number if exists($obj->{$off});
    $obj->{$off} = $val = new_number($val);
    $trc->[0]->trace_value($trc->[1], $trc->[2]) if $trc;
    return $val;
  }
  else
  { $obj->{$off} = $val->is_list
      ? new_number(scalar @{$val})
      : $val;
  }
  return $trc;
}

=head2 S<keys(%hash[,$opt])>

This operator returns the list of all keys used in the specified hash. By
default, it sorts the keys in alphabetic order. You can specify sort
criteria as an argument:

=over 10

=item B<    'IA' > By their keys, sorted numerically ascending

=item B<    'ID' > By their keys, sorted numerically descending

=item B<    'KA' > By their keys, sorted alphabetically

=item B<    'KD' > By their keys, in reverse alphabetic order

=item B<    'NA' > By their values, sorted numerically ascending

=item B<    'ND' > By their values, sorted numerically descending

=item B<    'SA' > By their values, sorted alphabetically

=item B<    'SD' > By their values, in reverse alphabetic order

=back

The hash is not implicitly defined by this operator.

When you specify C<*> as sort criteria, it returns all valid key lists for the
specified hash.

=cut

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

  # 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};

  # Transform assign operator when required
  $par = _ini_hset($par->{'var'}, $par->{'val'})
    if $par->is_operator eq '.assign.' && $par->{'var'}->is_lvalue eq q{%};

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

sub _find_keys
{ return (_get_keys(shift));
}

sub _get_keys
{ my ($slf) = @_;
  my ($hsh, $opt);

  # Get the hash
  ($hsh) = $slf->{'par'}->find_object;
  return RDA::Value::List->new unless defined($hsh) && $hsh->is_defined;
  die get_string('WANT_HASH')
    unless $hsh->is_hash || ($hsh = $hsh->get_hash)->is_hash;

  # Get the sort type
  $opt = uc($slf->{'opt'}->eval_as_string);
  return exists($tb_key{$opt}) ? &{$tb_key{$opt}}($hsh) : _keys_ka($hsh);
}

## no critic (Reverse)
sub _keys_ia
{ my ($hsh) = @_;

  return RDA::Value::List::new_from_data(sort {$a <=> $b} keys(%{$hsh}));
}

sub _keys_id
{ my ($hsh) = @_;

  return RDA::Value::List::new_from_data(sort {$b <=> $a} keys(%{$hsh}));
}

sub _keys_ka
{ my ($hsh) = @_;

  return RDA::Value::List::new_from_data(sort keys(%{$hsh}));
}

sub _keys_kd
{ my ($hsh) = @_;

  return RDA::Value::List::new_from_data(sort {$b cmp $a} keys(%{$hsh}));
}

sub _keys_na
{ my ($hsh) = @_;

  my %tbl = map {$_ => $hsh->{$_}->eval_as_number} keys(%{$hsh});
  return RDA::Value::List::new_from_data(
    sort {$tbl{$a} <=> $tbl{$b} or $a cmp $b} keys(%tbl));
}

sub _keys_nd
{ my ($hsh) = @_;

  my %tbl = map {$_ => $hsh->{$_}->eval_as_number} keys(%{$hsh});
  return RDA::Value::List::new_from_data(
    sort {$tbl{$b} <=> $tbl{$a} or $a cmp $b} keys(%tbl));
}

sub _keys_sa
{ my ($hsh) = @_;

  my %tbl = map {$_ => $hsh->{$_}->eval_as_string} keys(%{$hsh});
  return RDA::Value::List::new_from_data(
    sort {$tbl{$a} cmp $tbl{$b} or $a cmp $b} keys(%tbl));
}

sub _keys_sd
{ my ($hsh) = @_;

  my %tbl = map {$_ => $hsh->{$_}->eval_as_string} keys(%{$hsh});
  return RDA::Value::List::new_from_data(
    sort {$tbl{$b} cmp $tbl{$a} or $a cmp $b} keys(%tbl));
}
## use critic

sub _keys_all
{ return RDA::Value::List->new(_keys_sub(shift));
}

sub _keys_sub
{ my ($hsh, @key) = @_;
  my (@tbl);

  foreach my $key (sort keys(%{$hsh}))
  { if (ref($hsh->{$key}) =~ m/^(HASH|RDA::Value::(Assoc|Hash))$/)
    { push(@tbl,
        _keys_sub($hsh->{$key}, @key, RDA::Value::Scalar::new_text($key)));
    }
    else
    { push(@tbl,
        RDA::Value::Array->new(@key, RDA::Value::Scalar::new_text($key)));
    }
  }
  return @tbl;
}

=head2 S<resolve(%hash,$string)>

This operator resolves hash key references from the string, using the specified
hash. It supports nested references. The following reference formats are
supported:

=over 20

=item B<    ${key}>

Replaces the reference by the hash key value. When the key is not defined, it
replaces the reference with an empty string.

=item B<    ${key:dft}>

Replaces the reference by the hash key value. When the key is not defined, it
replaces the reference with the default text.

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

Replaces the reference by the specified text when the hash key
exists. Otherwise, it replaces the reference with the default text.

=back

You can prefix the key with a character that indicates on how to emphasize the
key value. It is not used for other replacement texts. The valid style
characters are as follows:

=over 6

=item S<    *> for bold

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

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

=back

It returns the resulting value.

=cut

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

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

  # Transform assign operator when required
  $par = _ini_hset($par->{'var'}, $par->{'val'})
    if $par->is_operator eq '.assign.' && $par->{'var'}->is_lvalue eq q{%};

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

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

  ($hsh) = $slf->{'par'}->find_object;
  $hsh = {}
    unless defined($hsh) && $hsh->is_defined
      && ($hsh->is_hash || ($hsh = $hsh->get_hash)->is_hash);
  $str = $slf->{'str'}->eval_as_string;
  1 while $str =~ s/\$\{([\*\'\`])?(\w+)((\?)([^\{\}]*?))?(\:([^\{\}]*?))?\}/
                    _resolve($hsh, $1, $2, $4, $5, $7)/eg;
  return RDA::Value::Scalar::new_text($str);
}

sub _resolve
{ my ($hsh, $stl, $key, $tst, $txt, $dft) = @_;
  my $str;

  return defined($dft) ? $dft : q{} unless exists($hsh->{$key});
  return defined($txt) ? $txt : q{} if $tst;
  $str = eval '$hsh->{$key}->eval_as_string';  ## no critic (Eval,Interpolation)
  return defined($dft) ? $dft : q{} if $@;
  return ($stl && exists($tb_stl{$stl}))
    ? $tb_stl{$stl}.$str.$tb_stl{$stl}
    : $str;
}

=head2 S<values(%hash[,$opt])>

This operator returns the list of all values used in the specified hash. By
default, it does not sort the values. You can specify sort criteria as an
argument:

=over 10

=item B<    'IA' > By their keys, sorted numerically ascending

=item B<    'ID' > By their keys, sorted numerically descending

=item B<    'KA' > By their keys, sorted alphabetically

=item B<    'KD' > By their keys, in reverse alphabetic order

=item B<    'NA' > By their values, sorted numerically ascending

=item B<    'ND' > By their values, sorted numerically descending

=item B<    'SA' > By their values, sorted alphabetically

=item B<    'SD' > By their values, in reverse alphabetic order

=back

The hash is not implicitly defined by this operator.

=cut

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

  # 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};

  # Transform assign operator when required
  $par = _ini_hset($par->{'var'}, $par->{'val'})
    if $par->is_operator eq '.assign.' && $par->{'var'}->is_lvalue eq q{%};

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

sub _find_values
{ return (_get_values(shift));
}

sub _get_values
{ my ($slf) = @_;
  my ($hsh, $opt);

  # Get the hash
  ($hsh) = $slf->{'par'}->find_object;
  return RDA::Value::List->new unless defined($hsh) && $hsh->is_defined;
  die get_string('WANT_HASH')
    unless $hsh->is_hash || ($hsh = $hsh->get_hash)->is_hash;

  # Get the sort type
  return exists($tb_val{$opt = uc($slf->{'opt'}->eval_as_string)})
    ? &{$tb_val{$opt}}($hsh)
    : RDA::Value::List->new(values(%{$hsh}));
}

## no critic (Reverse)
sub _values_ia
{ my ($hsh) = @_;

  return RDA::Value::List->new(map {$hsh->{$_}} sort {$a <=> $b} keys(%{$hsh}));
}

sub _values_id
{ my ($hsh) = @_;

  return RDA::Value::List->new(map {$hsh->{$_}} sort {$b <=> $a} keys(%{$hsh}));
}

sub _values_ka
{ my ($hsh) = @_;

  return RDA::Value::List->new(map {$hsh->{$_}} sort keys(%{$hsh}));
}

sub _values_kd
{ my ($hsh) = @_;

  return RDA::Value::List->new(map {$hsh->{$_}} sort {$b cmp $a} keys(%{$hsh}));
}

sub _values_na
{ my ($hsh) = @_;

  my %tbl = map {$_ => $hsh->{$_}->eval_as_number} keys(%{$hsh});
  return RDA::Value::List->new(map {$hsh->{$_}}
    sort {$tbl{$a} <=> $tbl{$b} or $a cmp $b} keys(%tbl));
}

sub _values_nd
{ my ($hsh) = @_;

  my %tbl = map {$_ => $hsh->{$_}->eval_as_number} keys(%{$hsh});
  return RDA::Value::List->new(map {$hsh->{$_}}
    sort {$tbl{$b} <=> $tbl{$a} or $a cmp $b} keys(%tbl));
}

sub _values_sa
{ my ($hsh) = @_;

  my %tbl = map {$_ => $hsh->{$_}->eval_as_string} keys(%{$hsh});
  return RDA::Value::List->new(map {$hsh->{$_}}
    sort {$tbl{$a} cmp $tbl{$b} or $a cmp $b} keys(%tbl));
}

sub _values_sd
{ my ($hsh) = @_;

  my %tbl = map {$_ => $hsh->{$_}->eval_as_string} keys(%{$hsh});
  return RDA::Value::List->new(map {$hsh->{$_}}
    sort {$tbl{$b} cmp $tbl{$a} or $a cmp $b} keys(%tbl));
}
## use critic

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

sub _is_editable
{ return shift->{'par'}->is_editable ? q{$} : q{};
}

1;

__END__

=head1 SEE ALSO

L<RDA::Agent|RDA::Agent>,
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