# DISPLAY.pm: Display Command Library

package RDA::Request::DISPLAY;

# $Id: DISPLAY.pm,v 1.10 2015/05/09 14:47:21 RDA Exp $
# ARCS: $Header: /home/cvs/cvs/RDA_8/src/scripting/lib/RDA/Request/DISPLAY.pm,v 1.10 2015/05/09 14:47:21 RDA Exp $
#
# Change History
# 20150508  MSC  Improve the DISPLAY.DSP_LINE command.

=head1 NAME

RDA::Request::DISPLAY - Display Command Library

=head1 SYNOPSIS

 require RDA::Request::DISPLAY;

=head1 DESCRIPTION

The objects of the C<RDA::Request::DISPLAY> class are used for displaying
information on screen during RDA execution. This library is used when output is
enabled.

The following methods are available:

=cut

use strict;

BEGIN
{ use Exporter;
  use RDA::Text qw(get_string);
  use RDA::Handle::Data;
  use RDA::Handle::Memory;
  use RDA::Object;
  use RDA::Object::Message;
}

# 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 = (
  'DISPLAY.DSP_API'    => \&_dsp_api,
  'DISPLAY.DSP_DATA'   => \&_dsp_data,
  'DISPLAY.DSP_LINE'   => \&_dsp_line,
  'DISPLAY.DSP_POD'    => \&_dsp_pod,
  'DISPLAY.DSP_REPORT' => \&_dsp_report,
  'DISPLAY.DSP_TEXT'   => \&_dsp_text,
  'DISPLAY.EXPLAIN'    => \&_do_explain,
  'DISPLAY.GET_STATUS' => \&_get_status,
  );
my %tb_det = (
  q{-} => qq{\n},
  q{A} => qq{\n\n.I 'Action: '\n},
  q{B} => qq{\n\n.I '        - '\n},
  q{C} => qq{\n\n.I 'Cause: '\n},
  q{P} => qq{\n\n.I '        '\n},
  );
my %tb_pod = (
  'RDA::UI' => 'UI/',
  );

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

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

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

C<RDA::Request::DISPLAY> 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<'_dsp'> > Reference to the display control object

=back

Internal keys are prefixed by an underscore.

=cut

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

  # Create the library object and return its reference
  $cfg = $agt->get_config;
  return bless {
    _agt => $agt,
    _cfg => $cfg,
    _dsp => $agt->get_display,
    }, 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 DISPLAY COMMANDS

=head2 DISPLAY.DSP_API - SDCL API display command

This command displays the details of the application programmatic interface
of the specified object class. It supports the following attribute:

=over 11

=item B<  package>

Specifies the package name.

=item B<  page>

When set, displays the data through a pager (default).

=back

=cut

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

  # Validate the argument
  return $req->error('NoObject')
    unless defined($pkg = $req->get_first('package'))
    && $pkg =~ m/^RDA::(Object::|Target::)?[a-z]+/i;

  # Report the interface details
  $slf->{'_dsp'}->dsp_report(RDA::Object::xref($pkg), $req->get_first('page'));
  return $req->new('OK.Continue');
}

=head2 DISPLAY.DSP_DATA - Data display command

This command displays the data attached to the request message. It supports
the following attribute:

=over 8

=item B<  page>

When set, displays the data through a pager (not set by default).

=back

=cut

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

  $slf->{'_dsp'}->dsp_data($req->get_data, $req->get_first('page', 0));
  return $req->new('OK.Continue');
}

=head2 DISPLAY.DSP_LINE - Line display command

This command displays the specified lines. It supports the following attribute:

=over 8

=item B<  line>

Specifies one or more lines to display.

=back

=cut

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

  $slf->{'_dsp'}->dsp_line(join(qq{\n}, $req->get_value('line', q{}), q{}));
  return $req->new('OK.Continue');
}

=head2 DISPLAY.DSP_POD - POD display command

This command displays data in Perl documentation format. It supports the
following attributes:

=over 11

=item B<  file>

Specifies the file containing the documentation. When the attribute contains a
list of files, it considers the first file found.

=item B<  package>

Specifies a Perl package name instead of files.

=item B<  page>

When set, displays the POD data through a pager (default).

=back

In the absence of C<file> or C<package> attribute, it expects that the
documentation is attached to the request message as data.

=cut

