# Scalar.pm: Class Used for Managing Scalar Values

package RDA::Value::Scalar;

# $Id: Scalar.pm,v 1.9 2014/12/23 10:30:31 RDA Exp $
# ARCS: $Header: /home/cvs/cvs/RDA_8/src/scripting/lib/RDA/Value/Scalar.pm,v 1.9 2014/12/23 10:30:31 RDA Exp $
#
# Change History
# 20141223  MSC  Add :data as import tag.

=head1 NAME

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

=head1 SYNOPSIS

 require RDA::Value::Scalar;

=head1 DESCRIPTION

The objects of the C<RDA::Value::Scalar> class are used to manage scalar
values.

The following value types are supported:

=over 8

=item B<    'C'> Class object

=item B<    'N'> Number

=item B<    'O'> Object

=item B<    'T'> Text String

=item B<    'U'> Undef

=back

The following methods are available:

=cut

use strict;

BEGIN
{ use Exporter;
  use RDA::Text qw(get_string);
  use RDA::Object;

  use vars qw(@EXPORT_OK %EXPORT_TAGS
              $DIE $DIE_A $DIE_B $DIE_M $DIE_S $DIE_X
              $NUMBER $VAL_NONE $VAL_ONE $VAL_UNDEF $VAL_ZERO);
  @EXPORT_OK   = qw(new_from_data
                    new_class new_number new_object new_text new_undef
                    $DIE $DIE_A $DIE_B $DIE_M $DIE_S $DIE_X
                    $NUMBER $VAL_NONE $VAL_ONE $VAL_UNDEF $VAL_ZERO);
  %EXPORT_TAGS = (
    die   => [qw($DIE $DIE_A $DIE_B $DIE_M $DIE_S $DIE_X)],
    data  => [qw(new_from_data $VAL_NONE $VAL_ONE $VAL_UNDEF $VAL_ZERO)],
    value => [qw($VAL_NONE $VAL_ONE $VAL_UNDEF $VAL_ZERO)],
    );

  use RDA::SDCL::Value qw($VALUE);
}

# Define the global public variables
use vars qw($STRINGS $VERSION @ISA
            $DIE $DIE_A $DIE_B $DIE_M $DIE_S $DIE_X);
$NUMBER  = qr/^[+-]?(\d+(\.\d*)?|\.\d+)([eE][\+\-]?\d+)?$/;
$VERSION = sprintf('%d.%02d', q$Revision: 1.9 $ =~ /(\d+)\.(\d+)/);
@ISA     = qw(RDA::SDCL::Value Exporter);

$DIE = qr/^___Die\050(\w)\051___/;
$DIE_A = "___Die(A)___\n"; # All module abort
$DIE_B = "___Die(B)___\n"; # Block abort
$DIE_M = "___Die(M)___\n"; # Module abort
$DIE_S = "___Die(S)___\n"; # Section abort
$DIE_X = "___Die(x)___\n"; # Exit request

# Define the global private constants
my $OBJECT = qr/^RDA::Object::[A-Z]\w+$/i;
my $RDA    = qr/^RDA(::[A-Z]\w+){1,2}$/i;
my $VALUE  = qr/^RDA::Value::[A-Z]\w+$/i;

# Define the global private variables
my %tb_dbg = (
  C => \&_dump_object,
  N => \&_dump_value,
  O => \&_dump_object,
  T => \&_dump_value,
  U => \&_dump_none,
  );
my %tb_dmp = (
  C => \&_dump_object,
  N => \&_dump_number,
  O => \&_dump_object,
  T => \&_dump_text,
  U => \&_dump_undef,
  );
my %tb_ini = (
  C => \&new_class,
  N => \&new_number,
  O => \&new_object,
  T => \&new_text,
  U => \&new_undef,
  );

# Define global special values
$VAL_NONE  = new_text(q{});
$VAL_ONE   = new_number(1);
$VAL_UNDEF = new_undef();
$VAL_ZERO  = new_number(0);

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

=head2 S<$h = RDA::Value::Scalar-E<gt>new($typ,...)>

