# Agent.pm: Class Used to Communicate between Agents

package RDA::Handle::Agent;

# $Id: Agent.pm,v 1.11 2015/09/25 07:17:00 RDA Exp $
# ARCS: $Header: /home/cvs/cvs/RDA_8/src/scripting/lib/RDA/Handle/Agent.pm,v 1.11 2015/09/25 07:17:00 RDA Exp $
#
# Change History
# 20150920  MSC  Eliminate Perl 5.22 warnings.

=head1 NAME

RDA::Handle::Agent - Class Used to Communicate between Agents

=head1 SYNOPSIS

require RDA::Handle::Agent;

=head1 DESCRIPTION

The following methods are available:

=cut

use strict;

BEGIN
{ use Exporter;
  use IO::Handle;
  use Symbol qw(qualify);
  use RDA::Text qw(get_string);
  use RDA::Local::Windows qw($CAN_PRC $CAN_WIN);
}

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

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

# Define the global private constants

# Define the global private variables

=head2 S<$h = RDA::Handle::Agent-E<gt>new($request)>

The object constructor.

C<RDA::Handle::Data> is represented by a symbol, which can be used as a file
handle. The following special keys are used:

=over 12

=item S<    B<'drv' > > Reference to the session driver object

=item S<    B<'emu' > > Emulation indicator

=item S<    B<'ifh' > > Input file handle

=item S<    B<'ofh' > > Output file handle

=item S<    B<'pid' > > Process identifier

=back

The request is described by a hash reference containing the following keys:

=over 12

=item S<    B<'cmd' > > Command array

=item S<    B<'hst' > > Remote host

=item S<    B<'usr' > > Remote user

=item S<    B<'opt' > > Option array

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

=item S<    B<'trc' > > Trace redirection

=back

=cut

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

  # Create the handle
  $slf = bless Symbol::gensym(), ref($cls) || $cls;
  tie *$slf, $slf;  ## no critic (Tie)
  $slf->open($req);

  # Return the handle
  return $slf;
}

sub open  ## no critic (Builtin)
{ my ($slf, $req) = @_;
  my ($can, $drv);

  # Create the handle when not yet done
  return $slf->new unless ref($slf);

  # Create the communication channel
  die get_string('NO_SESSION')
    unless ref($req->{'ses'}) eq 'RDA::Object::Remote';
  *$slf->{'drv'} = $drv = $req->{'ses'}->get_driver;
  die get_string('NO_INTERCONNECT')
    unless ($can = $drv->can_interconnect);
  *$slf->{'emu'} = $can < 0;
  *$slf->{'pid'} = $req->{'ses'}->interconnect($req,
    *$slf->{'ofh'} = IO::Handle->new,
    *$slf->{'ifh'} = IO::Handle->new,
    exists($req->{'trc'}) ? $req->{'trc'} : '>&=2');
  binmode(*$slf->{'ifh'});
  binmode(*$slf->{'ofh'});

  # Return the handle reference
  return $slf;
}

# Manage handle attributes
sub getinfo
{ my ($slf, $key, $dft) = @_;

  return exists(*$slf->{$key}) ? *$slf->{$key} : $dft;
}

sub setinfo
{ my ($slf, $key, $val) = @_;
  my ($old);

  $old = *$slf->{$key};
  *$slf->{$key} = $val if defined($val);
  return $old;
}

# Declare a routine for an undefined functionality
my $und = sub { return };

=head1 BASIC I/O METHODS

See L<perlfunc|perlfunc> for complete descriptions of each of the following
methods, which are just front ends for the corresponding built-in functions:

    $io->close
    $io->eof
    $io->fileno
    $io->getc
    $io->read(BUF,LEN,[OFFSET])
    $io->print(ARGS)
    $io->printf(FMT,[ARGS])
    $io->stat
    $io->sysread(BUF,LEN,[OFFSET])
    $io->syswrite(BUF,[LEN,[OFFSET]])
    $io->truncate(LEN)

=cut

sub close  ## no critic (Ambiguous,Builtin)
{ my $slf = shift;

  *$slf->{'drv'}->switch if *$slf->{'emu'};
  *$slf->{'drv'}->end;
  *$slf->{'ofh'}->close;
  *$slf->{'ifh'}->close;
  delete *$slf->{'ifh'};
  delete *$slf->{'ofh'};
  delete *$slf->{'pid'};
  undef *$slf;
  return 1;
}

sub eof  ## no critic (Builtin)
{ my $slf = shift;

  return *$slf->{'ifh'}->eof;
}

sub fileno  ## no critic (Builtin)
{ my $slf = shift;

  return *$slf->{'ifh'}->fileno;
}