sub _dsp_pod
{ my ($slf, $req) = @_;
  my ($cfg, $dsp, $flg, $ifh, $txt, @tbl);

  $cfg = $slf->{'_cfg'};
  $dsp = $slf->{'_dsp'};
  $flg = $req->get_first('page');
  if (@tbl = $req->get_value('package'))
  { $txt = $cfg->get_text;
    foreach my $pkg (@tbl)
    { $ifh = [_get_pod_file($cfg, $pkg)] unless $pkg =~ m/^(.*)::([^:]+)$/
        && exists($tb_pod{$1})
        && defined($ifh = $txt->get_handle($tb_pod{$1}."$2.pod"));
      return $req->new('OK.Continue') if $slf->{'_dsp'}->dsp_pod($ifh);
    }
  }
  elsif (@tbl = $req->get_value('file'))
  { return $req->new('OK.Continue') if $slf->{'_dsp'}->dsp_pod([@tbl]);
  }
  elsif ($ifh = RDA::Handle::Data->new($req))
  { return $req->new('OK.Continue') if $slf->{'_dsp'}->dsp_pod($ifh);
  }
  return $req->error('NoPod');
}

sub _get_pod_file
{ my ($cfg, $pkg) = @_;
  my ($fil, $pth);

  $fil = $pkg.q{.pm};
  $fil =~ s{::}{/}g;
  $pth = $INC{$fil};
  $pth = $cfg->get_file('D_RDA_INC', $fil) if $pth =~ m/^PERL2EXE_STORAGE/;
  return $pth;
}

=head2 DISPLAY.DSP_REPORT - Display report command

This command displays the report attached to the request message as data. It
supports the following attribute:

=over 8

=item B<  page>

When set, displays the report through a pager (default).

=back

=cut

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

  $slf->{'_dsp'}->dsp_report($ifh, $req->get_first('page'))
    if ($ifh = RDA::Handle::Data->new($req));
  return $req->new('OK.Continue');
}

=head2 DISPLAY.DSP_TEXT - Display text command

This command displays a text. The text can contain variables that are resolved
through specified attributes. When the variable is not defined, properties are
used. It supports the following attributes:

=over 14

=item B<  name>

Specifies the symbolic text associated to the text.

=item B<  page>

When set, displays the text through a pager (default).

=item B<  set_E<lt>nameE<gt>>

Defines the text variable E<lt>nameE<gt>.

=back

You can also specified the text variables as data, using the following format:

  <name>="<value>"

When a variable is not defined, settings and properties are considered. RDA
restricts the property resolution to the following property groups: C<CFG>,
C<COL>, C<DFT>, C<ENV>, C<OUT>, C<RDA>, C<REG>, C<RUN>, C<SET>, and C<STA>.

=cut

sub _dsp_text
{ my ($slf, $req) = @_;
  my ($ifh, $var);

  # Construct the variable hash
  $var = {};
  if ($ifh = RDA::Handle::Data->new($req))
  { while (<$ifh>)
    { s/[\n\r\s]+$//;
      $var->{$1} = $2 if m/^(\w+)="(.*)"$/;
    }
    $ifh->close;
  }
  else
  { foreach my $key ($req->grep('^set_'))
    { $var->{substr($key, 4)} = $req->get_first($key);
    }
  }
  $var->{q{.}} = $slf->{'_agt'}->get_collector;

  # Display the text
  $slf->{'_dsp'}->dsp_text($req->get_first('name'), $var,
    $req->get_first('page'));
  return $req->new('OK.Continue');
}

=head2 DISPLAY.EXPLAIN - Error explain command

This command displays the explanation of error numbers. It supports the
following attributes:

=over 10

=item B<  errors>

List of errors to explain. An error is composed of a product code and a number,
separated by a dash (-). It supports C<EXPL>, C<IRDA>, C<OCM>, C<RDA>, and
C<STB> as product codes. It takes C<RDA> as the default product code.

=item B<  page>

When set, displays each error through a pager (default).

=back

=cut

sub _do_explain
{ my ($slf, $req) = @_;
  my ($dsp, $flg, @err);

  $dsp = $slf->{'_dsp'};
  $flg = $req->get_first('page');
  foreach my $err ($req->get_value('errors'))
  { eval {$dsp->dsp_error($err, $flg)};
    push(@err, $@) if $@;
  }
  return scalar @err
    ? $req->error('NoExplanation', @err)
    : $req->new('OK.Explain');
}

=head2 DISPLAY.GET_STATUS - Get status command

This command indicates if output is allowed.

=cut

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

  return $req->new('OK.Display');
}

1;

__END__

=head1 SEE ALSO

L<RDA::Agent|RDA::Agent>,
L<RDA::Handle::Data|RDA::Handle::Data>,
L<RDA::Handle::Memory|RDA::Handle::Memory>,
L<RDA::Object|RDA::Object>,
L<RDA::Object::Collect|RDA::Object::Collect>,
L<RDA::Object::Display|RDA::Object::Display>,
L<RDA::Object::Message|RDA::Object::Message>,
L<RDA::Object::Rda|RDA::Object::Rda>,
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