# Expr.pm: Class Used for Numeric Expression Macros

package RDA::Library::Expr;

# $Id: Expr.pm,v 1.8 2015/10/27 09:02:37 RDA Exp $
# ARCS: $Header: /home/cvs/cvs/RDA_8/src/scripting/lib/RDA/Library/Expr.pm,v 1.8 2015/10/27 09:02:37 RDA Exp $
#
# Change History
# 20151027  MSC  Add the average, round, and sum macros.

=head1 NAME

RDA::Library::Expr - Class Used for Numeric Expression Macros

=head1 SYNOPSIS

 require RDA::Library::Expr;

=head1 DESCRIPTION

The objects of the C<RDA::Library::Expr> class are used to interface with
numeric expression-related macros.

The following methods are available:

=cut

use strict;

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

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

# Define the global private constants

# Define the global private variables
my %tb_fct = (
  'avg'      => [\&_m_average,   'N'],
  'average'  => [\&_m_average,   'N'],
  'compute'  => [\&_m_compute,   'N'],
  'expr'     => [\&_m_expr,      'N'],
  'frac'     => [\&_m_frac,      'L'],
  'int'      => [\&_m_int,       'N'],
  'isNumber' => [\&_m_is_number, 'N'],
  'max'      => [\&_m_max,       'N'],
  'maximum'  => [\&_m_max,       'N'],
  'min'      => [\&_m_min,       'N'],
  'minimum'  => [\&_m_min,       'N'],
  'num'      => [\&_m_num,       'N'],
  'round'    => [\&_m_round,     'N'],
  'sum'      => [\&_m_sum,       'N'],
  );

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

=head2 S<$h = RDA::Library::Expr-E<gt>new($driver,$collector)>

The object constructor. It takes the library driver and collector references as
arguments.

C<RDA::Library::Expr> is represented by a blessed hash reference.

=cut

sub new
{ my ($cls, $drv, $col) = @_;
  my ($slf);

  # Create the macro object
  $slf = bless {}, ref($cls) || $cls;

  # Register the macros
  $drv->register($slf, [keys(%tb_fct)]);

  # Return the object reference
  return $slf;
}

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

This method executes the macro code.

=cut

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

  return &{$tb_fct{$nam}->[0]}($slf, @arg);
}

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

This method deletes the library control object.

=cut

sub delete_object
{ RDA::Object::dump_caller($_[0], 'Library') if $RDA::Object::DELETE;
  undef %{$_[0]};
  undef $_[0];
  return;
}

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

This method executes the macro with the specified argument list in a given
context. Code values are executed.

=cut

sub run
{ my ($slf, $nam, $arg, $ctx) = @_;
  my ($fct, $ret, $typ);

  $fct = $tb_fct{$nam};
  $typ = $fct->[1];

  # Treat an array context
  return RDA::Value::List::new_from_data(&{$fct->[0]}($slf, $ctx,
    $arg->eval_as_array)) if $typ eq 'L';

  # Treat a scalar context
  return defined($ret = &{$fct->[0]}($slf, $ctx, $arg->eval_as_array))
    ? RDA::Value::Scalar->new($typ, $ret)
    : $VAL_UNDEF;
}

=head1 NUMERIC EXPRESSION MACROS

=head2 S<average($num,...)>

This macro returns the average of the numbers specified as arguments.

=cut

sub _m_average
{ my ($slf, $ctx, @arg) = @_;
  my ($cnt, $sum);

  foreach my $val (@arg)
  { next unless defined($val) && $val =~ $NUMBER;
    $sum += $val;
    ++$cnt;
  }
  return $cnt ? $sum / $cnt : undef;
}

=head2 S<compute($str)>

This macro computes the specified expression. It returns an undefined value in
case of errors or when the string contains invalid characters.

