# Da.pm: Class Used for Remote Access with the Diagnostic Assistant

package RDA::Driver::Da;

# $Id: Da.pm,v 1.26 2015/10/30 09:59:39 RDA Exp $
# ARCS: $Header: /home/cvs/cvs/RDA_8/src/scripting/lib/RDA/Driver/Da.pm,v 1.26 2015/10/30 09:59:39 RDA Exp $
#
# Change History
# 20151030  MSC  Enhance the tracing mechanisms.

=head1 NAME

RDA::Driver::Da - Class Used for Remote Access using the Diagnostic Assistant

=head1 SYNOPSIS

 require RDA::Driver::Da;

=head1 DESCRIPTION

The objects of the C<RDA::Driver::Da> class are used for execution remote
access requests using the Diagnostic Assistant (DA).

The following methods are available:

=cut

use strict;

BEGIN
{ use Exporter;
  use IO::File;
  use RDA::Text qw(debug get_string);
  use RDA::Object::Java;
  use RDA::Object::Rda qw($APPEND $CREATE $FIL_PERMS);
}

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

# Define the global private constants
my $CLS = 'oracle/sysman/da/rda/Rda2Jsch';
my $END = "/QUIT\n";
my $JAR = 'lib/dacore.jar';
my $JSC = 'lib/jsch.jar';
my $NAM = 'DaJsch';
my $OUT = qr{timeout};
my $WRK = 'da.tmp';

# Define the global private variables
my %tb_cnv = (
  CHK => \&_cnv_match,
  NXT => \&_cnv_next,
  PAT => \&_cnv_match,
  SRC => \&_cnv_array,
  );
my %tb_cmd = map {$_ => 1} qw(CHOOSE CLOSE COLLECT DEFAULT EXEC GET LOCAL
                              LOGIN LOGOUT META OPEN PUT SHADOW TEST);

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

=head2 S<$h = RDA::Driver::Da-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::Da> is represented by a blessed hash reference. The
following special keys are used:

=over 12

=item S<    B<'-api'> > Version of the Java interface (M,S)

=item S<    B<'-cfg'> > Reference to the RDA configuration (M,S)

=item S<    B<'-cod'> > Reference to the main Java object (M,S)

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

=item S<    B<'-ctl'> > Reference to the language control (M,S)

=item S<    B<'-flw'> > Interconnection flow direction (S)

=item S<    B<'-hit'> > Last prompt matched (S)

=item S<    B<'-hnd'> > Communication handle (M,S)

=item S<    B<'-ief'> > Interface error file (M,S)

=item S<    B<'-lim'> > Default execution limit (S)

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

=item S<    B<'-lng'> > Interface language (M,S)

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

=item S<    B<'-new'> > New connection indicator (M,S)

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

=item S<    B<'-opt'> > Interface option (M,S)

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

=item S<    B<'-pid'> > Process identifier of the Java interface (M,S)

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

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

=item S<    B<'-sig'> > Signaling file (S)

=item S<    B<'-skp'> > Skip indicator (M,S)

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

=item S<    B<'-sys'> > Reference to the system view object (M,S)

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

=item S<    B<'-xfc'> > Transfer completion file (S)

=item S<    B<'-xfh'> > Transfer file handle (S)