sub getc  ## no critic (Builtin)
{ my $slf = shift;

  return *$slf->{'ifh'}->getc;
}

sub print  ## no critic (Builtin)
{ my $slf = shift;

  $slf->write(join((defined($,) ? $, : q{}), @_).(defined($,) ? $, : q{}));
  return 1;
}

sub printf  ## no critic (Builtin)
{ my $slf = shift;
  my $fmt = shift;

  $slf->write(sprintf($fmt, @_));
  return 1;
}
*read = \&sysread;

sub stat  ## no critic (Builtin)
{ my ($slf) = @_;

  return unless $slf->opened;
  return 1 unless wantarray;
  ## no critic (Number,Zero)
  return (undef, # device
          undef, # inode
          0666,  # filemode
          1,     # links
          $>,    # user identidier
          $),    # group identidier
          undef, # device identidier
          undef, # size
          undef, # atime
          undef, # mtime
          undef, # ctime
          undef, # block size
          undef, # blocks
         );
}

sub sysread  ## no critic (Builtin)
{ my $slf = shift;

  *$slf->{'drv'}->switch(0) if *$slf->{'emu'};
  return *$slf->{'ifh'}->sysread(@_);
}

sub syswrite  ## no critic (Builtin)
{ my $slf = shift;

  *$slf->{'drv'}->switch(1) if *$slf->{'emu'};
  return *$slf->{'ofh'}->syswrite(@_);
}

*truncate = $und;

=head1 I/O METHODS RELATED TO PERL VARIABLES

See L<perlvar|perlvar> for complete descriptions of each of the following
methods. All of them return the previous value of the attribute and takes an
optional single argument that when given will set the value. If no argument
is given the previous value is unchanged.

    $|    $io-E<gt>autoflush([BOOL])
    $.    $io-E<gt>input_line_number([NUM])

=cut

*autoflush = $und;
*input_line_number = $und;

=head1 IO::HANDLE LIKE METHODS

See L<IO::Handle|IO::Handle> for complete descriptions of each of the following
methods:

    $io->blocking([BOOL])
    $io->clearerr
    $io->error
    $io->flush
    $io->getline
    $io->getlines
    $io->opened
    $io->printflush(ARGS)
    $io->sync
    $io->ungetc(ORD)
    $io->untaint
    $io->write(BUF,LEN[,OFFSET])

=cut

*blocking = $und;
*clearerr = $und;
*error = $und;
*fcntl = $und;

sub flush
{ my $slf = shift;

  return *$slf->{'ofh'}->flush;
}

sub getline
{ my $slf = shift;

  return *$slf->{'ifh'}->getline;
}

sub getlines
{ my $slf = shift;

  return *$slf->{'ifh'}->getlines;
}

*ioctl = $und;

sub opened
{ my $slf = shift;

  return defined(*$slf->{'pid'});
}

*printflush = $und;
*setbuf = $und;
*setvbuf = $und;
*sync = $und;

sub ungetc
{ my $slf = shift;

  return *$slf->{'ifh'}->ungetc;
}

*untaint = $und;
*write = \&syswrite;

=head1 SEEK METHODS

See L<IO::Seekable||IO::Seekable> for complete descriptions of each of the
following methods:

    $io->getpos
    $io->setpos($pos)
    $io->seek($pos,$whence)
    $io->sysseek($pos,$whence)
    $io->tell

=cut

*getpos = $und;
*seek = $und;
*setpos = $und;
*sysseek = $und;
*tell = $und;

=head1 TIE METHODS

Following methods are implemented to emulate a file handle:

    BINMODE this
    CLOSE this
    DESTROY this
    EOF this
    FILENO this
    GETC this
    OPEN this, mode, LIST
    PRINT this, LIST
    PRINTF this, format, LIST
    READ this, scalar, length, offset
    READLINE this
    SEEK this, position, whence
    TELL this
    TIEHANDLE classname, LIST
    WRITE this, scalar, length, offset

=cut

sub BINMODE
{ my $slf = shift;

  return (@_) ? 0 : 1;
}

*CLOSE = \&close;

sub DESTROY { }

*EOF = \&eof;
*FILENO = \&fileno;
*GETC = \&getc;
*OPEN = \&open;
*PRINT = \&print;
*PRINTF = \&printf;
*READ = \&sysread;
*READLINE = \&getline;
*SEEK = $und;
*TELL = $und;

sub TIEHANDLE
{ my $slf = shift;

  unless (ref($slf))
  { $slf = bless Symbol::gensym(), $slf;
    $slf->open(@_);
  }
  return $slf;
}

*WRITE = \&syswrite;

=head1 OTHER I/O METHODS

=for stopwords autoflush

