# Value.pm: Class Used for Managing Values

package RDA::SDCL::Value;

# $Id: Value.pm,v 1.12 2015/02/12 13:13:03 RDA Exp $
# ARCS: $Header: /home/cvs/cvs/RDA_8/src/scripting/lib/RDA/SDCL/Value.pm,v 1.12 2015/02/12 13:13:03 RDA Exp $
#
# Change History
# 20150212  MSC  Add the is_editable method.

=head1 NAME

RDA::SDCL::Value - Class Used for Managing Values

=head1 SYNOPSIS

 require RDA::SDCL::Value;

=head1 DESCRIPTION

The C<RDA::SDCL::Value> class regroups the methods common to all value
subclasses.

The following methods are available:

=cut

use strict;

BEGIN
{ use Exporter;
  use RDA::Text qw(get_string);
  use RDA::Value::Scalar qw(:value);
}

# Define the global public variables
use vars qw($STRINGS $VALUE $VERSION @ISA @EXPORT_OK);
$VALUE     = qr/^RDA::Value::[A-Z]\w+$/i;
$VERSION   = sprintf('%d.%02d', q$Revision: 1.12 $ =~ /(\d+)\.(\d+)/);
@EXPORT_OK = qw(convert_value conv_array conv_hash copy_array copy_hash
                $VALUE);
@ISA       = qw(Exporter);

# Define the global private constants
my $CODE    = 'RDA::Value::Code';
my $HASH    = 'RDA::Value::Hash';
my $LIST    = 'RDA::Value::List';
my $POINTER = 'RDA::Value::Pointer';
my $SCALAR  = 'RDA::Value::Scalar';

my $ARRAY  = qr/^RDA::Value::(Array|List)$/i;
my $ASSOC  = qr/^RDA::Value::(Assoc|Hash)$/i;

# Define the global private variables

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

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

This method returns the internal hash of an object. Otherwise, it returns the
object reference.

=cut

sub get_hash
{ return shift;
}

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

This method returns the value that is associated with a given attribute. When
the attribute does not exist, it returns the default value.

=cut

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

  $val = $slf->{$key} if exists($slf->{$key});
  return $val;
}

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

This method indicates whether the value has methods.

=cut

sub has_methods
{ return 0;
}

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

This method indicates whether the value is a list or an array.

=cut

sub is_array
{ return 0;
}

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

This method indicates whether it assimilates the value to a macro call or an
object method invocation.

=cut

sub is_call
{ return 0;
}

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

This method indicates whether the value is a named block.

=cut

sub is_code
{ return q{};
}

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

This method indicates whether the value is defined.

=cut

sub is_defined
{ return 1;
}

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

This method indicates whether the value can be modified.

=cut

sub is_editable
{ return shift->is_lvalue(@_);
}

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

This method indicates whether the value is an associative array.

=cut

sub is_hash
{ return 0;
}

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

This method indicates whether the value is a list item.

=cut

sub is_item
{ return 1;
}

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

This method indicates whether the value is a list.

=cut

sub is_list
{ return 0;
}

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

This method indicates whether the value can be used as a left value.

=cut

sub is_lvalue
{ return q{};
}

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

This method indicates whether the value is a method invocation.

=cut

sub is_method
{ return q{};
}

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

This method indicates whether the value is an object.

=cut

sub is_object
{ return q{};
}

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

This method indicates whether the value is an operator.

=cut

sub is_operator
{ return q{};
}

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

This method indicates whether the value is a variable pointer.

=cut

sub is_pointer
{ return q{};
}

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

This method indicates whether the value is a left value that requires a scalar
in assignment.

=cut

sub is_scalar_lvalue
{ return shift->is_lvalue eq q{$};
}

=head2 S<$h-E<gt>set_info($key,$val)>

This method assigns the specified value to a given key.

=cut

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

  return $slf->{$key} = $val;
}

=head1 ASSIGN AND EVAL METHODS

=head2 S<$h-E<gt>assign_value($val[,$flg])>

This method assigns a new value. It evaluates the new value unless the flag is
set. It returns the new value.

=cut

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

  # Evaluate the value
  $val = $val->eval_value unless $flg;

  # Perform the assignment and return the value
  $trc->[0]->trace_value($trc->[1], $trc->[2])
    if ($trc = $slf->is_list
      ? $slf->assign_item($val->is_list ? [@{$val}] : [$val])
      : $slf->assign_var($val));

  # Return the value
  return $val;
}

sub assign_item
{ die get_string('BAD_LVALUE', ref(shift));
}

sub assign_var
{ die get_string('BAD_LVALUE', ref(shift));
}

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

  die get_string('BAD_FIND', ref($slf)) if $typ;
  return ();
}

=head2 S<RDA::SDCL::Value::convert_value($val)>

This method converts a Perl value into a value.

=cut

sub convert_value
{ return _gen_value({}, @_);
}

sub _gen_value
{ my ($tbl, $val) = @_;
  my ($ref);

  $ref = ref($val);
  return
    ($ref =~ $VALUE)               ? $val :
    ($ref && exists($tbl->{$val})) ? $tbl->{$val} :
    ($ref eq 'ARRAY')              ? _gen_array($tbl, $val) :
    ($ref eq 'HASH')               ? _gen_hash($tbl, $val) :
                                     _new_scalar($val);
}