=item S<    B<'-xfr'> > Transfer file path (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 {
        -api => $cls->{'-api'},
        -cfg => $cls->{'-cfg'},
        -cod => $cls->{'-cod'},
        -col => $cls->{'-col'},
        -ctl => $cls->{'-ctl'},
        -lim => $ses->get_info('lim'),
        -lin => [],
        -lng => $cls->{'-lng'},
        -msg => undef,
        -new => $cls->{'-col'}->get_first("REMOTE.$nod.B_NEW", $cls->{'-new'}),
        -nod => $nod,
        -opt => $cls->{'-opt'},
        -out => 0,
        -pre => $cls->{'-col'}->get_first("REMOTE.$nod.W_PREFIX", $nod),
        -ses => $ses,
        -skp => 0,
        -sta => 0,
        -sys => $cls->{'-sys'},
        -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 'da';
}

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

This method indicates whether an interconnection is possible.

=cut

sub can_interconnect
{ my ($slf) = @_;

  return $slf->{'-cfg'}->can_spawn  ?  1 :
         $slf->{'-cfg'}->is_windows ? -1 :
                                       0;
}

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

This method deletes the object.

=cut

sub delete_object
{ # Close the communication handle
  end($_[0]);

  # Delete the object
  undef %{$_[0]};
  undef $_[0];
  return;
}

# Close the Java interface
sub end
{ my ($slf) = @_;
  my ($hnd);

  if ($hnd = delete($slf->{'-hnd'}))
  { eval {
      local $SIG{'PIPE'} = 'IGNORE';

      $hnd->syswrite($END, length($END));
      $hnd->close;
      };
    delete($slf->{'-pid'});
  }
  return $slf;
}

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

This method indicates that the driver does not support passwords.

=cut

sub get_access
{ return shift->{'-col'}->get_access;
}

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

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

=cut

sub get_api
{ return shift->{'-api'};
}

=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 shift->{'-hit'};
}

=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>get_status>

This method returns the last captured status.

=cut

sub get_status
{ return shift->{'-sta'};
}

=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 remote command. It returns
its process identifier.

=cut

sub interconnect
{ my ($slf, $var, $ifh, $ofh, $efh) = @_;
  my ($bkp, $dis, $flg, $msg, $trc);

  # Start the interconnection channel
  $flg = $slf->{'-cfg'}->can_spawn;
  $trc = $slf->{'-trc'};
  $slf->{'-cod'}->set_info('pre', $trc ? 'JSCH' : q{});
  $bkp = $slf->{'-sys'}->set_context({RDA_DUMP  => undef,
                                      RDA_LEVEL => undef,
                                      RDA_TRACE => undef,
                                      RDA_TRACK => undef});
  $slf->{'-hnd'} = $ifh;
  if ($flg)
  { eval {$slf->{'-pid'} = $slf->{'-ctl'}->interconnect_code($ifh, $ofh, $efh,
            $slf->{'-lng'}, $NAM, @{$slf->{'-opt'}})};
    $msg = $@;
    $dis = 1 if RDA::Object::Rda->is_windows;
  }
  else
  { eval {($slf->{'-pid'}, undef, $slf->{'-ief'}) =
      $slf->{'-ctl'}->pipe_code($ifh,
        $slf->{'-lng'}, $NAM, @{$slf->{'-opt'}})};
    $msg = $@;
  }
  $slf->{'-sys'}->restore_context($bkp);
  if ($msg)
  { $msg =~ s/[\n\r\s]+$//;
    $slf->{'-msg'} = $msg;
    return $slf->{'-hnd'} = undef;
  }
  binmode($ifh);

  # Initialize the interconnection channel
  if (exists($slf->{'-ses'}))
  { my ($fil, $wrk, %var);

    # Load some defaults
    return $slf->{'-hnd'} = undef if _set_default($slf, $dis);

    # Start the shadow agent
    if ($var->{'LOC'})
    { $var{'CMD#'} = _set_array(\%var, 'CMD',
        [$slf->{'-cfg'}->get_value('T_SELF'), @{$var->{'OPT'}}]);
    }
    else
    { $var{'CMD'} = join(q{ }, map {RDA::Object::Rda->quote($_)}
                                   @{$var->{'CMD'}}, @{$var->{'OPT'}});
    }
    $var{'HST'} = $var->{'HST'};
    $var{'LCK'} = RDA::Object::Rda->native($fil)
      if RDA::Object::Rda->is_windows
      && defined($fil = $slf->{'-ses'}->get_lock);
    $var{'LIM'} = 30;
    $var{'PWD'} = $var->{'PWD'} if exists($var->{'PWD'});
    $var{'STA'} = 1;
    $var{'TMP'} = 1;
    $var{'USR'} = $var->{'USR'} if exists($var->{'USR'});
    $wrk = $slf->{'-col'}->get_work($slf->{'-nod'}.q{_}.$WRK, 1);
    $var{'WRK'} = RDA::Object::Rda->native($wrk);
    unless ($flg)
    { $wrk =~ s/\.tmp$//;
      $var{'MSG'} = RDA::Object::Rda->native($slf->{'-xfr'} = $wrk);
      $slf->{'-flw'} = 1;
      $slf->{'-sig'} = $fil = "$wrk.sig";
      1 while unlink($fil);
      $slf->{'-xfc'} = "$wrk.end";
      $slf->{'-xfh'} = $ofh;
      $slf->{'-xfr'} = $fil = "$wrk.msg";
      $msg = IO::File->new;
      $msg->open($fil, $CREATE, $FIL_PERMS)
        or die get_string('ERR_CREATE', $fil, $!);
      $msg->close;
      open($ofh, "<$fil")  ## no critic (Close,Open)
        or die get_string('ERR_OPEN', $fil, $!)
    }
    return $slf->{'-hnd'} = undef
      if request($slf, $var->{'LOC'} ? 'LOCAL' : 'SHADOW', {%var});
  }

  # Return the process identifier
  return $slf->{'-pid'};
}

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

