# Local.pm: Class Used for Local Access

package RDA::Driver::Local;

# $Id: Local.pm,v 1.14 2015/06/29 06:40:33 RDA Exp $
# ARCS: $Header: /home/cvs/cvs/RDA_8/src/scripting/lib/RDA/Driver/Local.pm,v 1.14 2015/06/29 06:40:33 RDA Exp $
#
# Change History
# 20150629  MSC  Add the end method.

=head1 NAME

RDA::Driver::Local - Class Used for Local Access

=head1 SYNOPSIS

 require RDA::Driver::Local;

=head1 DESCRIPTION

The objects of the C<RDA::Driver::Local> class are used for execution local
requests.

The following methods are available:

=cut

use strict;

BEGIN
{ use Exporter;
  use IO::Handle;
  use RDA::Text qw(debug get_string);
  use RDA::Object::Rda;
}

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

# Define the global private constants

# Define the global private variables

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

=head2 S<$h = RDA::Driver::Local-E<gt>new($collector)>

The remote access manager object constructor. It takes the collector object
reference as an argument.

=head2 S<$h-E<gt>new($session)>

The remote session manager object constructor. It takes the remote session
object reference as an argument.

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

=over 12

=item S<    B<'-col'> > Reference to the collector object (M,S)

=item S<    B<'-lin'> > Stored lines (S)

=item S<    B<'-msg'> > Last message (M,S)

=item S<    B<'-nod'> > Node identifier (M,S)

=item S<    B<'-out'> > Timeout indicator (M,S)

=item S<    B<'-pre'> > Trace prefix (M,S)

=item S<    B<'-ses'> > Reference to the session object (S)

=item S<    B<'-sta'> > Last captured exit code (M,S)

=item S<    B<'-trc'> > Trace indicator (M,S)

=back

Internal keys are prefixed by a dash.

=cut

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

  # Create the object and return its reference
  $nod = $ses->get_oid;
  return ref($cls)
    ? bless {
        -col => $cls->{'-col'},
        -lin => [],
        -msg => undef,
        -nod => $nod,
        -pre => $cls->{'-col'}->get_first("REMOTE.$nod.W_PREFIX", $nod),
        -out => 0,
        -ses => $ses,
        -sta => 0,
        -trc => $cls->{'-trc'} || $ses->get_level,
        }, ref($cls)
    : _create_manager(@_);
}

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

This method returns the driver type.

=cut

sub as_type
{ return 'local';
}

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

This method indicates whether an interconnection is possible.

=cut

sub can_interconnect
{ return 1;
}

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

This method deletes the object.

=cut

sub delete_object
{ undef %{$_[0]};
  undef $_[0];
  return;
}

sub end
{ return;
}

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

This method indicates that the driver does not support passwords.

=cut

sub get_access
{ return;
}

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

This method returns the version of the interface. It returns an undefined value
in case of problems.

=cut

sub get_api
{ return;
}

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

This method returns the last prompt matched. It returns an undefined value in
case of problems.

=cut

sub get_hit
{ return;
}

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

This method returns the lines stored during the last command execution.

=cut

sub get_lines
{ return @{shift->{'-lin'}};
}

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

This method returns the last message.

=cut

sub get_message
{ return shift->{'-msg'};
}

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

This method indicates whether the last request encountered a timeout.

=cut

sub has_timeout
{ return shift->{'-out'};
}

=head2 S<$h-E<gt>interconnect($var,$ifh,$ofh,$efh)>

This method creates a communication channel with a local command. It returns
its process identifier.

=cut

sub interconnect
{ my ($slf, $var, $ifh, $ofh, $efh) = @_;

  require RDA::Handle::Agent;
  return RDA::Handle::Agent::exec_command($ifh, $ofh, $efh,
    @{$var->{'CMD'}}, @{$var->{'OPT'}});
}

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

This method indicates whether the last request was skipped.

=cut

sub is_skipped
{ return 0;
}

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

This method indicates whether the driver needs a password.

=cut

sub need_password
{ return 0;
}

=head2 S<$h-E<gt>need_pause([$var])>

This method indicates whether the current connection could require a pause for
providing a password.

