# SDSL.pm: SDSL Command Library

package RDA::Request::SDSL;

# $Id: SDSL.pm,v 1.10 2015/11/16 18:47:06 RDA Exp $
# ARCS: $Header: /home/cvs/cvs/RDA_8/src/scripting/lib/RDA/Request/SDSL.pm,v 1.10 2015/11/16 18:47:06 RDA Exp $
#
# Change History
# 20151116  MSC  Add the SDSL.DEFINE command.

=head1 NAME

RDA::Request::SDSL - SDSL Command Library

=head1 SYNOPSIS

 require RDA::Request::SDSL;

=head1 DESCRIPTION

The objects of the C<RDA::Request::SDSL> class are used to execute Support
Diagnostic Setup Language (SDSL) requests.

The following methods are available:

=cut

use strict;

BEGIN
{ use Exporter;
  use RDA::Text qw(get_string);
  use RDA::Handle::Data;
  use RDA::Object;
  use RDA::Object::Content qw ($RE_DC);
  use RDA::Object::Message;
  use RDA::Object::Rda;
  use RDA::SDSL::Module;
}

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

# Define the global private constants

# Define the global private variables
my %tb_cmd = (
  'SDSL.CHECK'   => \&_do_check,
  'SDSL.DEFINE'  => \&_do_define,
  'SDSL.DISPLAY' => \&_do_display,
  'SDSL.XREF'    => \&_do_xref,
  );

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

=head2 S<$h = RDA::Request::SDSL-E<gt>new($agt)>

The object constructor. This method enables you to specify the agent reference
as an argument.

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

=over 10

=item S<  B<'_agt'> > Reference to the agent object

=item S<  B<'_cfg'> > Reference to the RDA software configuration

=item S<  B<'_lng'> > Reference to the language control object

=back

Internal keys are prefixed by an underscore.

=cut

sub new
{ my ($cls, $agt) = @_;
  my ($cfg);

  # Create the library object and return the object reference
  $cfg = $agt->get_config;
  return bless {
    _agt => $agt,
    _cfg => $cfg,
    _lng => $agt->get_lang('SDSL'),
    }, ref($cls) || $cls;
}

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

This method deletes the library object.

=cut

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

=head2 S<$h-E<gt>exec_command($req)>

This method executes the command specified in the message.

=cut

sub exec_command
{ my ($slf, $req) = @_;

  my $cmd = $req->{'msg'};
  return exists($tb_cmd{$cmd})
    ? &{$tb_cmd{$cmd}}($slf, $req)
    : $req->error('NotImplemented', get_string('BAD_COMMAND', $cmd));
}

=head1 SDSL COMMANDS

=head2 SDSL.CHECK - Check SDSL package command

This command checks a SDSL package. It supports the following attributes:

=over 11

=item B<  groups>

When present, restricts the package search to the specified groups.

=item B<  name>

Specifies the block name used when the code is provided as message data.

=item B<  package>

Specifies the package name or file to check.

=back

=cut

sub _do_check
{ my ($slf, $req) = @_;

  # Load the package to check it
  eval {_load($slf, $req)->delete_object};

  # Provide the response
  return $req->reply($@, 'Check');
}

=head2 SDSL.DEFINE - Define command

This command defines the provided data as a SDSL package. It supports the
following attribute:

=over 8

=item B<  name>

Specifies the block name.

=back

=cut

sub _do_define
{ my ($slf, $req) = @_;
  my ($dat, $nam);

  eval {
    if (defined($dat = $req->get_data))
    { $nam = $req->get_first('name', '_sdsl_');
      die get_string('BAD_NAME') unless $nam =~ m/^\w+$/;
      $slf->{'_lng'}->define_data($nam, $dat);
    }
    };

  # Provide the response
  return $req->reply($@, 'Define');
}

=head2 SDSL.DISPLAY - Display setup question command

This command displays the setup questions contained in a SDSL package. It
supports the following attributes:

=over 11

=item B<  degree>

When present, specifies a setting level.