This method indicates whether the last request was skipped.

=cut

sub is_skipped
{ return shift->{'-skp'};
}

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

This method indicates whether the driver needs a password.

=cut

sub need_password
{ my ($slf, $var) = @_;
  my ($ret);

  $ret = -1;
  $var = {} unless ref($var) eq 'HASH';
  $var->{'FCT'} = [\&_check_connect, \$ret];
  $var->{'NEW'} = 1;
  request($slf, 'TEST', $var);
  return $ret;
}

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

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 requests and returns the result file. It supports the
following commands:

=over 2

=item * C<CHOOSE>

It performs required input selection with the remote server.

=item * C<CLOSE>

It closes any existing session with the remote server.

=item * C<COLLECT>

It submits a command to the remote servers and collects the results. It manages
the command and continuation prompts.

=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<LOGIN>

It performs required authentication with the remote server.

=item * C<LOGOUT>

It ends any current session with the remote server.

=item * C<META>

It returns the interface information.

=item * C<OPEN>

It closes any existing session and starts a new session with the remote server.

=item * C<QUIT>

It closes the interface.

=back

It returns a negative value in case of problems.

=cut

sub request  ## no critic (Complex)
{ my ($slf, $cmd, $var, @dat) = @_;
  my ($buf, $cnt, $err, $fct, $lim, $msk, $sta, $tmp, $trc, $wrk, @arg);

  local $SIG{'__WARN__'} = sub {};

  # Validate the request
  $slf->{'-out'} = 0;
  return -30 unless defined($cmd) && ref($var) eq 'HASH';
  return -31 unless exists($tb_cmd{$cmd});

  # Get the communication handle
  unless (_get_handle($slf))
  { $slf->{'-skp'} = 1 unless defined($slf->{'-msg'});
    return -32;
  }

  # Execute the request
  eval {
    local $SIG{'ALRM'} = 'IGNORE' if exists($SIG{'ALRM'});
    local $SIG{'PIPE'} = sub {die "Pipe broken\n"};

    # Prepare the request
    $trc = $slf->{'-pre'}.'] ' if $slf->{'-trc'};
    $lim = exists($var->{'LIM'}) ? $var->{'LIM'} : 0;
    if (exists($var->{'FCT'}))
    { ($fct, @arg) = @{$fct} if ref($fct = delete($var->{'FCT'})) eq 'ARRAY';
    }
    elsif (exists($var->{'COL'}))
    { $wrk = delete($var->{'COL'});
      ($fct, @arg) = (  ## no critic (Comma)
        ref($wrk) ? \&_write_result : \&_copy_result,
        $wrk, delete($var->{'CLR'}));
    }
    elsif ($cmd eq 'EXEC')
    { if (exists($var->{'FLG'}))
      { ($fct, @arg) = (\&_load_lines, $var->{'FLG'});
      }
      elsif (exists($var->{'OUT'}))
      { $wrk = delete($var->{'OUT'});
        ($fct, @arg) = (  ## no critic (Comma)
          ref($wrk) ? \&_write_result : \&_copy_result,
          $wrk, delete($var->{'CLR'}));
      }
      $var->{'NEW'} = 1 if $slf->{'-new'};
    }
    elsif ($cmd eq 'GET')
    { $var->{'DST'} = RDA::Object::Rda->native($var->{'DST'})
        if exists($var->{'DST'});
    }
    elsif ($cmd eq 'PUT')
    { $var->{'SRC'} = (ref($var->{'SRC'}) eq 'ARRAY')
        ? [map {RDA::Object::Rda->native($_)} @{$var->{'SRC'}}]
        : RDA::Object::Rda->native($var->{'SRC'})
        if exists($var->{'SRC'});
    }
    elsif ($cmd eq 'CHOOSE' || $cmd eq 'LOGIN')
    { ($fct, @arg) = (\&_load_lines, $var->{'FLG'})
        if exists($var->{'FLG'});
    }
    $wrk = $tmp = $slf->{'-col'}->get_work($WRK, 1);
    $var->{'WRK'} = RDA::Object::Rda->native($wrk);
    $wrk =~ s/\.tmp$/.txt/;
    1 while unlink($tmp, $wrk);
    if (exists($var->{'STA'}))
    { $sta = $wrk;
      $sta =~ s/\.txt$/.sta/;
      $var->{'ERR'} = RDA::Object::Rda->native($sta);
      $var->{'STA'} = 1;
      $slf->{'-sta'} = -33;
    }
    else
    { $slf->{'-sta'} = 0;
      $var->{'ERR'} = RDA::Object::Rda->native($var->{'ERR'})
        if exists($var->{'ERR'});
    }
    $slf->{'-lin'} = [];

    # Amend some driver attributes
    foreach my $key (keys(%{$var}))
    { &{$tb_cnv{$key}}($slf, $var, $key) if exists($tb_cnv{$key});
    }
    if ($cmd eq 'DEFAULT')
    { $slf->{'-lim'} = $var->{'LIM'} if exists($var->{'LIM'});
      $slf->{'-new'} = 1             if delete($var->{'NEW'});
      $slf->{'-pre'} = $var->{'PRE'} if exists($var->{'PRE'});
      $slf->{'-trc'} = $var->{'TRC'} if exists($var->{'TRC'});
    }

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

    # Wait for the request completion
    debug($trc, "Waiting the $cmd results") if $trc;
    $cnt = $lim ? $lim + 2 : 0;
    $err = $slf->{'-ief'};
    while (! -e $wrk)
    { die _get_error($err).qq{\n} if -s $err;
      die "Request timeout\n"   if $lim && --$cnt < 0;
      debug($trc, "* Sleeping ($cnt)") if $trc;
      sleep(1);
    }
    die _get_error($err).qq{\n} if -s $err;
    $tmp = undef;

    # Treat the result when requested
    &$fct($slf, $wrk, @arg) if $fct;
    if ($sta && -f $sta)
    { _check_status($slf, $sta);
      1 while unlink($sta);
    }
    1 while unlink($wrk);
    };

  # Indicate the completion status
  if ($buf = $@)
  { $buf =~ s/[\n\r\s]+$//;
    $slf->{'-msg'} = $buf;
    debug($trc, 'Error: ', $buf) if $trc;
    RDA::Object::Rda->kill_child($slf->{'-pid'});
    $slf->{'-hnd'}->close;
    $slf->{'-hnd'} = undef;
    if ($buf =~ $OUT)
    { $slf->{'-out'} = 1;
      $slf->{'-sta'} = -34;
    }
    else
    { $slf->{'-sta'} = -35;
    }

    # Treat partial results when requested
    eval {
      if ($fct && $tmp && exists($var->{'TMP'}))
      { rename($tmp, $wrk)      if -f $tmp;
        &$fct($slf, $wrk, @arg) if -f $wrk;
      }
      };
  }
  else
  { $slf->{'-col'}->clean_work($WRK);
  }
  return $slf->{'-sta'};
}

