# ASK.pm: User Interaction Command Library

package RDA::Request::ASK;

# $Id: ASK.pm,v 1.10 2015/05/09 14:47:37 RDA Exp $
# ARCS: $Header: /home/cvs/cvs/RDA_8/src/scripting/lib/RDA/Request/ASK.pm,v 1.10 2015/05/09 14:47:37 RDA Exp $
#
# Change History
# 20150508  MSC  Change the display.

=head1 NAME

RDA::Request::ASK - User Interaction Command Library

=head1 SYNOPSIS

 require RDA::Request::ASK;

=head1 DESCRIPTION

The objects of the C<RDA::Request::ASK> class are used for interacting with the
user. This class is used when interactions are enabled.

The following methods are available:

=cut

use strict;

BEGIN
{ use Exporter;
  use RDA::Text qw(get_string);
  use RDA::Agent qw($INTERRUPT);
  use RDA::Handle::Data;
  use RDA::Object;
  use RDA::Object::Access;
  use RDA::Object::Display;
  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(RDA::Text Exporter);

# Define the global private constants
my $EOF = 'Eof';
my $NL  = qq{\n};

# Define the global private variables
my %tb_cmd = (
  'ASK.ASK_ACKNOWLEDGE' => \&_ask_acknowledge,
  'ASK.ASK_CONFIRM'     => \&_ask_confirm,
  'ASK.ASK_LINE'        => \&_ask_line,
  'ASK.ASK_PASSWORD'    => \&_ask_password,
  'ASK.CONFIRM'         => \&_ask_confirm,
  'ASK.GET_STATUS'      => \&_get_status,
  'ASK.SELECT'          => \&_ask_select,
  );

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

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

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

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

=back

Internal keys are prefixed by an underscore.

=cut

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

  # Create the library object and return it reference
  return bless {
    _agt => $agt,
    _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 ASK COMMANDS

=head2 ASK.ASK_ACKNOWLEDGE - Ask acknowledge command

This command displays a text and asks for an acknowledge. 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 (false by default).

=item B<  prompt>

Specifies the confirmation prompt.

=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 _ask_acknowledge
{ my ($slf, $req) = @_;
  my ($buf, $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', 0));

  # Get an user acknowledge
  eval {
    local $SIG{'INT'} = sub { die "$INTERRUPT\n"; };

    ($buf) = $req->get_first('prompt', q{Press 'Enter' to continue});
    $buf =~ s/[\s\r\n]+$/ /;
    syswrite($slf->{'_agt'}->get_screen, $buf, length($buf));
    $buf = <STDIN>;  ## no critic (Stdin)
    die "$EOF\n" unless defined($buf);
  };

  # Treat interruptions
  if ($@ =~ m/^($EOF|$INTERRUPT)/)
  { syswrite($slf->{'_agt'}->get_screen, $NL, length($NL));
    return $req->new("INFO.$1");
  }

  # Indicate the result
  return $@
    ? $req->error('Input', $@)
    : $req->new('OK.Continue');
}

=head2 ASK.CONFIRM - Confirmation command

This command displays a text and requests an user acknowledge before
continuing. It supports the following attribute:

=over 10

=item B<  prompt>

Specifies the continuation prompt.

=back

=cut

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

  # Extract the text from the file
  $slf->{'_dsp'}->dsp_report($ifh, 0) if ($ifh = RDA::Handle::Data->new($req));

  # Get an user acknowledge
  eval {
    local $SIG{'INT'} = sub { die "$INTERRUPT\n"; };

    ($buf) = $req->get_first('prompt', q{Press 'Enter' to continue});
    $buf =~ s/[\s\r\n]+$/ /;
    syswrite($slf->{'_agt'}->get_screen, $buf, length($buf));
    $buf = <STDIN>;  ## no critic (Stdin)
    die "$EOF\n" unless defined($buf);
  };

  # Treat interruptions
  if ($@ =~ m/^($EOF|$INTERRUPT)/)
  { syswrite($slf->{'_agt'}->get_screen, $NL, length($NL));
    return $req->new("INFO.$1");
  }

  # Indicate the result
  return $@
    ? $req->error('Input', $@)
    : $req->new('OK.Continue');
}

=head2 ASK.ASK_LINE - Input line request command

This command asks for an input line. A formatted introduction text can be
provided as data. It returns the line read as data.

=cut

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

  # Display provided text
  $slf->{'_dsp'}->dsp_report($ifh, 0) if ($ifh = RDA::Handle::Data->new($req));

  # Read a line
  eval {
    local $SIG{'INT'} = sub { die "$INTERRUPT\n"; };

    $lin = <STDIN>;  ## no critic (Stdin)
    die "$EOF\n" unless defined($lin);
    syswrite($slf->{'_agt'}->get_screen, $NL, length($NL));
    $lin =~ s/[\n\r\s]+$//;
  };

  # Treat interruptions
  if ($@ =~ m/^($EOF|$INTERRUPT)/)
  { syswrite($slf->{'_agt'}->get_screen, $NL, length($NL));
    return $req->new("INFO.$1");
  }

  # Return the input line
  return $@
    ? $req->error('Input', $@)
    : $req->new('OK.Line')->add_data($lin);
}

=head2 ASK.ASK_PASSWORD - Password request command

This command asks for a password. When supported by the installed Perl version,
it suppresses the character echo for password entry. When the character echo is
suppressed, the command requests the password twice. If both strings do not
match after three attempts, the request is canceled. It returns the password,
or, in case of failure, it returns an undefined value.

It supports the following attribute:

=over 10

=item B<  prompt>

Specifies the password prompt.

=back

A formatted introduction text can be provided as data.

=cut

sub _ask_password
{ my ($slf, $req) = @_;
  my ($ifh, $pwd, $txt);

  # Display provided text
  $slf->{'_dsp'}->dsp_report($ifh, 0) if ($ifh = RDA::Handle::Data->new($req));

  # Get the attribute
  $txt =~ s/[\s\r\n]+$/ / if ($txt = $req->get_first('prompt'));

  # Return the password
  return defined($pwd = RDA::Object::Access::ask_password($slf->{'_agt'}, $txt))
    ? $req->new('OK.Password', password => $pwd)
    : $req->new('ERROR.NoPassword');
}

=head2 ASK.GET_STATUS - Get status command

This command indicates if user interactions are allowed.

=cut

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

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

=head2 ASK.SELECT - Menu item select command

This command selects an item from the list of items provided as data.

It supports the following attributes:

=over 13

=item B<  items>

Specifies the menu items.

=item B<  prompt>

Specifies the input prompt.

=item B<  separator>

Specifies the character used to separate values and descriptions. By default,
the value is used as description.

=item B<  title>

Specifies the selection title.

=back

=cut

sub _ask_select
{ my ($slf, $req) = @_;
  my ($buf, $cnt, $ifh, $lin, $sep, $str, @dsc, @rsp);

  # Get the menu items
  $cnt = 0;
  $sep = $req->get_first('separator');
  foreach my $itm ($req->get_value('items'))
  { ++$cnt;
    if (defined($sep))
    { ($rsp[$cnt], $dsc[$cnt]) = split($sep, $itm, 2);
    }
    else
    { $rsp[$cnt] = $dsc[$cnt] = $itm
    }
  }
  return $req->new('INFO.NoItems') unless $cnt;

  # Display selection
  $buf = q{};
  $buf .= ".P\n$str\n\n" if ($str = $req->get_first('title'));
  for my $off (1..$cnt)
  { $buf .= sprintf(".I '  %3d  '\n\%s\n\n", $off, $dsc[$off]);
  }
  $buf .= ".N 1\n.P\n";
  $buf .= $req->get_first('prompt', get_string('SelectItem'));
  $buf .= qq{\n\n};
  $slf->{'_dsp'}->dsp_report($buf, 0);

  # Get the selected item
  for (;;)  ## no critic (Loop)
  { # Read a line
    eval {
      local $SIG{'INT'} = sub { die "$INTERRUPT\n"; };

      $lin = <STDIN>;  ## no critic (Stdin)
      die "$EOF\n" unless defined($lin);
      syswrite($slf->{'_agt'}->get_screen, $NL, length($NL));
      $lin =~ s/[\n\r\s]+$//;
      $lin =~ s/^\s+//;
    };
    if ($@ =~ m/^($EOF|$INTERRUPT)/)
    { syswrite($slf->{'_agt'}->get_screen, $NL, length($NL));
      return $req->new("INFO.$1")
    }
    return $req->error('Input', $@)   if $@;
    return $req->new('INFO.NoSelect') unless length( $lin);

    # Validate the answer
    last if $lin =~ m/^\d+$/ && $lin > 0 && $lin <= $cnt;
    if ($lin eq q{?})
    { $slf->{'_dsp'}->dsp_report($buf, 0);
    }
    else
    { $str = get_string('BadItem', $cnt).qq{\n};
      syswrite($slf->{'_agt'}->get_screen, $str, length($str));
    }
  }

  # Return the selected item
  return $req->new('OK.Select', item=> $rsp[$lin]);
}

1;

__END__

=head1 SEE ALSO

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