sub _gen_array
{ my ($tbl, $src) = @_;
  my ($dst);

  $tbl->{$src} = $dst = _new_array();
  foreach my $itm (@{$src})
  { push(@{$dst}, _gen_value($tbl, $itm));
  }
  return $dst;
}

sub _gen_hash
{ my ($tbl, $src) = @_;
  my ($dst);

  $tbl->{$src} = $dst = _new_assoc();
  foreach my $key (keys(%{$src}))
  { $dst->{$key} = _gen_value($tbl, $src->{$key});
  }
  return $dst;
}

=head2 S<$h-E<gt>copy_value($flg)>

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

=cut

sub copy_value
{ return shift;
}

sub copy_array
{ my ($dst, $src, $tbl, $flg) = @_;

  $tbl->{$src} = $dst;
  foreach my $val (@{$src})
  { copy_index($dst, $tbl, $val, $flg);
  }
  return $dst;
}

sub copy_hash
{ my ($dst, $src, $tbl, $flg) = @_;

  $tbl->{$src} = $dst;
  foreach my $key (keys(%{$src}))
  { $dst->{$key} = copy_key($tbl, $src->{$key}, $flg);
  }
  return $dst;
}

sub copy_index
{ my ($dst, $tbl, $val, $flg) = @_;
  my ($ref);

  $ref = ref($val);
  if ($ref eq $SCALAR)
  { push(@{$dst}, $val)
  }
  elsif ($ref && exists($tbl->{$val}))
  { push(@{$dst}, $tbl->{$val});
  }
  elsif ($ref =~ $ARRAY)
  { push(@{$dst}, copy_array($val->new, $val, $tbl, $flg));
  }
  elsif ($ref =~ $ASSOC)
  { push(@{$dst}, copy_hash($val->new, $val, $tbl, $flg));
  }
  elsif ($ref =~ $VALUE)
  { if ($flg)
    { $tbl->{$val} = $val;
      copy_index($dst, $tbl, $val->copy_object(1));
    }
    else
    { push(@{$dst}, $val);
    }
  }
  elsif ($ref eq 'ARRAY')
  { push(@{$dst}, copy_array(_new_array(), $val, $tbl, $flg));
  }
  elsif ($ref eq 'HASH')
  { push(@{$dst}, copy_hash(_new_assoc(), $val, $tbl, $flg));
  }
  else
  { push(@{$dst}, _new_scalar($val));
  }
  return;
}

sub copy_key
{ my ($tbl, $val, $flg) = @_;
  my ($ref);

  $ref = ref($val);
  return
    ($ref eq $SCALAR) ?
      $val :
    ($ref && exists($tbl->{$val})) ?
      $tbl->{$val} :
    ($ref =~ $ARRAY) ?
      copy_array($val->new, $val, $tbl, $flg) :
    ($ref =~ $ASSOC) ?
      copy_hash($val->new, $val, $tbl, $flg) :
    ($ref =~ $VALUE) ?
      ($flg ? copy_key($tbl, ($tbl->{$val} = $val)->copy_object($flg)) : $val) :
    ($ref eq 'ARRAY') ?
      copy_array(_new_array(), $val, $tbl, $flg) :
    ($ref eq 'HASH') ?
      copy_hash(_new_assoc(), $val, $tbl, $flg) :
    _new_scalar($val);
}

sub copy_object
{ return shift;
}

=head2 S<$h-E<gt>decr_value([$num])>

This method decrements a value and returns the new value.

=cut

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

  return $slf->assign_var(defined($val) ? -$val : -1, 1);
}

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

This method deletes a left value or a list of left values and returns their
previous content.

=cut

sub delete_value
{ die get_string('BAD_DELETE', ref(shift));
}

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

This method evaluates the value and returns the evaluation result as a Perl
list. It executes code values. When the flag is set, the value is directly
converted without being evaluated again.

=cut

sub eval_as_array
{ return shift->eval_value(1)->as_array;
}

=head2 S<$h-E<gt>eval_as_data([$flg])>

This method evaluates the value and returns the evaluation result as a Perl
data structure.

When the flag is set, it executes code values.

=cut

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

  return $slf->eval_value($flg)->as_data($flg);
}

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

This method evaluates the value and returns the evaluation result as a text
line. It executes code values. It ignores all undefined values and object
references.

=cut

sub eval_as_line
{ return shift->eval_value(1)->as_line;
}

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

This method evaluates the value and returns the evaluation result as a Perl
number. It executes code values.

=cut

sub eval_as_number
{ return shift->eval_value(1)->as_number;
}

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

This method evaluates the value and returns the evaluation result as a Perl
scalar. It executes code values.

=cut

sub eval_as_scalar
{ return shift->eval_value(1)->as_scalar;
}

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

This method evaluates the value and returns the evaluation result as a Perl
string. It executes code values.

=cut

sub eval_as_string
{ return shift->eval_value(1)->as_string;
}

=head2 S<$h-E<gt>eval_code($dft)>