=cut

sub need_pause
{ return 0;
}

=head2 S<$h-E<gt>request($cmd,$var,@dat)>

This method executes a request and returns the result file. It supports the
following commands:

=over 2

=item * C<DEFAULT>

It changes some interface parameters.

=item * C<EXEC>

It submits one or more commands to the remote servers and collects the results.

=item * C<GET>

It gets one or more remote files.

=item * C<PUT>

It puts one or more local files into the remote server.

=back

It returns a negative value in case of problems.

=cut

sub request
{ my ($slf, $cmd, $var, @dat) = @_;
  my ($msk, $pre);

  # Validate the request
  return -20 unless defined($cmd) && ref($var) eq 'HASH';

  # Trace the request
  if ($slf->{'-trc'})
  { $pre = $slf->{'-pre'}.'] ';
    $msk = exists($var->{'MSK'}) ? $var->{'MSK'} : 'PPH|PWD';
    debug(join(qq{\n}, $pre."Executing a $cmd request",
      map {m/^($msk)$/ ? "$pre  $_=***" : "$pre  $_='".$var->{$_}.q{'}}
        sort keys(%{$var})));
  }

  # Execute the request
  return _do_default($slf, $var)    if $cmd eq 'DEFAULT';
  return exists($var->{'FLG'})
    ? _do_command($slf, $var)
    : _do_exec($slf, $var, @dat)    if $cmd eq 'EXEC';
  return -21;
}

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

# Create the driver manager
sub _create_manager
{ my ($cls, $col, $lim) = @_;

  # Create the driver manager object
  return bless {
    -col => $col,
    -msg => undef,
    -nod => 'LOCAL',
    -out => 0,
    -sta => 0,
    -trc => $col->get_trace('SSH'),
    }, $cls;
}

# Perform an EXEC request (Command mode)
sub _do_command
{ my ($slf, $var) = @_;
  my ($cmd, $flg, $ifh, $trc);

  $slf->{'-lin'} = [];
  $cmd = $var->{'CMD'};
  $flg = $var->{'FLG'};
  if ($slf->{'-trc'})
  { debug($slf->{'-pre'}."] Command: $cmd 2>1");
    $trc = $slf->{'-pre'}.q{> };
  }
  if (open($ifh = IO::Handle->new, "$cmd 2>&1 |"))  ## no critic (Open)
  { while (<$ifh>)
    { s/[\n\r\s]+$//;
      debug($trc, $_) if $trc;
      push(@{$slf->{'-lin'}}, $_) if $flg || m/RDA-\d{5}:/;
    }
    $ifh->close;
  }

  # Indicate the command result
  return $?;
}

# Perform a DEFAULT request
sub _do_default
{ my ($slf, $var) = @_;

  $slf->{'-lim'} = $var->{'LIM'} if exists($var->{'LIM'});
  $slf->{'-pre'} = $var->{'PRE'} if exists($var->{'PRE'});
  $slf->{'-trc'} = $var->{'TRC'} if exists($var->{'TRC'});
  return 0;
}

# Perform an EXEC request (Execute mode)
sub _do_exec
{ my ($slf, $var, @dat) = @_;
  my ($cmd, $cod, $ofh, $pre);

  $cmd = $var->{'CMD'};
  debug($slf->{'-pre'}."] Command: $cmd 2>/dev/null") if $slf->{'-trc'};
  if (open($ofh = IO::Handle->new, "| $cmd 2>/dev/null"))  ## no critic (Open)
  { if (@dat)
    { $cod = join(qq{\n}, @dat);
      if ($slf->{'-trc'})
      { $pre = $slf->{'-pre'}.': ';
        for (split(/\n/, $cod))
        { debug($pre, $_);
        }
      }
      syswrite($ofh, $cod, length($cod));
    }
    $ofh->close;
  }

  # Indicate the command result
  return $?;
}

1;

__END__

=head1 SEE ALSO

L<RDA::Agent|RDA::Agent>,
L<RDA::Object::Rda|RDA::Object::Rda>,
L<RDA::Object::Remote|RDA::Object::Remote>,
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