The object constructor. The list of arguments depends on the specified value
type:

=over 8

=item B<    'C'> $pkg,$dsc

=item B<    'N'> $val (0 by default)

=item B<    'O'> $val

=item B<    'T'> $val (empty string by default)

=item B<    'U'> (no argument)

=back

A C<RDA::Value::Scalar> is represented by a blessed hash reference. The
following special keys are used:

=over 12

=item S<    B<'cls' > > Object class  (C,O)

=item S<    B<'met' > > Object methods  (C)

=item S<    B<'nam' > > Attribute name  (C)

=item S<    B<'pkg' > > Reference to the package object  (C)

=item S<    B<'typ' > > Value type  (C,N,O,T,U)

=item S<    B<'val' > > Associated value  (N,O,T,U)

=back

=cut

sub new
{ my (undef, $typ, @arg) = @_;

  # Validate the value type
  die get_string('BAD_TYPE', $typ) unless exists($tb_ini{$typ});

  # Create the data collection object and return its reference
  return &{$tb_ini{$typ}}(@arg);
}

=head2 S<$h = RDA::Value::Scalar::new_from_data($val)>

This method creates a list where each argument is converted into object, text,
or undefined values.

=cut

sub new_from_data
{ my ($val) = @_;
  my $ref = ref($val);

  return
    ($ref =~ $VALUE)                        ? $val :
    ($ref =~ $OBJECT)                       ? new_object($val, 1) :
    ($ref =~ $RDA && $val->can('as_class')) ? new_object($val, 1) :
    ($ref eq 'ARRAY')                       ? _new_array(@{$val}) :
    ($ref eq 'HASH')                        ? _new_assoc(%{$val}) :
    $ref                                    ? new_undef() :
    !defined($val)                          ? new_undef() :
    $val =~ $NUMBER                         ? new_number($val) :
                                              new_text($val);
}

# Initialize the object based on its type
sub new_class
{ my ($pkg, $dsc) = @_;

  return new_undef() unless exists($dsc->{'top'});
  return bless {
    typ => 'C',
    cls => $dsc->{'cls'},
    met => $dsc->{'met'},
    nam => $dsc->{'top'},
    pkg => $pkg,
    }, __PACKAGE__;
}

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

  return bless {
    typ => 'N',
    val => defined($val) ? $val : 0,
    }, __PACKAGE__;
}

sub new_object
{ my ($val, $flg) = @_;
  my ($cls);

  $cls = ref($val);
  return new_undef()
    unless $flg || $cls =~ $OBJECT || ($cls =~ $RDA && $val->can('as_class'));
  return bless {
    typ => 'O',
    cls => $cls,
    val => $val,
    }, __PACKAGE__;
}

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

  return bless {
    typ => 'T',
    val => defined($val) ? $val : q{},
    }, __PACKAGE__;
}

sub new_undef
{ return bless {
    typ => 'U',
    val => undef,
    }, __PACKAGE__;
}

=head2 S<$h-E<gt>dump([$level[,$text[,$trace]]])>

This method returns a string containing the object dump. You can provide an
indentation level, a prefix text, and a trace indicator as extra parameters.

=cut

sub dump  ## no critic (Builtin)
{ my ($slf, $lvl, $txt, $trc) = @_;

  $lvl = 0   unless defined($lvl);
  $txt = q{} unless defined($txt);

  return dump_object($slf, {}, $lvl, $txt, $trc, q{});
}

sub dump_object
{ my ($slf, $tbl, $lvl, $txt, $trc, $arg) = @_;

  return &{$tb_dmp{_get_type($slf)}}($slf, $tbl, $lvl, $txt, $trc, $arg);
}

sub _dump_none
{ return q{};
}

sub _dump_number
{ my ($slf, $tbl, $lvl, $txt) = @_;

  return q{  } x $lvl.$txt.q{Number=}.$slf->{'val'}
    .(RDA::Object->is_tainted($slf->{'val'}) ? ' [T]' : q{});
}