=cut

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

  if (defined($str) && $str !~/[\;\$\%\@\[\]\{\}\#]/)
  { $ret = eval "$str";  ## no critic (Eval)
    return $ret unless $@;
  }
  return;
}

=head2 S<expr($op,$num1,$num2)>

This macro performs a given operation on the two numbers specified as
arguments. The supported operations are as follows:

=over 12

=item S<    B<'+' > > Sum of C<$num1> and C<$num2>

=item S<    B<'-' > > Difference between C<$num1> and C<$num2>

=item S<    B<'*' > > Product of C<$num1> and C<$num2>

=item S<    B<'/' > > Quotient of C<$num1> by C<$num2>

=item S<    B<'%' > > Modulus of C<$num1> by C<$num2>

=item S<    B<'E<lt>E<lt>'> > C<$num1> left shifted by C<$num2> bits

=item S<    B<'E<gt>E<gt>'> > C<$num1> right shifted by C<$num2> bits

=item S<    B<'E<amp>' > > Bitwise AND of C<$num1> and C<$num2>

=item S<    B<'|' > > Bitwise OR of C<$num1> and C<$num2>

=item S<    B<'^' > > Bitwise Exclusive OR of C<$num1> and C<$num2>

=item S<    B<'=='> > True if C<$num1> equals to C<$num2>

=item S<    B<'E<lt>E<gt>'> > True if C<$num1> differs from C<$num2>

=item S<    B<'E<lt>' > > True if C<$num1> is less than C<$num2>

=item S<    B<'E<lt>='> > True if C<$num1> is less than or equals to C<$num2>

=item S<    B<'E<gt>' > > True if C<$num1> is greater than C<$num2>

=item S<    B<'E<gt>='> > True if C<$num1> is greater than or equals to C<$num2>

=back

=cut

sub _m_expr
{ #
  ## no critic (Bit,Numbered)
  my ($slf, $ctx, $op, $num1, $num2) = @_;

  if (defined($num1) && defined($num2))
  { return $num1 + $num2  if $op eq q{+};
    return $num1 - $num2  if $op eq q{-};
    return $num1 * $num2  if $op eq q{*};
    return $num1 / $num2  if $op eq q{/};
    return $num1 % $num2  if $op eq q{%};
    return int($num1) << int($num2) if $op eq q{<<};
    return int($num1) >> int($num2) if $op eq q{>>};
    return int($num1) & int($num2)  if $op eq q{&};
    return int($num1) | int($num2)  if $op eq q{|};
    return int($num1) ^ int($num2)  if $op eq q{^};
    return $num1 == $num2 if $op eq q{==};
    return $num1 != $num2 if $op eq q{<>};
    return $num1 < $num2  if $op eq q{<};
    return $num1 <= $num2 if $op eq q{<=};
    return $num1 > $num2  if $op eq q{>};
    return $num1 >= $num2 if $op eq q{>=};
  }
  return 0;
}

=head2 S<frac($num[,$flg])>

This macro splits the integer and decimal parts of a number. When the flag is
set, the decimal part is always positive.

=cut

sub _m_frac
{ my ($slf, $ctx, $num, $flg) = @_;
  my ($dec, $int);

  return () unless defined($num) && $num =~ $NUMBER;
  $dec = $num - ($int = int($num));
  if ($flg && $dec < 0)
  { $dec += 1.;
    --$int;
  }
  return ($int, $dec);
}

=head2 S<int($num)>

This macro returns the integer part of a number.

=cut

sub _m_int
{ my ($slf, $ctx, $num) = @_;

  return (defined($num) && $num =~ $NUMBER) ? int($num) : undef;
}

=head2 S<isNumber($str)>

This macro indicates whether the string represents a number.

=cut

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

  return defined($str) && $str =~ $NUMBER;
}

=head2 S<max($num,...)>

This macro returns the maximum value of the numbers specified as arguments.

=cut

sub _m_max
{ my ($slf, $ctx, @arg) = @_;
  my ($max);

  foreach my $val (@arg)
  { next unless defined($val) && $val =~ $NUMBER;
    $max = $val unless defined($max) && $max >= $val;  ## no critic (Unless)
  }
  return $max;
}

=head2 S<min($num,...)>

This macro returns the minimum value of the numbers specified as arguments.

=cut

sub _m_min
{ my ($slf, $ctx, @arg) = @_;
  my ($min);

  foreach my $val (@arg)
  { next unless defined($val) && $val =~ $NUMBER;
    $min = $val unless defined($min) && $min <= $val;  ## no critic (Unless)
  }
  return $min;
}

=head2 S<num($str[,$dft])>

This macro converts a string in a number. It uses the default value when the
string does not represent a valid number format.

=cut

sub _m_num
{ my ($slf, $ctx, $str, $dft) = @_;

  return (defined($str) && $str =~ $NUMBER) ? 0 + $str : $dft;
}

=head2 S<round($num[,$res])>

This macro rounds the value according to the specified precision. When no
precision is present, it rounds to the closest integer value. The precision
must be a positive integer value.

=cut

sub _m_round
{ my ($slf, $ctx, $val, $res) = @_;

  return unless defined($val) && $val =~ $NUMBER;
  $res = 0 unless defined($res) && $res =~ m/^\d+$/;
  return sprintf('%.*f', $res, $val);
}

=head2 S<sum($num,...)>

This macro returns the sum of the numbers specified as arguments.

=cut

sub _m_sum
{ my ($slf, $ctx, @arg) = @_;
  my ($sum);

  foreach my $val (@arg)
  { $sum += $val if defined($val) && $val =~ $NUMBER;
  }
  return $sum;
}

1;

__END__

=head1 SEE ALSO

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