=head2 S<RDA::Handle::Agent::exec_command($wfh,$rfh,$efh,$cmd[,$arg,...])>

This method spawns the given command and connects $rfh for reading, $wfh for
writing, and $efh for errors. If $efh is false then STDOUT and STDERR of the
child are on the same file handle. The $wfh will have autoflush turned on.

If C<E<lt>E<amp>FH> or C<E<lt>E<amp>=FD> is specified as output handle, it
will be closed in the parent, and the child will read from it directly. If
C<E<gt>E<amp>FH> or C<E<gt>E<amp>=FD> is specified as input or error handle,
then the child will send output directly to it.

It returns the process identifier of the child process. On failure, it just
raises an exception matching C</^exec_command:/>. However, C<exec> failures in
the child are not reported.

The child must be explicitly removed from the process queue using
C<waitpid($pid,0)>.

This code is derived from C<IPC::OPen3>.

=cut

sub exec_command  ## no critic (Complex)
{ my ($p_w, $p_r, $p_e, @cmd) = @_;
  my ($c_e, $c_r, $c_w, $flg, $pid, $pkg);

  no strict 'refs';  ## no critic (Strict)

  # Create the communication pipes
  $p_e ||= $p_r;
  $flg = $p_e eq $p_r;
  $pkg = caller;
  _pipe($c_r = IO::Handle->new, $p_w, 'I') unless ($p_w =~ s/^[<>]&//);
  _pipe($p_r, $c_w = IO::Handle->new, 'O') unless ($p_r =~ s/^[<>]&//);
  _pipe($p_e, $c_e = IO::Handle->new, 'E') unless ($p_e =~ s/^[<>]&//) || $flg;

  # Create and initialize the child process
  if ($^O eq 'MSWin32' || $^O eq 'MSWin64')
  { my ($can, $f_e, $f_r, $f_w, $prc, $ret, @err, @fds, %sav);

    # Examine the possible redirections
    $f_r = $c_r                  ? q{=}.CORE::fileno($c_r) :
           ($p_w =~ /^=?(\d+)$/) ? qq{=$1} :
                                   qualify($p_w, $pkg);

    $f_w = $c_w                  ? q{=}.CORE::fileno($c_w) :
           ($p_r =~ /^=?(\d+)$/) ? qq{=$1} :
                                   qualify($p_r, $pkg);

    $f_e = $flg                  ? $f_w :
           $c_e                  ? q{=}.CORE::fileno($c_e) :
           ($p_e =~ /^=?(\d+)$/) ? qq{=$1} :
                                   qualify($p_e, $pkg);

    # Determine child file descriptors
    @fds = (
      { hnd  => \*STDIN,
        mod  => q{r},
        pre  => q{<&},
        new  => $f_r,
      },
      { hnd  => \*STDOUT,
        mod  => q{w},
        pre  => q{>&},
        new  => $f_w,
      },
      { hnd  => \*STDERR,
        mod  => q{w},
        pre  => q{>&},
        new  => $f_e,
      },
      );

    # Create the child process
    eval {
      # Take a copy of STDIN, STDOUT, and STDERR
      foreach my $fd (@fds)
      { $fd->{'bkp'} = IO::Handle->new_from_fd($fd->{'hnd'}, $fd->{'mod'});
        $sav{q{=}.CORE::fileno($fd->{'hnd'})} = q{=}.CORE::fileno($fd->{'bkp'});
      }

      # Redirect file handles before launching the command
      foreach my $fd (@fds)
      { CORE::open($fd->{'hnd'},
          $fd->{'pre'}.($sav{$fd->{'new'}} || $fd->{'new'}))
          or push(@err, "open failed: $!");
      }

      # Launch the command
      unless (@err)
      { $can = RDA::Local::Windows->can_spawn;
        if ($can & $CAN_PRC)       ##  no critic (Bit)
        { # Launch the command in background using Win32::Process
          ## no critic (Explicit,Exported)
          $ret = eval {Win32::Process::Create($prc, $cmd[0],
            join(q{ }, map {m/^".*"$/ ? $_
                                      : RDA::Local::Windows->quote($_)} @cmd),
            0, 0, q{.})};
          if ($@)
          { push(@err, "Cannot spawn (Win32::Process)1: $@");
          }
          elsif ($ret)
          { $pid = $prc->GetProcessID();
          }
          elsif ($can & $CAN_WIN)  ##  no critic (Bit)
          { push(@err, 'Cannot spawn (Win32::Process)2: '.
                       Win32::FormatMessage(Win32::GetLastError()));
          }
          else
          { push(@err, 'Cannot spawn (Win32::Process)');
          }
        }
        elsif ($can & $CAN_WIN)    ##  no critic (Bit)
        { # Launch the command in background using Win32
          ## no critic (Explicit,Exported)
          $ret = eval {Win32::Spawn($cmd[0],
            join(q{ }, map {m/^".*"$/ ? $_
                                      : RDA::Local::Windows->quote($_)} @cmd),
            $pid)};
          if ($@)
          { push(@err, "Cannot spawn (Win32): $@");
          }
          elsif (!$ret)
          { push(@err, 'Cannot spawn (Win32): '.
                       Win32::FormatMessage(Win32::GetLastError()));
          }
        }
        else
        { # Launch the command in background using system(1, ...)
          $pid = eval {system(1, @cmd)};
          push(@err, "Cannot spawn NOWAIT: $!")
            unless $pid && $pid >= 0;  ## no critic (Unless)
        }
      }

      # Ajust parent file handles before generating any error
      foreach my $fd (@fds)
      { CORE::open($fd->{'hnd'},
          $fd->{'pre'}.q{=}.CORE::fileno($fd->{'bkp'}))
          or push(@err, "open failed: $!");
        $fd->{'bkp'}->close
          or push(@err, "closed failed: $!");
      }
      die join("\n", @err, q{}) if @err;
    };
    die "exec_command: $@" if $@;
  }
  elsif (($pid = _fork()) == 0)  # Child process
  { my $tmp;

    # A tie in the parent should not be allowed
    untie *STDIN;
    untie *STDOUT;

    # Save stdout when child's dup of stderr is required
    $tmp = IO::Handle->new_from_fd(\*STDOUT, 'w')
      unless $flg || $c_e ||  ## no critic (Unless)
             CORE::fileno(STDOUT) != _fileno2($p_e, $pkg);

    # Manage the file descriptors
    if ($c_r)
    { _close($p_w);
      _open(\*STDIN, q{<&=}.CORE::fileno($c_r));
    }
    else
    { $p_w = qualify($p_w, $pkg) unless $p_w =~ /^=?\d+$/;
      _open(\*STDIN, qq{<&$p_w})
        if CORE::fileno(STDIN) != _fileno($p_w);
    }
    if ($c_w)
    { _close($p_r);
      _open(\*STDOUT, q{>&=}.CORE::fileno($c_w));
    }
    else
    { $p_r = qualify($p_r, $pkg) unless $p_r =~ /^=?\d+$/;
      _open(\*STDOUT, qq{>&$p_r})
        if CORE::fileno(STDOUT) != _fileno($p_r);
    }
    if ($flg)
    { _open(\*STDERR, q{>&STDOUT})
        if CORE::fileno(STDERR) != CORE::fileno(STDOUT);
    }
    elsif ($c_e)
    { _close($p_e);
      _open(\*STDERR, q{>&=}.CORE::fileno($c_e));
    }
    elsif ($tmp)
    { _open(\*STDERR, q{>&}._fileno($tmp))
        if CORE::fileno(STDERR) != CORE::fileno($tmp);
      CORE::close($tmp);
    }
    else
    { $p_e = qualify($p_e, $pkg) unless $p_e =~ /^=?\d+$/;
      _open(\*STDERR, qq{>&$p_e}) if CORE::fileno(STDERR) != _fileno($p_e);
    }

    # Execute the command
    exec(@cmd)
      or die 'exec_command: Cannot exec '.join(q{ }, @cmd)."\n";
  }

  # Unbuffer parent output pipe
  select((select($p_w), $| = 1)[0]);  ## no critic (Local,Select)

  # Close child file handles
  _close($c_r) if $c_r;
  _close($c_w) if $c_w;
  _close($c_e) if $c_e;

  # Return the child process identifier
  return $pid;
}

sub _close
{ return CORE::close($_[0])
    || die "exec_command: close failed $_[0]: $!\n";
}

sub _fileno
{ return ($_[0] =~ m/^=?(\d+)$/) ? $1 : CORE::fileno($_[0]);
}

sub _fileno2
{ return ($_[0] =~ m/^=?(\d+)$/) ? $1 : CORE::fileno(qualify($_[0], $_[1]));
}

sub _fork
{ my $pid = fork();
  return $pid if defined($pid);
  die "exec_command: fork failed: $!\n";
}

sub _open
{ return CORE::open($_[0], $_[1])
    || die "exec_command: open failed: $!\n";
}

sub _pipe
{ return pipe($_[0], $_[1])
    || die "exec_command: pipe($_[2]) failed: $!\n";
}

1;

__END__

=head1 SEE ALSO

L<RDA::Agent|RDA::Agent>,
L<RDA::Local::Windows|RDA::Local::Windows>,
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