# Code.pm: Class Used for Managing Code Block References

package RDA::Value::Code;

# $Id: Code.pm,v 1.7 2014/05/11 18:38:42 RDA Exp $
# ARCS: $Header: /home/cvs/cvs/RDA_8/src/scripting/lib/RDA/Value/Code.pm,v 1.7 2014/05/11 18:38:42 RDA Exp $
#
# Change History
# 20140511  MSC  Add the as_sub method.

=head1 NAME

RDA::Value::Code - Class Used for Managing Code Block References

=head1 SYNOPSIS

 require RDA::Value::Code;

=head1 DESCRIPTION

The objects of the C<RDA::Value::Code> class are used to manage code block
references.

=cut

use strict;

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

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

# Define the global private constants

# Define the global private variables

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

=head2 S<$h = RDA::Value::Code-E<gt>new($type,$block,$name[,$args[,eval]])>

The object constructor. It takes the reference to the current block and the
code block name as arguments.

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

=over 12

=item S<    B<'arg' > > Optional invocation arguments

=item S<    B<'blk' > > Reference to the current block

=item S<    B<'cod' > > Associated code

=item S<    B<'evl' > > Indicates that the arguments must be evaluated directly

=item S<    B<'lng' > > Code block language

=item S<    B<'nam' > > Code block name

=item S<    B<'var' > > Associated type

=back

=cut

sub new
{ my ($cls, $blk, $lng, $nam, $arg, $evl) = @_;
  my (%tbl);

  # Detect the argument presence
  if (defined($arg))
  { $tbl{'arg'} = $arg;
    $tbl{'evl'} = 1 if defined($evl);
  }

  # Create the data collection object and return its reference
  return bless {
    %tbl,
    blk => $blk,
    lng => $lng,
    nam => $nam,
    var => q{&},
    }, ref($cls) || $cls;
}

sub new_code
{ my ($ctx, $cod) = @_;

  return bless {
    cod => $cod,
    ctx => $ctx,
    lng => 'SDCL',
    }, __PACKAGE__;
}

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

  return bless {
    arg => $slf->{'arg'}->eval_value,
    blk => $slf->{'blk'},
    lng => $slf->{'lng'},
    nam => $slf->{'nam'},
    var => q{&},
    }, ref($slf);
}

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

This method returns a string containing the value 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) = @_;
  my ($fct);

  return q{  } x $lvl.$txt.'Code=(...)'
     if exists($slf->{'cod'});

  $fct = q{&}.$slf->{'lng'}.q{.}.$slf->{'nam'};
  return q{  } x $lvl.$txt.'Code='.$fct
     unless exists($slf->{'arg'});

  $tbl->{$slf->{'arg'}} = "$arg$fct)";
  return $slf->{'arg'}->dump_object($tbl, $lvl, $txt.'Code='.$fct.' arg:', $trc,
    "$arg$fct,");
}

=head2 S<$h-E<gt>is_code([$flag])>

This method indicates whether the value is a named block. When the flag is set,
it does not consider SDCL block.

=cut

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

  return $flg ? $slf->{'lng'} ne 'SDCL' : $slf->{'lng'};
}

=head2 S<$h-E<gt>open_pipe($ofh)>

This method resolves code values.

=cut

sub open_pipe
{ my ($slf, $ofh) = @_;
  my ($lng, $nam, $pid, @arg);

  $lng = $slf->{'lng'};
  $nam = $slf->{'nam'};
  push(@arg, $slf->{'arg'}->eval_as_data) if exists($slf->{'arg'});
  die get_string('BAD_PIPE', $lng, $nam)
    unless $slf->{'lng'} ne 'SDCL'  ## no critic (Unless)
    && ($pid = $slf->{'blk'}->get_inline->pipe_code($ofh, $lng, $nam, @arg));
  return $pid;
}

=head1 ASSIGN AND EVAL METHODS

=head2 S<$h-E<gt>eval_code([$default])>

This method resolves code values.

=cut

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

  if (exists($slf->{'cod'}))
  { my $ret;

    $ret = defined($val) ? $val : $VAL_UNDEF;
    $slf->{'ctx'}->set_internal('val', $ret);
    foreach my $itm (@{$slf->{'cod'}})
    { $ret = $itm->eval_value(1);
    }
    return $ret;
  }

  if ($slf->{'lng'} ne 'SDCL')
  { my (@arg);

    if (exists($slf->{'arg'}))
    { push(@arg, $slf->{'arg'}->eval_as_data);
    }
    elsif (ref($val))
    { push(@arg, $val->eval_as_data);
    }
    return RDA::Value::List::new_from_data(
      $slf->{'blk'}->get_inline->exec_code($slf->{'lng'}, $slf->{'nam'}, @arg));
  }

  return $slf->{'blk'}->exec_code($slf->{'nam'}, exists($slf->{'arg'})
    ? $slf->{'arg'}->eval_value(1)
    : $val)->eval_value(1);
}

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

This method evaluates a value. When the flag is set, it executes code values.

=cut

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

  return $flg                  ? $slf->eval_code :
         exists($slf->{'evl'}) ? $slf->new_eval :
                                 $slf;
}

=head1 CONVERSION METHODS

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

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

When the flag is set, it executes code values.

=cut

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

  return $flg                  ? $slf->eval_code->as_data :
         exists($slf->{'evl'}) ? $slf->new_eval->as_sub :
                                 $slf->as_sub;
}

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

This method converts the value in a Perl anonymous subroutine.

=cut

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

  return sub {$slf->eval_code(RDA::Value::List::new_from_data(@_))->as_data};
}

# --- Copy mechanim -----------------------------------------------------------

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

  return $slf unless $flg;
  return ($val = $slf->eval_code)->is_list
    ? new_number(scalar @{$val})
    : $val;
}

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::SDCL::Value|RDA::SDCL::Value>,
L<RDA::Text|RDA::Text>,
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