=head2 S<$h-E<gt>switch([$flow])>

This method manages changes in flow direction.

=cut

sub switch
{ my ($slf, $flw) = @_;
  my ($cnt, $ifh, $trc);

  return unless exists($slf->{'-xfh'});

  # Close the interconnection when requested
  $trc = $slf->{'-pre'}.q{] } if $slf->{'-trc'};
  unless (defined($flw))
  { # Create the signaling file when needed
    if (exists($slf->{'-sig'}))
    { debug($trc, 'Creating the signaling file '.$slf->{'-sig'}) if $trc;
      $ifh = IO::File->new;
      $ifh->open($slf->{'-sig'}, $CREATE, $FIL_PERMS)
        or die get_string('ERR_CREATE', $slf->{'-sig'}, $!);
      $ifh->close;
      delete($slf->{'-sig'});
    }

    # Close the transfer file
    debug($trc, 'Closing the transfer file '.$slf->{'-xfr'}) if $trc;
    close($slf->{'-xfh'});
    delete($slf->{'-hnd'});
    delete($slf->{'-pid'});
    delete($slf->{'-xfc'});
    delete($slf->{'-xfh'});
    delete($slf->{'-xfr'});
    return;
  }

  # Treat direction inversion
  if ($flw)
  { unless ($slf->{'-flw'})
    { # Terminate the message treatment
      1 while unlink($slf->{'-xfc'});
      debug($trc, 'Truncating the transfer file') if $trc;
      truncate($slf->{'-xfh'}, 0);
      $slf->{'-flw'} = $flw;
    }
  }
  else
  { if ($slf->{'-flw'})
    { # Wait for a message
      debug($trc, 'Waiting a message') if $trc;
      while (! -e $slf->{'-xfc'})
      { debug($trc, q{* Sleeping (}.++$cnt.q{) for }.$slf->{'-xfc'}) if $trc;
        sleep(1);
      }
      debug($trc, 'Rewinding the transfer file') if $trc;
      seek($slf->{'-xfh'}, 0, 0);
      $slf->{'-flw'} = $flw;
    }
  }
  return;
}