sub _dump_object
{ my ($slf, $tbl, $lvl, $txt, $trc, $arg) = @_;
  my ($flg, $ref, $val);

  $val = exists($slf->{'pkg'})
    ? $slf->{'pkg'}->get_top($slf->{'nam'})
    : $slf->{'val'};
  $ref = $slf->{'cls'};
  $flg = $ref =~ $OBJECT || ($ref =~ $RDA && $val->can('as_class'));

  return !$flg ? q{  } x $lvl.$txt.q{Object=bless(...,}.$ref.q{)} :
         $arg  ? q{  } x $lvl.$txt.q{Object=}.$ref.q{(}.$val->as_string.q{)} :
                 $val->dump($lvl, $txt.'Object=', $trc);
}

sub _dump_text
{ my ($slf, $tbl, $lvl, $txt) = @_;

  return q{  } x $lvl.$txt.q{Text='}.$slf->{'val'}.q{'}
    .(RDA::Object->is_tainted($slf->{'val'}) ? q{ [T]} : q{});
}

sub _dump_undef
{ my ($slf, $tbl, $lvl, $txt) = @_;

  return q{  } x $lvl.$txt.'Undef';
}

sub _dump_value
{ return shift->{'val'};
}

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

This method indicates whether the value has methods.

=cut

sub has_methods
{ return _get_type(shift) =~ m/^[COU]$/;
}

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

This method indicates whether the value is defined.

=cut

sub is_defined
{ return _get_type(shift) ne 'U';
}

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

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

=cut

sub is_lvalue
{ return (_get_type(shift) eq 'U')  ? q{-} : q{};
}

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

This method indicates whether the value is an object.

=cut

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

  _get_type($slf);
  return exists($slf->{'cls'}) ? $slf->{'cls'} : q{};
}

=head1 ASSIGN AND EVAL METHODS

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

This method has no effect on a scalar value and returns an undefined value.

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

This method has no effect on a scalar value and returns an undefined value.

=cut

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

  return () if $flg;
  return $VAL_UNDEF;
}

=head2 S<$h-E<gt>eval_method($blk,$nam,$arg[,$flg])>

This method invokes an object method.

=cut

sub eval_method  ## no critic (Complex)
{ my ($slf, $blk, $nam, $arg, $flg) = @_;
  my ($cls, $def, $obj, $typ, $val, @val);

  # Validate the associated object and skip an undefined object
  if (_get_type($slf) eq 'C')
  { $cls = $slf->{'cls'};
    unless (ref($obj = $blk->get_top($slf->{'nam'})) eq $cls)
    { die get_string('BAD_OBJECT', $cls) if defined($obj);
      $blk->get_context->trace_warning(get_string('UndefClass', $nam));
      return $VAL_UNDEF;
    }
    die get_string('UNKNOWN_METHOD', $nam, $cls)
      unless exists($slf->{'met'}->{$nam});
    $def = $slf->{'met'}->{$nam};
  }
  else
  { unless (defined($obj = $slf->{'val'}))
    { $blk->get_context->trace_warning(get_string('UndefObject', $nam));
      return $VAL_UNDEF;
    }
    die get_string('NO_OBJECT') unless exists($slf->{'cls'});
    $cls = $slf->{'cls'};
    $def = $blk->get_method($cls, $nam);
  }

  # Invoke the method and convert the result
  $typ = exists($def->{'evl'}) ? $def->{'evl'} : q{};
  if (exists($def->{'arg'}))
  { foreach my $arg (@{$def->{'arg'}})
    { push(@val, $blk->get_top($arg));
    }
  }
  if ($typ eq 'E')
  { push(@val, [@{$arg->eval_value}]);
  }
  elsif ($typ eq 'C')
  { push(@val, $arg->eval_as_data);
  }
  elsif ($typ eq 'D')
  { push(@val, $arg->eval_as_dump);
  }
  elsif ($typ eq 'L')
  { push(@val, $arg->eval_as_line);
  }
  elsif ($typ eq 'N')
  { push(@val, [@{$arg}]);
  }
  else
  { push(@val, $arg->eval_as_data(1));
  }
  unshift(@val, $blk) if $def->{'blk'};
  if ($def->{'ret'})
  { @val = eval "\$obj->$nam(\@val)";  ## no critic (Eval)
    if ($@)
    { die $@ if $@ =~ $DIE;
      $blk->get_agent->abort($@, get_string('ERR_METHOD', $cls, $nam));
    }
    $val = _new_list(@val);
  }
  else
  { $val = eval "\$obj->$nam(\@val)";  ## no critic (Eval)
    if ($@)
    { die $@ if $@ =~ $DIE;
      $blk->get_agent->abort($@, get_string('ERR_METHOD', $cls, $nam));
    }
    $val = (ref($val) eq 'ARRAY')
      ? _new_list(@{$val})
      : RDA::SDCL::Value::convert_value($val);
  }
  return $flg ? $val->eval_value(1) : $val;
}

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

