# Value.pm: Class Used for Value Macros

package RDA::Library::Value;

# $Id: Value.pm,v 1.8 2014/11/07 18:06:49 RDA Exp $
# ARCS: $Header: /home/cvs/cvs/RDA_8/src/scripting/lib/RDA/Library/Value.pm,v 1.8 2014/11/07 18:06:49 RDA Exp $
#
# Change History
# 20141107  MSC  Add the refresh method.

=head1 NAME

RDA::Library::Value - Class Used for Value Macros

=head1 SYNOPSIS

 require RDA::Library::Value;

=head1 DESCRIPTION

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

The following methods are available:

=cut

use strict;

BEGIN
{ use Exporter;
  use RDA::Text qw(get_string);
  use RDA::Driver::Library;
  use RDA::Object;
  use RDA::Value::Scalar qw(:value new_number new_object);
}

# Define the global public variables
use vars qw($STRINGS $SUSPEND $VERSION @ISA);
$SUSPEND = {
  _lvl => sub {return {}},
  };
$VERSION = sprintf('%d.%02d', q$Revision: 1.8 $ =~ /(\d+)\.(\d+)/);
@ISA     = qw(RDA::Driver::Library Exporter);

# Define the global private constants

# Define the global private variables
my %tb_fct = (
  'can'      => \&_m_can,
  'new'      => \&_m_new,
  'setClass' => \&_m_set_class,
  );

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

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

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

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

=over 12

=item S<    B<'_col'> > Reference to the collector object

=item S<    B<'_lvl'> > Debug/trace level hash

=back

=cut

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

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

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

  # Return the object reference
  return refresh($slf, $col);
}

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

This method executes the macro code. It requires external conversion of the
argument list and of the return value.

=cut

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

  return &{$tb_fct{$nam}}($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>refresh($col)>

This method updates the library control object for a new collector.

=cut

sub refresh
{ my ($slf, $col) = @_;

  $slf->{'_col'} = $col;
  return $slf;
}

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

This method resets the trace levels.

=cut

sub reset  ## no critic (Builtin)
{ return shift->{'_lvl'} = {};
}

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

This method runs the macro with the specified argument list in a given context.

=cut

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

  return &{$tb_fct{$nam}}($slf, $ctx, $arg);
}

=head1 OBJECT RELATED MACROS

=head2 S<can($class,$name)>

This macro indicates if the specified method is supported by that object
class. An object can be specified as a class.

=cut

sub _m_can
{ my ($slf, $ctx, $arg) = @_;
  my ($cls, $def, $nam, $obj, $use);

  # Validate the arguments
  ($obj, $nam) = @{$arg};
  return $VAL_ZERO
    unless $obj && $nam && ($nam = $nam->eval_value(1)->as_string(q{}));

  # Determine the object class
  $obj = $obj->eval_value(1);
  return $VAL_ZERO
    unless ($cls = $obj->is_object) || ($cls = $obj->as_string(q{}));

  # Check the Perl object
  $use = $ctx->get_top('use');
  return (defined($cls = _get_class($use, $cls)) && exists($use->{$cls})
    && exists($use->{$cls}->{'met'}->{$nam}))
    ? $VAL_ONE
    : $VAL_ZERO;
}

=head2 S<new($class[,$arg,...])>

This macro creates a new object and returns a reference to it. An object can be
specified as a class.

=cut

sub _m_new
{ my ($slf, $ctx, $arg) = @_;
  my ($cls, $def, $flg, $nam, $new, $obj, $use, @arg);

  # Determine and validate the object class
  $use = $ctx->get_top('use');
  ($obj, @arg) = @{$arg};
  return $VAL_UNDEF unless ref($obj = $obj->eval_value(1));
  if ($nam = $obj->is_object)
  { return $VAL_UNDEF unless exists($use->{$cls = $nam})
                          || exists($use->{$cls = "RDA::Object::$nam"});
    $obj = $obj->as_scalar || $cls;
  }
  elsif ($nam = $obj->as_string(q{}))
  { return $VAL_UNDEF unless exists($use->{$cls = $nam})
                          || exists($use->{$cls = "RDA::Object::$nam"});
    $obj = $cls;
  }
  else
  { return $VAL_UNDEF;
  }

  # Create a Perl object
  die get_string('BAD_NEW', $cls) unless exists($use->{$cls}->{'new'});
  eval {
    $flg = $use->{$cls}->{'new'};
    $new = $obj->new(map {$_->eval_as_data($flg)} @arg);
    $new->set_authen($slf->{'_col'}->get_access) if $use->{$cls}->{'pwd'};
    if (exists($use->{$cls}->{'trc'}))
    { $slf->{'_lvl'}->{$cls} = $slf->{'_col'}->get_trace($use->{$cls}->{'trc'})
        unless exists($slf->{'_lvl'}->{$cls});
      $new->set_trace($slf->{'_lvl'}->{$cls});
    }
    };
  die get_string('ERR_NEW', $@) if $@;
  return new_object($new, 1);
}

=head2 S<setClass($class[,$level])>

This macro sets the trace level for an object class.

It returns the previous trace level.

=cut

sub _m_set_class
{ my ($slf, $ctx, $arg) = @_;
  my ($cls, $lvl, $old);

  ($cls, $lvl) = $arg->eval_as_array;
  return $VAL_UNDEF
    unless defined($cls)
        && defined($cls = _get_class($ctx->get_package('use'), $cls));
  $old = $slf->{'_lvl'}->{$cls};
  if ($ctx->get_top('out'))
  { $slf->{'_lvl'}->{$cls} = 0;
  }
  elsif (defined($lvl) && $lvl =~ m/^\d+$/)
  { $slf->{'_lvl'}->{$cls} = $lvl;
  }
  return new_number($old);
}

sub _get_class
{ my ($use, $nam) = @_;
  my ($cls);

  if ($cls = ref($nam))
  { return unless exists($use->{$cls});
  }
  elsif (defined($nam))
  { return unless exists($use->{$cls = $nam})
               || exists($use->{$cls = "RDA::Object::$nam"});
  }
  return $cls;
}

1;

__END__

=head1 SEE ALSO

L<RDA::Agent|RDA::Agent>,
L<RDA::Driver::Library|RDA::Driver::Library>,
L<RDA::Object|RDA::Object>,
L<RDA::Object|RDA::Object>,
L<RDA::SDCL::Block|RDA::SDCL::Block>,
L<RDA::SDCL::Context|RDA::SDCL::Context>,
L<RDA::Value::Scalar|RDA::Value::Scalar>,
L<RDA::Text|RDA::Text>

=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