# --- Result handling routines ------------------------------------------------

# Check a connection status
sub _check_connect
{ my ($slf, $wrk, $var) = @_;
  my ($ifh, $trc);

  $ifh = IO::File->new;
  $trc = $slf->{'-pre'}.'] ' if $slf->{'-trc'};
  debug($trc, 'Check the connection status') if $trc;
  $$var = 1;
  if ($ifh->open("<$wrk"))
  { while (<$ifh>)
    { s/[\n\r\s]+$//;
      debug($trc, '* ', $_) if $trc;
      if (m/^OK\b/)
      { $$var = 0;
        last;
      }
      elsif (m/^Error:\s*(.*)$/)
      { $slf->{'-msg'} = $1;
      }
    }
    $ifh->close;
  }
  return;
}

# Check an execution status
sub _check_status
{ my ($slf, $wrk) = @_;
  my ($ifh, $str, $trc);

  $ifh = IO::File->new;
  $trc = $slf->{'-pre'}.'] ' if $slf->{'-trc'};
  debug($trc, 'Check the execution status') if $trc;
  if ($ifh->open("<$wrk"))
  { while (<$ifh>)
    { s/[\n\r\s]+$//;
      debug($trc, '* ', $_) if $trc;
      if (m/^Exit:\s*(\-?\d+)/)
      { $slf->{'-sta'} = $1 << 8;
      }
      elsif (m/^Error:\s*(.*)$/)
      { $slf->{'-msg'} = $1;
      }
      elsif (m/^Hit:\s*'(.*)'/)
      { $slf->{'-hit'} = $1;
      }
      elsif (m/^Hit:\s*((?:[A-Za-z\d]{2})*)/)
      { $str = $1;
        $str =~ s/([A-Za-z\d]{2})/chr(hex($1))/eg;
        $slf->{'-hit'} = $str;
      }
    }
    $ifh->close;
  }
  return;
}