This method resolves code values.

=cut

sub eval_code
{ return shift;
}

=head2 S<$h-E<gt>eval_value([$flg])>

This method evaluates a value. It resolves the variables and executes
appropriate macro calls. When there is an evaluation problem, it returns an
undefined value.

When the flag is set, it executes code values.

=cut

sub eval_value
{ return shift;
}

=head2 S<$h-E<gt>incr_value([$num])>

This method increments a value and returns the new value.

=cut

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

  return $slf->assign_var(defined($val) ? $val : 1, 1);
}

=head1 CONVERSION METHODS

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

This method converts the value in a Perl list, without altering complex data
structures.

=cut

sub as_array
{ die get_string('BAD_ARRAY', ref(shift));
}

=head2 S<$h-E<gt>as_data([$flg])>

This method converts the value as a list of Perl data structures. When the flag
is set, it executes code blocks.

=cut

sub as_data
{ return shift;
}

sub conv_array
{ my ($dst, $src, $tbl, $flg) = @_;

  $tbl->{$src} = $dst;
  foreach my $val (@{$src})
  { conv_index($dst, $tbl, $val, $flg);
  }
  return $dst;
}

sub conv_hash
{ my ($dst, $src, $tbl, $flg) = @_;

  $tbl->{$src} = $dst;
  foreach my $key (keys(%{$src}))
  { $dst->{$key} = conv_key($tbl, $src->{$key}, $flg);
  }
  return $dst;
}

sub conv_index
{ my ($dst, $tbl, $val, $flg) = @_;
  my ($ref);

  $ref = ref($val);
  if ($ref eq $SCALAR)
  { push(@{$dst}, $val->as_scalar)
  }
  elsif ($ref eq $LIST)
  { push(@{$dst}, @{$val});
  }
  elsif ($ref eq $HASH)
  { push(@{$dst}, %{$val});
  }
  elsif ($ref && exists($tbl->{$val}))
  { push(@{$dst}, $tbl->{$val});
  }
  elsif ($ref eq 'ARRAY' || $ref =~ $ARRAY)
  { push(@{$dst}, conv_array([], $val, $tbl, $flg));
  }
  elsif ($ref eq 'HASH' || $ref =~ $ASSOC)
  { push(@{$dst}, conv_hash({}, $val, $tbl, $flg));
  }
  elsif ($ref eq $POINTER)
  { conv_index($dst, $tbl, $val->get_value, $flg);
  }
  elsif ($ref eq $CODE)
  { push(@{$dst}, $val->as_data($flg));
  }
  elsif ($ref =~ $VALUE)
  { conv_index($dst, $tbl, $val->eval_value($flg), $flg);
  }
  else
  { push(@{$dst}, $val);
  }
  return;
}

sub conv_key
{ my ($tbl, $val, $flg) = @_;
  my ($ref);

  $ref = ref($val);
  return
    ($ref eq $SCALAR)      ? $val->as_scalar :
    ($ref &&
     exists($tbl->{$val})) ? $tbl->{$val} :
    ($ref eq 'ARRAY' ||
     $ref =~ $ARRAY)       ? conv_array([], $val, $tbl, $flg) :
    ($ref eq 'HASH' ||
     $ref =~ $ASSOC)       ? conv_hash({}, $val, $tbl, $flg) :
    ($ref eq $POINTER)     ? conv_key($tbl, $val->get_value, $flg) :
    ($ref eq $CODE)        ? $val->as_data($flg) :
    ($ref =~ $VALUE)       ? conv_key($tbl, $val->eval_value($flg), $flg) :
                             $val;
}

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

This method converts the value as a dump string.

=cut

sub as_dump
{ return shift->dump;
}

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

This method converts the value as a text line. It ignores all undefined values
and all object references.

=cut

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

  return join(q{}, grep {defined($_) && !ref($_)} $slf->as_array).qq{\n};
}

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

This method indicates that no attribute name is associated with the value.

=cut

sub as_name
{ return;
}

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

This method converts the value as a Perl number.

=cut

sub as_number
{ die get_string('BAD_NUMBER');
}

=head2 S<$h-E<gt>as_string($dft)>

This method converts the value as a Perl string. When the conversion is not
possible it generates an error, except if a default value is provided.

=cut

sub as_string
{ my ($slf, $dft) = @_;

  die get_string('BAD_TEXT') unless defined($dft);
  return $dft;
}

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

This method converts the value as a Perl scalar.

=cut

sub as_scalar
{ return;
}

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

sub _new_array
{ require RDA::Value::Array;
  return RDA::Value::Array->new;
}

sub _new_assoc
{ require RDA::Value::Assoc;
  return RDA::Value::Assoc->new;
}

sub _new_scalar
{ return RDA::Value::Scalar::new_from_data(@_);
}

1;

__END__

=head1 SEE ALSO

L<RDA::Agent|RDA::Agent>,
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::Explorer|RDA::Object::Explorer>,
L<RDA::Object::Ftp|RDA::Object::Ftp>,
L<RDA::Object::Hcve|RDA::Object::Hcve>,
L<RDA::Object::Html|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::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::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::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