=item B<  groups>

When present, restricts the package search to the specified groups.

=item B<  name>

Specifies the block name used when the SDSL code is provided as message data.

=item B<  package>

Specifies the package name or file to configure.

=back

=cut

sub _do_display
{ my ($slf, $req) = @_;
  my ($buf, $lvl, $obj);

  # Load the package and extract the setup questions
  eval {
    $lvl = $slf->{'_cfg'}->get_degree($req->get_first('degree', 0));
    die get_string('BAD_DEGREE', $lvl) unless defined($lvl);
    $obj = _load($slf, $req, 1);
    $buf = $obj->display($lvl);
    $obj->delete_object;
    };

  # Display the setup questions
  return $req->add_error($@)->has_errors
    ? $req->error('Display')
    : _display($slf, $req, 'OK.Display', $buf);
}

=head2 SDSL.XREF - Cross reference command

This command produces a cross-reference of a SDSL package. It supports the
following attributes:

=over 11

=item B<  groups>

When present, restricts the package search to the specified groups.

=item B<  logic>

When set, produces the associated logic cross-reference instead of the setting
cross-reference.

=item B<  name>

Specifies the block name used when the SDSL code is provided as message data.

=item B<  package>

Specifies the package name or file to analyze.

=back

=cut

sub _do_xref
{ my ($slf, $req) = @_;
  my ($buf, $obj);

  # Load the package and produce the cross-reference
  eval {
    $obj = _load($slf, $req);
    $buf = $obj->xref($req->get_first('logic'));
    $obj->delete_object;
    };

  # Display the cross-reference
  return $req->add_error($@)->has_errors
    ? $req->error('Xref')
    : _display($slf, $req, 'OK.Xref', $buf);
}

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

# Display the result
sub _display
{ my ($slf, $req, $sta, $buf) = @_;
  my ($err, $msg);

  $msg = RDA::Object::Message->new('DISPLAY.DSP_REPORT',
    page => 1)->add_data($buf);
  return ($err = $slf->{'_agt'}->submit(q{.}, $msg)->is_error($req))
    ? $req->error($err)
    : $req->new($sta);
}

# Load the package
sub _load
{ my ($slf, $req, $flg) = @_;
  my ($lng, $ifh, $nam, $obj);

  $lng = $slf->{'_lng'};
  if (defined($nam = $req->get_first('package')))
  { $obj = ($nam =~ m/^(\w+):(\w+)(\.(cfg|ctl|exe))?$/i)
      ? $lng->search_package([$1], $2, $flg)
      : $lng->load_file(RDA::Object::Rda->basename($nam),
                        RDA::Object::Rda->dirname($nam), $flg) ||
        $lng->load_file($nam, undef, $flg);
  }
  elsif ($ifh = RDA::Handle::Data->new($req))
  { $nam = $req->get_first('name', '_sdsl_');
    $nam =~ s/\.(cfg|ctl|exe)$//i;
    $obj = ($nam =~ m/^(\w+):(\w+)$/)
      ? $lng->load_data($ifh, $1, $2, $flg)
      : $lng->load_data($ifh, $req->get_first('groups'), $nam, $flg);
  }
  die get_string('NO_CODE') unless $obj;

  # Return the package information
  return $obj;
}

1;

__END__

=head1 SEE ALSO

L<RDA::Agent|RDA::Agent>,
L<RDA::Error|RDA::Error>,
L<RDA::Handle::Data|RDA::Handle::Data>,
L<RDA::Object|RDA::Object>,
L<RDA::Object::Content|RDA::Object::Content>,
L<RDA::Object::Item|RDA::Object::Item>,
L<RDA::Object::Message|RDA::Object::Message>,
L<RDA::Object::Rda|RDA::Object::Rda>,
L<RDA::Request::DISPLAY|RDA::Request::DISPLAY>,
L<RDA::SDSL::Language|RDA::SDSL::Language>,
L<RDA::SDSL::Module|RDA::SDSL::Module>,
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