# Copy the result into a file
sub _copy_result
{ my ($slf, $src, $dst, $new) = @_;
  my ($buf, $ifh, $lgt, $ofh);

  debug($slf->{'-pre'}, '] Tranferring results') if $slf->{'-trc'};
  $ifh = IO::File->new;
  $ofh = IO::File->new;
  $ifh->open("<$src")
    or die get_string('ERR_OPEN', $src, $!);
  $ofh->open($dst, $new ? $CREATE : $APPEND, $FIL_PERMS)
    or die get_string('ERR_TRANSFER', $dst, $!);
  binmode($ofh);
  while ($lgt = $ifh->sysread($buf, 65536))
  { $ofh->syswrite($buf, $lgt)
      or die get_string('ERR_WRITE', $dst, $!);
  }
  $ifh->close;
  $ofh->close;
  return;
}

# Load the results
sub _load_lines
{ my ($slf, $wrk, $flg) = @_;
  my ($ifh);

  $ifh = IO::File->new;
  debug($slf->{'-pre'}, '] Loading execution ',
    $flg ? 'results' : 'errors') if $slf->{'-trc'};
  if ($ifh->open("<$wrk"))
  { while (<$ifh>)
    { s/[\n\r\s]+$//;
      push(@{$slf->{'-lin'}}, $_) if $flg || m/RDA-\d{5}:/;
    }
    $ifh->close;
  }
  return;
}

# Load the interface information
sub _load_meta
{ my ($slf, $wrk) = @_;
  my ($ifh, $trc);

  $ifh = IO::File->new;
  $trc = $slf->{'-pre'}.'] ' if $slf->{'-trc'};
  debug($trc, 'Loading META results') if $trc;
  if ($ifh->open("<$wrk"))
  { while (<$ifh>)
    { s/[\n\r\s]+$//;
      debug($trc, '* ', $_) if $trc;
      $slf->{$1} = $2 if m/^(\-\w+)\='(.*)'/;
    }
    $ifh->close;
  }
  return;
}

# Write the result into a report or a buffer
sub _write_result
{ my ($slf, $src, $dst) = @_;
  my ($buf, $ifh, $lgt);

  debug($slf->{'-pre'}, '] Tranferring results') if $slf->{'-trc'};
  $ifh = IO::File->new;
  $ifh->open("<$src")
    or die get_string('ERR_OPEN', $src, $!);
  while ($lgt = $ifh->sysread($buf, 65536))
  { $dst->syswrite($buf, $lgt)
      or die get_string('ERR_WRITE', $dst->get_file, $!);
  }
  $ifh->close;
  return;
}

# --- Conversion routines -----------------------------------------------------