This method has no effect on a scalar value and returns an undefined value.

=cut

my $n_a = sub {return $VAL_UNDEF};

*decr_value   = $n_a;

=head1 CONVERSION METHODS

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

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

=cut

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

  return ($slf->{'pkg'}->get_top($slf->{'nam'})) if _get_type($slf) eq 'C';
  return ($slf->{'val'});
}

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

This method converts the value as a list of Perl data structures.

=cut

*as_data = \&as_array;

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

This method converts the value as a dump string

=cut

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

  return &{$tb_dbg{_get_type($slf)}}($slf, {}, 0, q{}, 0, q{});
}

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

This method returns the attribute name associated with the object, an undefined
value otherwise.

=cut

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

  return (_get_type($slf) eq 'C') ? $slf->{'nam'} : undef;
}

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

This method converts the value as a Perl number.

=cut

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

  $typ = _get_type($slf);
  return $slf->{'val'}     if $typ eq 'N';
  return 0                 if $typ eq 'U';
  return 0 + $slf->{'val'} if $typ eq 'T' && $slf->{'val'} =~ $NUMBER;
  die get_string('BAD_NUMBER');
}

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

This method converts the value as a Perl scalar.

=cut

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

  return (_get_type($slf) eq 'C')
    ? $slf->{'pkg'}->get_top($slf->{'nam'})
    : $slf->{'val'};
}

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

This method converts the value as a Perl string.

=cut

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

  $typ = _get_type($slf);
  return $slf->{'val'}            if $typ eq 'T';
  return q{}.$slf->{'val'}        if $typ eq 'N';
  return $slf->{'val'}->as_string if $typ eq 'O';
  return ref($obj = $slf->{'pkg'}->get_top($slf->{'nam'}))
    ? $obj->as_string
    : q{}                         if $typ eq 'C';
  return q{};
}

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

sub _new_array
{ require RDA::Value::Array;
  return RDA::Value::Array::new_from_data(@_);
}

sub _new_assoc
{ require RDA::Value::Assoc;
  return RDA::Value::Assoc::new_from_data(@_);
}

sub _new_list
{ require RDA::Value::List;
  return RDA::Value::List->new(map {RDA::SDCL::Value::convert_value($_)} @_);
}

# --- Assign mechanism --------------------------------------------------------

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

  die get_string('BAD_ASSIGN', ref($slf)) if _get_type($slf) ne 'U';
  shift(@{$tbl});
  return;
}

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

  die get_string('BAD_DELETE', ref($slf)) if _get_type($slf) ne 'U';
  return;
}

# --- Validation routines -----------------------------------------------------

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

  if (($typ = $slf->{'typ'}) eq 'O' && ref($slf->{'val'}) ne $slf->{'cls'})
  { $slf->{'typ'} = $typ = 'U';
    $slf->{'val'} = undef;
    delete($slf->{'cls'});
  }
  return $typ;
}

1;

__END__

=head1 SEE ALSO

L<RDA::Agent|RDA::Agent>,
L<RDA::Deleted|RDA::Deleted>,
L<RDA::Object|RDA::Object>,
L<RDA::SDCL::Block|RDA::SDCL::Block>,
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::List|RDA::Value::List>

=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