sub _cnv_array
{ my ($slf, $var, $key) = @_;

  $var->{$key.q{#}} = _set_array($var, $key, delete($var->{$key}))
    if ref($var->{$key}) eq 'ARRAY';
  return;
}

sub _cnv_match
{ my ($slf, $var, $key) = @_;

  if (ref($var->{$key}) eq 'ARRAY')
  { my ($cnt);

    $cnt = 0;
    foreach my $val (@{delete($var->{$key})})
    { ++$cnt;
      $var->{$key.$cnt} = _fmt_match($val);
    }
    $var->{$key.q{#}} = $cnt;
  }
  else
  { $var->{$key} = _fmt_match($var->{$key});
  }
  return;
}

sub _cnv_next
{ my ($slf, $var) = @_;

  if (ref($var->{'NXT'}) eq 'ARRAY')
  { my ($ack, $cnt, $val);

    $ack = exists($var->{'ACK'})
      ? _fmt_octal(delete($var->{'ACK'}))
      : '0012';
    $cnt = 0;
    foreach my $rec (@{delete($var->{'NXT'})})
    { next unless ref($rec) eq 'ARRAY'
        && defined($val = $rec->[0]) && length($val);
      ++$cnt;
      $var->{"NXT$cnt"} = _fmt_match($val);
      $var->{"ACK$cnt"} = (defined($val = $rec->[1]) && length($val))
        ? _fmt_octal($val)
        : $ack;
    }
    $var->{'NXT#'} = $var->{'ACK#'} = $cnt;
  }
  else
  { $var->{'ACK'} = _fmt_octal($var->{'ACK'}) if exists($var->{'ACK'});
    $var->{'NXT'} = _fmt_match($var->{'NXT'});
  }
  return;
}

sub _fmt_match
{ my ($str) = @_;
  my ($opt, $pat, @opt);

  ($pat, $opt) = ($str =~ m{^\s*/(.*)/([a-z]*)})         ? ($1, $2) :
                 ($str =~ m{^\s*m\s*\{(.*)\}([a-z]*)})   ? ($1, $2) :
                 ($str =~ m{^\s*m\s*\[(.*)\]([a-z]*)})   ? ($1, $2) :
                 ($str =~ m{^\s*m\s*\((.*)\)([a-z]*)})   ? ($1, $2) :
                 ($str =~ m{^\s*m\s*\<(.*)\>([a-z]*)})   ? ($1, $2) :
                 ($str =~ m{^\s*m\s*(\W)(.*)\1([a-z]*)}) ? ($2, $3) :
                                                           ($str, q{});
  $pat = q{(?}.join(q{}, @opt).q{)}.$pat
    if $opt && (@opt = grep {m/[ims]/} split(//, $opt));
  return $pat;
}

sub _fmt_octal
{ my ($str) = @_;

  return join(q{}, map {sprintf('%04o', $_)} unpack('c*', $str));
}

sub _set_array
{ my ($var, $key, $arr) = @_;
  my ($cnt);

  $cnt = 0;
  foreach my $val (@{$arr})
  { ++$cnt;
    $var->{$key.$cnt} = $val;
  }
  return $cnt;
}

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

# Create the driver manager
sub _create_manager
{ my ($cls, $col, $lim) = @_;
  my ($cfg, $cod, $ctl, $jar, $jsc, $rem, $slf, $trc);

  # Try to locate JSCH in DA
  $trc = $col->get_trace('JSCH');
  debug('DA] Searching for Rda2Jsch.jar ...') if $trc;
  $cfg = $col->get_config;
  return unless (-f ($jar = $cfg->get_file('D_RDA', "da/$JAR")) &&
                 -f ($jsc = $cfg->get_file('D_RDA', "da/$JSC")))
             || (-f ($jar = $cfg->get_file('D_RDA', "../$JAR")) &&
                 -f ($jsc = $cfg->get_file('D_RDA', "../$JSC")));
  if ($trc)
  { debug("DA]  => $jar found");
    debug("DA]  => $jsc found");
  }

  # Prepare the Java interface
  eval {
    $ctl = $col->get_inline->force_context('Java');
    debug("DA] Defining $NAM Java interface ...") if $trc;
    $cod = RDA::Object::Java->new_command($NAM, $CLS);
    $cod->add_jar($jar);
    $cod->add_jar($jsc);
    $cod = $ctl->add_common($cod->add_sequence);
    };
  if ($@)
  { debug("DA] Error in Java interface preparation:\nDA]  $@") if $trc;
    return;
  }

  # Initialize the authentication agent
  $rem = $col->get_remote;
  $rem->set_agent;

  # Create the driver manager object
  $slf = bless {
    -cfg => $cfg,
    -cod => $cod,
    -col => $col,
    -ctl => $ctl,
    -lng => $cod->get_language,
    -msg => undef,
    -new => $col->get_first('REMOTE.B_NEW'),
    -nod => 'DA',
    -opt => $rem->has_agent ? ['-a'] : [],
    -out => 0,
    -pre => 'DA',
    -sta => 0,
    -sys => $col->get_agent->get_system,
    -trc => $trc,
    }, $cls;

  # Request the interface information to test the interface
  return request($slf, 'META', {FCT => [\&_load_meta], LIM => $lim})
    ? undef
    : end($slf);
}

# Get the Java error
sub _get_error
{ my ($err) = @_;
  my ($buf, $ifh);

  return 'Request error'
    unless -s $err && ($ifh = IO::File->new)->open("<$err");
  $buf = join("\n ", <$ifh>);
  $ifh->close;
  return $buf;
}

# Get the communication handle
sub _get_handle
{ my ($slf) = @_;
  my ($bkp, $msg);

  # Initialise the communication handle on the first call
  unless (exists($slf->{'-hnd'}))
  { $slf->{'-cod'}->set_info('pre', $slf->{'-trc'} ? q{DA} : q{});
    $bkp = $slf->{'-sys'}->set_context({RDA_DUMP  => undef,
                                        RDA_LEVEL => undef,
                                        RDA_TRACE => undef,
                                        RDA_TRACK => undef});
    eval {($slf->{'-pid'}, undef, $slf->{'-ief'}) =
      $slf->{'-ctl'}->pipe_code($slf->{'-hnd'} = IO::File->new,
                                $slf->{'-lng'}, $NAM, @{$slf->{'-opt'}})};
    $msg = $@;
    $slf->{'-sys'}->restore_context($bkp);
    if ($msg)
    { $msg =~ s/[\n\r\s]+$//;
      $slf->{'-msg'} = $msg;
      return $slf->{'-hnd'} = undef;
    }

    # Load some defaults
    return $slf->{'-hnd'} = undef
      if exists($slf->{'-ses'}) && _set_default($slf);
  }

  # Delete the previous message
  $slf->{'-msg'} = undef;

  # Return the remote handle
  return $slf->{'-hnd'};
}

# Set some defaults
sub _set_default
{ my ($slf, $flg) = @_;
  my ($val, %var);

  if ($val = $slf->{'-col'}->get_first('REMOTE.T_AGENT_LOG'))
  { $val = sprintf($val, $$);
    $var{'AGT'} = RDA::Object::Rda->quote(RDA::Object::Rda->is_unix
      ? $val
      : RDA::Object::Rda->short($val));
  }
  elsif ($slf->{'-trc'} & 0x0100)  ## no critic (Bit,Number)
  { $var{'AGT'} = 'RdaSsh.log';
  }
  $var{'LIM'} = $slf->{'-lim'} if $slf->{'-lim'};
  $var{'PRE'} = $slf->{'-pre'};
  $var{'RDA'} = $slf->{'-cfg'}->get_value('T_SHORT');
  $var{'TRC'} = $flg ? 0 : $slf->{'-trc'} & 0xff;  ## no critic (Bit,Number)
  $var{'RDA#'} = _set_array(\%var, 'RDA',
                            scalar $slf->{'-cfg'}->get_value('T_SELF'))
                            unless $slf->{'-cfg'}->is_cygwin;
  return request($slf, 'DEFAULT', {%var});
}

1;

__END__

=head1 SEE ALSO

L<RDA::Agent|RDA::Agent>,
L<RDA::Object::Access|RDA::Object::Access>,
L<RDA::Object::Collect|RDA::Object::Collect>,
L<RDA::Object::Inline|RDA::Object::Inline>,
L<RDA::Object::Java|RDA::Object::Java>,
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