# AGENT.pm: AGENT Command Library

package RDA::Request::AGENT;

# $Id: AGENT.pm,v 1.10 2015/10/02 14:16:59 RDA Exp $
# ARCS: $Header: /home/cvs/cvs/RDA_8/src/scripting/lib/RDA/Request/AGENT.pm,v 1.10 2015/10/02 14:16:59 RDA Exp $
#
# Change History
# 20150925  MSC  Add the AGENT.BOOT command.

=head1 NAME

RDA::Request::AGENT - Agent Command Library

=head1 SYNOPSIS

require RDA::Request::AGENT;

=head1 DESCRIPTION

The objects of the C<RDA::Request::AGENT> class are used to interface with
agents.

The following methods are available:

=cut

use strict;

BEGIN
{ use Exporter;
  use IO::File;
  use RDA::Text qw(get_string);
  use RDA::Agent;
  use RDA::Handle::Data;
  use RDA::Handle::Memory;
  use RDA::Object;
  use RDA::Object::Message;
  use RDA::Object::Rda qw($CREATE $EXE_PERMS $FIL_PERMS);
  use RDA::Text;
}

# 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_chk = (
  dir => {D_RDA     => [qw(Convert IRDA RDA ccr da modules tools)],
          D_RDA_INC => [qw(Convert IRDA RDA RDA/Extern)],
         },
  fil => {D_RDA     => [qw(irdacfg.cyg irdacfg.ini irdacfg.vms irdacfg.win
                           rda.cfg rda.exe cmd.exe
                           engine/rda.cfg engine/rda.dft
                           .filter filter.vms filter.win)],
          D_RDA_INC => [qw(RDA/Build.pm RDA/Request/TEST.pm RDA/UI/Test.pm)],
          D_RDA_REL => [qw(rda.dat)],
         },
  );
my %tb_cmd = (
  'AGENT.ANALYZE'   => \&_do_analyze,
  'AGENT.BOOT'      => \&_do_boot,
  'AGENT.CHECK'     => \&_do_check,
  'AGENT.EXIT'      => \&_do_exit,
  'AGENT.EXTRA'     => \&_do_extra,
  'AGENT.GET'       => \&_do_get,
  'AGENT.GET_USAGE' => \&_do_usage,
  'AGENT.INFO'      => \&_do_info,
  'AGENT.INIT'      => \&_do_init,
  'AGENT.SLEEP'     => \&_do_sleep,
  'AGENT.START'     => \&_do_start,
  'AGENT.STOP'      => \&_do_stop,
  'AGENT.SUBMIT'    => \&_do_submit,
  'AGENT.VALIDATE'  => \&_do_validate,
  'AGENT.VERIFY'    => \&_do_verify,
  'AGENT.VERSION'   => \&_do_version,
  );

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

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

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

C<RDA::Request::AGENT> 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<'_bld'> > Current RDA build

=item S<  B<'_cfg'> > Reference to the RDA software configuration

=item S<  B<'_chk'> > Check sum hash

=item S<  B<'_dsp'> > Reference to the display control object when verbose

=item S<  B<'_ver'> > Current RDA version

=back

Internal keys are prefixed by an underscore.

=cut

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

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

=head2 AGENT.ANALYZE - Installation analyze command

This command analyzes the RDA installation and determines the files that must
be requested.

=cut

sub _do_analyze
{ my ($slf, $req) = @_;
  my ($cfg, $chk, $fil, $ifh, $pth, $ptr, $top, @err);

  # Load the check sum file if needed
  $cfg = $slf->{'_cfg'};
  unless (exists($slf->{'_chk'}))
  { $ifh = IO::File->new;
    $fil = $cfg->get_file('D_RDA_REL', 'rda.dat');
    return $req->error('NoFile', $!) unless $ifh->open("<$fil");
    return $req->error('BadFile')    if _load_chksum($slf, $slf, $ifh);
  }

  # Check the RDA installation
  foreach my $grp (sort keys(%{$slf->{'_chk'}}))
  { next unless ($top = $cfg->get_group($grp));
    foreach my $dir (sort keys(%{$chk = $slf->{'_chk'}->{$grp}}))
    { $pth = ($dir eq q{.})
        ? $top
        : $cfg->cat_dir($top, split(/\//, $dir));

      # Check the directory content
      if (opendir(DIR, $pth))
      { foreach my $nam (sort readdir(DIR))
        { next unless exists($chk->{$dir}->{$nam})
            && -f ($fil = $cfg->cat_file($pth, $nam));
          $ptr = $chk->{$dir}->{$nam};
          $ptr->[2] = 1 if -r $fil && $ptr->[0] == _get_chksum($fil);
        }
        closedir(DIR);
      }

      # Identify missing files
      foreach my $nam (sort keys(%{$chk->{$dir}}))
      { $ptr = $chk->{$dir}->{$nam};
        push(@err, ($ptr->[1] ? 'R' : 'X').($ptr->[3] ? 'O' : 'M').$ptr->[0]
          ."[$grp]$dir $nam") unless $ptr->[2];
      }
    }
  }

  # Indicate the analysis result
  return (scalar @err)
    ? $req->new('INFO.Analyze')->add_data([@err])
    : $req->new('OK.Analyze');
}

sub _get_chksum
{ my ($fil) = @_;

  my $ifh = IO::File->new;
  return $ifh->open("<$fil") ? _calc_chksum($ifh) : 0;
}

=head2 AGENT.BOOT - Installation boot command

This command clones the RDA installation of the parent node. It supports the
following attributes:

=over 12

=item B<  install>

Specifies a list of extra elements to install. Each element is represented by
three items separated by a vertical bar: a directory group, a sub directory,
the file name.

=item B<  next>

Specifies the command to execute at a successful completion to replace the
current agent.

=back


=cut

sub _do_boot  ## no critic (Complex)
{ my ($slf, $req) = @_;
  my ($bld, $cfg, $cur, $dat, $drv, $flg, $ifh, $mod, $pth, $rsp, $tbl, $val);

  $cfg = $slf->{'_cfg'};
  eval {
    die get_string('NO_DRIVER')
      unless ($drv = $slf->{'_agt'}->get_info('drv'));
    if (-f ($pth = $cfg->get_file('D_RDA_REL', 'rda.dat')))
    { # Check the current installation
      eval {
        $ifh = IO::File->new;
        $ifh->open("<$pth") or die get_string('ERR_OPEN', $pth, $!);
        die get_string('BAD_CURRENT', $pth) if _load_chksum($slf, $slf, $ifh);
        $cur = $slf->{'_bld'};
        $tbl = _check_rda($slf, $slf);
        die get_string('HAS_ERRORS') if exists($tbl->{'err'});
        require RDA::Build;
        die get_string('BAD_BUILD') if $RDA::Build::BUILD lt $cur;
        };
      $cur = undef if $@;
    }

    if ($cfg->get_value('B_NO_UPGRADE'))
    { die get_string('NO_UPGRADE') unless defined($cur);
    }
    else
    { # Analyze the installation
      ($tbl, $dat, $bld) = _get_checksum($slf, $drv, $cur);
      die get_string('HAS_NEW_ERRORS') if exists($tbl->{'err'});

      # Add the installation directives
      foreach my $itm ($req->get_value('install'))
      { my ($dir, $grp, $nam, $sub);

        ($grp, $sub, $nam) = split(/\|/, $itm);
        next unless defined($dir = $cfg->get_dir($grp, $sub));
        $tbl->{'alt'}->{$dir}->{$nam} = [$grp, $sub, 1];
      }

      # Create the directory structure
      eval {
        if (exists($tbl->{'mis'}))
        { foreach my $dir (sort keys(%{$tbl->{'mis'}}))
          { $cfg->create_dir($dir);
          }
          $flg += 2;
        }
        if (exists($tbl->{'alt'}))
        { foreach my $dir (sort keys(%{$tbl->{'alt'}}))
          { next if -w $dir;
            $mod = (stat($dir))[2];
            $mod |= 0400;  ## no critic (Bit)
            chmod($mod, $dir) or die get_string('ERR_CHMOD', $dir, $!);
          }
          $flg += 1;
        }
      };
      if ($@)
      { die $@ unless defined($cur);
        $flg = 0;
      }

      # Get the files
      if ($flg)
      { $tbl->{'mis'}->{$cfg->get_dir('D_RDA_INC', 'RDA')}->{'Build.pm'} =
          ['D_RDA_INC', 'RDA', 1];
        foreach my $key ('mis', 'alt')
        { if (exists($tbl->{$key}))
          { foreach my $dir (sort keys(%{$tbl->{$key}}))
            { foreach my $nam (sort keys(%{$tbl->{$key}->{$dir}}))
              { _get_file($drv, $flg, $dir, $nam,
                  @{$tbl->{$key}->{$dir}->{$nam}});
              }
            }
          }
          $flg = 0;
        }
        _set_engine($slf);
        if ($dat)
        { _save_file($dat, $cfg->create_dir($cfg->get_group('D_RDA_REL')),
            'rda.dat', 1);
          $cur = $bld;
        }
      }
    }

    # Specify a post treatment
    $drv->set_info('fct', \&_switch_agent) if $req->is_defined('next');
    };

  # Generate and return the response
  return $req->reply($@, 'Init', {build => $cur, os => $^O});
}

sub _check_rda
{ my ($slf, $tbl) = @_;
  my ($cfg, $chk, $dir, $fil, $ifh, $min, $ptr, $res, $top, $win);

  $cfg = $slf->{'_cfg'};
  $ifh = IO::File->new;
  $res = {};
  $win = $slf->{'_win'};
  foreach my $grp (sort keys(%{$tbl->{'_chk'}}))
  { next unless ($top = $cfg->get_group($grp));
    foreach my $sub (sort keys(%{$chk = $tbl->{'_chk'}->{$grp}}))
    { $dir = ($sub eq q{.})
        ? $top
        : RDA::Object::Rda->cat_dir($top, split(/\//, $sub));

      # Check existing files
      if (opendir(DIR, $dir))
      { foreach my $nam (sort readdir(DIR))
        { next unless -f ($fil = RDA::Object::Rda->cat_file($dir, $nam))
            && exists($chk->{$sub}->{$nam});
          $ptr = $chk->{$sub}->{$nam};
          $ptr->[2] = 2;
          if (-r $fil && $ifh->open("<$fil"))
          { unless ($ptr->[0] == _calc_chksum($ifh))
            { $res->{'alt'}->{$dir}->{$nam} = [$grp, $sub, $ptr->[1]];
            }
            unless ($ptr->[1] || $win || -x $fil)
            { ++$res->{'err'}->{"$grp/$sub/$nam"};
            }
          }
          else
          { ++$res->{'err'}->{"$grp/$sub/$nam"};
          }
        }
        closedir(DIR);
      }

      # Identify missing files
      $min = ($sub eq 'engine') ? 2 : 1;
      foreach my $nam (sort keys(%{$chk->{$sub}}))
      { $ptr = $chk->{$sub}->{$nam};
        $res->{'mis'}->{$dir}->{$nam} = [$grp, $sub, $ptr->[1]]
          if $ptr->[2] < $min;
      }
    }
  }
  return $res;
}

sub _get_checksum
{ my ($slf, $drv, $ver) = @_;
  my ($dat, $ifh, $rsp, $tbl);

  $rsp = $drv->exec_request(RDA::Object::Message->new('AGENT.GET',
    group => 'D_RDA_REL',
    lines => '1',
    path  => 'rda.dat',
    ));
  die get_string('ERR_GET_NEW', $1) if $rsp->{'msg'} =~ m/^ERROR\.(\w+)$/;
  die get_string('NO_NEW') unless ($ifh = RDA::Handle::Data->new($rsp));
  $dat = [@{$rsp->get_data}];
  die get_string('BAD_NEW') if _load_chksum($slf, $tbl = {}, $ifh);
  return ({}) if defined($ver) && $ver gt $tbl->{'_bld'};
  return (_check_rda($slf, $tbl), $dat, $tbl->{'_bld'});
}

sub _get_file
{ my ($drv, $flg, $dir, $nam, $grp, $sub, $mod) = @_;
  my ($err, $rsp);

  $rsp = $drv->exec_request(RDA::Object::Message->new('AGENT.GET',
    group => $grp,
    path  => "$sub/$nam",
    ));
  if ($err = $rsp->is_error)
  { return unless $flg;
    die get_string('ERR_GET_FILE', "[$grp]$sub/$nam", $err);
  }
  return _save_file($rsp->{'dat'}, $dir, $nam, $mod, $rsp->get_first('dos'));
}

sub _save_file
{ my ($dat, $dir, $nam, $mod, $dos) = @_;
  my ($eol, $lgt, $max, $off, $ofh, $pth);

  $ofh = IO::File->new;
  $pth = RDA::Object::Rda->cat_file($dir, $nam);
  $ofh->open($pth, $CREATE, $mod ? $FIL_PERMS : $EXE_PERMS)
    or die get_string('ERR_CREATE', $pth, $!);
  binmode($ofh);
  if (ref($dat) eq 'ARRAY')
  { $eol = $dos ? "\015\012" : "\012";
    foreach my $lin (@{$dat})
    { print {$ofh} $lin.$eol;
    }
  }
  else
  { $max = length($dat);
    $off = 0;
    while ($max)
    { $lgt = $ofh->syswrite($dat, $max, $off)
        or die get_string('ERR_WRITE', $pth, $!);
      $max -= $lgt;
      $off += $lgt;
    }
  }
  $ofh->close or die get_string('ERR_CLOSE', $pth, $!);
  return;
}

sub _set_engine
{ my ($slf) = @_;
  my ($ofh, $pth);

  if (-d ($pth = $slf->{'_cfg'}->get_dir('D_RDA', 'engine')) &&
    ! -f ($pth = RDA::Object::Rda->cat_file($pth, 'rda.cfg')))
  { $ofh = IO::File->new;
    if ($ofh->open($pth, $CREATE, $FIL_PERMS))
    { print {$ofh} qq{RDA_ENG=""\n};
      print {$ofh} qq{RDA_EXE="rda.exe"\n};
      print {$ofh} qq{D_RDA=".."\n};
      $ofh->close;
    }
  }
  return;
}

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

  exec($req->get_value('next'));
  die get_string('ERR_SWITCH', $!);
}

=head2 AGENT.CHECK - Installation check command

This command checks the RDA installation and reports all missing and altered
files.

=cut

sub _do_check  ## no critic (Complex)
{ my ($slf, $req) = @_;
  my ($cfg, $chk, $dsp, $fil, $flg, $ifh, $pth, $ptr, $sep, $sta, $top, $win,
      @err);

  # Load the check sum file if needed
  $cfg = $slf->{'_cfg'};
  $dsp = $slf->{'_dsp'};
  unless (exists($slf->{'_chk'}))
  { $dsp->dsp_line(get_string('V_ListLoad')) if $dsp;
    $ifh = IO::File->new;
    $fil = $cfg->get_file('D_RDA_REL', 'rda.dat');
    return $req->error('NoFile', $!) unless $ifh->open("<$fil");
    return $req->error('BadFile')    if _load_chksum($slf, $slf, $ifh);
  }

  # Check the RDA installation
  $win = $cfg->is_windows;
  foreach my $grp (sort keys(%{$slf->{'_chk'}}))
  { next unless ($top = $cfg->get_group($grp));
    foreach my $dir (sort keys(%{$chk = $slf->{'_chk'}->{$grp}}))
    { $pth = ($dir eq q{.})
        ? $top
        : $cfg->cat_dir($top, split(/\//, $dir));

      # Check the directory content
      $dsp->dsp_line(get_string('V_DirCheck', "\[$grp\] $dir")) if $dsp;
      if (opendir(DIR, $pth))
      { foreach my $nam (sort readdir(DIR))
        { next unless -f ($fil = $cfg->cat_file($pth, $nam))
            && exists($chk->{$dir}->{$nam});
          $ptr = $chk->{$dir}->{$nam};
          $ptr->[2] = 1;
          $sta = q{};
          $sep = get_string('File', $fil);
          if (-r $fil)
          { unless ($ptr->[0] == _get_chksum($fil))
            { $sta .= get_string('Altered', $sep);
              $sep = q{,};
            }
            unless ($ptr->[1] || $win || -x $fil)
            { $sta .= get_string('NotExec', $sep);
              $sep = q{,};
            }
          }
          else
          { $sta = get_string('NotRead', $sep);
          }
          push(@err, $sta) if $sta;
        }
        closedir(DIR);

        # Identify missing files
        foreach my $nam (sort keys(%{$chk->{$dir}}))
        { push(@err, get_string('NoFile', $cfg->cat_file($pth, $nam)))
            unless $chk->{$dir}->{$nam}->[2];
        }
      }
      else
      { # Check if that directory contains any mandatory file
        foreach my $ptr (values(%{$chk->{$dir}}))
        { next if $ptr->[2];
          push(@err, get_string('NoAccess', $pth));
          last;
        }
      }
    }
  }
  $chk = scalar @err;

  # Indicate the check result
  if ($dsp)
  { $dsp->dsp_line(qq{\n});
    $dsp->dsp_line(get_string('V_NoErrors')) unless $chk;
  }
  return $chk
    ? $req->error('Check', get_string('ERR_CHECK', $chk), @err)
    : $req->new('OK.Check');
}

=head2 AGENT.EXIT - Exit command

This command initiates an agent shutdown. When a dynamic work directory has
been used, a cleaning or removal action can also be specified. It supports the
following attribute:

=over 8

=item B<  work>

Specifies optional work directory action (C<clean> or C<remove>).

=back

=cut

sub _do_exit
{ my ($slf, $req) = @_;
  my ($cfg, $cmd);

  # Cleanup the work directory when requested
  eval {
    $cfg = $slf->{'_cfg'};
    if ($cfg->get_info('dyn'))
    { $cmd = $req->get_first('work', q{});
      if ($cmd eq 'clean')
      { $cfg->clean_group('D_CWD');
      }
      elsif ($cmd eq 'remove')
      { chdir(q{/});
        $cfg->delete_group('D_CWD');
      }
    }
    };

  # Return the completion status
  return $req->reply($@, 'Exit');
}

=head2 AGENT.EXTRA - Extra element detect command

This command checks the RDA installation and reports all extra elements found
in it.

=cut

sub _do_extra  ## no critic (Complex)
{ my ($slf, $req) = @_;
  my ($chk, $cfg, $dsp, $fil, $ifh, $pth, $top, @err, %dir, %fil);

  # Ignore some structural elements
  $cfg = $slf->{'_cfg'};
  $dsp = $slf->{'_dsp'};
  foreach my $grp (keys(%{$chk = $tb_chk{'dir'}}))
  { foreach my $nam (@{$chk->{$grp}})
    { $dir{$cfg->get_dir($grp, $nam)} = 0;
    }
  }
  foreach my $grp (keys(%{$chk = $tb_chk{'fil'}}))
  { foreach my $nam (@{$chk->{$grp}})
    { $fil{$cfg->get_file($grp, $nam)} = 0;
    }
  }

  # Load the check sum file if needed
  unless (exists($slf->{'_chk'}))
  { $dsp->dsp_line(get_string('V_ListLoad')) if $dsp;
    $ifh = IO::File->new;
    $fil = $cfg->get_file('D_RDA_REL', 'rda.dat');
    return $req->error('NoFile', $!) unless $ifh->open("<$fil");
    return $req->error('BadFile')    if _load_chksum($slf, $slf, $ifh);
  }

  # Check the RDA installation
  foreach my $grp (sort keys(%{$slf->{'_chk'}}))
  { next unless ($top = $cfg->get_group($grp));
    $dir{$top} = 0;
    foreach my $dir (sort keys(%{$chk = $slf->{'_chk'}->{$grp}}))
    { $pth = ($dir eq q{.})
        ? $top
        : $cfg->cat_dir($top, split(/\//, $dir));

      # Check the directory content
      $dsp->dsp_line(get_string('V_DirCheck', "\[$grp\] $dir")) if $dsp;
      if (opendir(DIR, $pth))
      { $dir{$pth} = 0;

        foreach my $nam (sort readdir(DIR))
        { next if $nam =~ m/^(\.+|obsolete\.txt)$/;
          $fil = $cfg->cat_file($pth, $nam);
          if (-f $fil)
          { if (exists($chk->{$dir}->{$nam}))
            { $fil{$fil} = 0;
            }
            else
            { $fil{$fil} = 1 unless exists($fil{$fil});
            }
          }
          elsif (-d $fil)
          { $dir{$fil} = 1 unless exists($dir{$fil})
              || ($grp eq 'D_RDA' && $nam =~ m/^[a-z]{2}-[A-Z]{2}$/);
          }
          else
          { $fil{$fil} = 1 unless exists($fil{$fil});
          }
        }
        closedir(DIR);
      }
      else
      { $dir{$pth} = -1 unless exists($dir{$pth});
      }
    }
  }
  $chk = @err = (
    (map {get_string('NoAccess', $_)}  sort grep{$dir{$_} < 0} keys(%dir)),
    (map {get_string('ExtraDir', $_)}  sort grep{$dir{$_} > 0} keys(%dir)),
    (map {get_string('ExtraFile', $_)} sort grep{$fil{$_}}     keys(%fil)),
    );

  # Indicate the check result
  if ($dsp)
  { $dsp->dsp_line(qq{\n});
    $dsp->dsp_line(get_string('V_NoExtras')) unless $chk;
  }
  return $chk
    ? $req->error('Check', get_string('ERR_EXTRA', $chk), @err)
    : $req->new('OK.Check');
}

=head2 AGENT.GET - Get file command

This command gets a file. Relative file paths are taken from the specified
directory group when the group is found. Otherwise, they are taken from the
current directory. C</> are used when directories are included in the path. It
supports the following attributes:

=over 9

=item B<  group>

Specifies the directory group.

=item B<  lines>

When true, handles the file by lines instead of by data blocks.

=item B<  path>

Specifies the file path.

=back

=cut

sub _do_get
{ my ($slf, $req) = @_;
  my ($dat, $dir, $ifh, $lin, $pth, @att);

  return $req->new('ERROR.NoPath') unless ($pth = $req->get_first('path'));
  $dir = $slf->{'_cfg'}->get_group($req->get_first('group', q{}));
  $pth = RDA::Object::Rda->cat_file($dir, split(/\//, $pth))
    if !RDA::Object::Rda->is_absolute($pth) && defined($dir);

  if ($lin = $req->get_first('lines'))
  { $ifh = IO::File->new;
    if ($ifh->open("<$pth"))
    { $ifh->read($dat, 1024);
      $ifh->close;
      push(@att, dos => 1) if defined($dat) && $dat =~ m/\015\012/o;
    }
  }

  return
    (! -f $pth) ? $req->new('ERROR.NoFile') :
    (! -r $pth) ? $req->new('ERROR.NoAccess') :
                  $req->new('OK.Get', @att)->add_file($pth, $lin);
}

=head2 AGENT.GET_USAGE - Usage transfer command

This command consolidates sub agent usage and returns it. It supports the
following attribute:

=over 12

=item B<  no_usage>

When true, suppresses the C<usage> attribute.

=back

=cut

sub _do_usage
{ my ($slf, $req) = @_;
  my ($agt, $cmd, $ctl, $def, $flg, $top);

  # Determine if the usage atribute must be suppressed
  $flg = $req->get_first('no_usage');

  # Consolidate the usage from sub agents
  $top = $slf->{'_agt'};
  $ctl = $top->get_info('ctl');
  foreach my $oid (keys(%{$ctl}))
  { $def = $ctl->{$oid};
    next unless exists($def->{'-agt'});
    $agt = $def->{'-agt'};
    if (defined($cmd = $agt->get_info('upd')))
    { eval {$top->submit($oid, $cmd, no_usage => 1)->is_error($req)};
      $req->add_error($@) if $@;
    }
    $agt->merge_usage;
  }

  # Report the usage
  return $top->add_usage($req->new('OK.Usage'), $flg ? undef : 'usage');
}

=head2 AGENT.INFO - Information transfer command

This command transfers usage information between agents.

=cut

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

  $slf->{'_agt'}->extract_usage($req);
  return $req->new('OK.Loaded');
}

=head2 AGENT.INIT - Initialization command

This command initializes the agent. It supports the following attributes:

=over 12

=item B<  edit>

Specifies edit directives.

=item B<  no_usage>

When true, disables local usage storage.

=item B<  work>

Specifies the work directory.

=back


=cut

sub _do_init
{ my ($slf, $req) = @_;
  my ($agt, $cfg, $edt, $ifh, $key, $val, @edt, @inp);

  $agt = $slf->{'_agt'};
  $cfg = $agt->get_config;
  $agt->set_info('use') if $req->get_value('no_usage');

  # Treat the edit directives
  if (@edt = $req->get_value('edit'))
  { $edt = $agt->get_info('edt', {});
    foreach my $itm (@edt)
    { _edit($edt, $cfg, $itm);
    }
    $agt->set_info('edt', $edt);
  }

  # Treat the input directives
  if ($ifh = RDA::Handle::Data->new($req))
  { while (<$ifh>)
    { last if m/^#EOF\b/;
      push(@inp, $_);
    }
    $ifh->close;
    $agt->set_info('inp', [@inp]) if @inp;
  }

  # Set the work directory and report results
  eval {$cfg->set_work($agt, $req->get_first('work'))};
  return $@
    ? $req->error('BadWork', $@)
    : $req->new('OK.Started', family => $cfg->get_family);
}

# Extract the information from the edit directives
sub _edit
{ my ($tbl, $cfg, $str) = @_;
  my ($key, $val);

  $str =~ s/^\s+//;
  for (;;)  ## no critic (Loop)
  { # Extract a directive
    unless ($str =~ s/^((\w+\/)?(\w+\.)*\w+)\s*=\s*//)
    { next if $str =~ s/^(.*?),\s*//;
      return;
    }
    $key = uc($1);  ## no critic (Capture)
    $val = eval{_decode_value(\$str)};

    # Add the contribution
    unless ($@)
    { if ($key =~ s/^CFG\///)
      { _edit_config($cfg, $key, $val);
      }
      elsif ($key !~ m/^(?:ENV|PRF|RUN)\//)
      { $tbl->{$key} = $val;
      }
    }

    # Check for another directive
    $str =~ s/^[^,]*//;
    return unless $str =~ s/^,\s*//;
  }
}

sub _decode_array
{ my ($str) = @_;
  my ($val);

  $val = [];
  unless ($$str =~ m/^\051/)
  { for (;;)  ## no critic (Loop)
    { push(@{$val}, _decode_value($str));
      last unless $$str =~ s/^,\s*//;
    }
  }
  die get_string('NO_PARENTHESIS') unless $$str =~ s/^\051\s*//;
  return $val;
}

sub _decode_hash
{ my ($str) = @_;
  my ($key, $val);

  $val = {};
  unless ($$str =~ m/^\175/)
  { for (;;)  ## no critic (Loop)
    { $key = _decode_scalar($str);
      die get_string('NO_COMMA') unless $$str =~ s/^\s*(,|=>)\s*//;
      $val->{$key} = _decode_value($str);
      last unless $$str =~ s/^,\s*//;
    }
  }
  die get_string('NO_BRACE') unless $$str =~ s/^\175\s*//;
  return $val;
}

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

  return q{} unless $$str =~ s{^(.*?)\s*(\z|=>?|[,\050\051\173\175])}{$2};
  return RDA::Object::decode($1) unless $2 eq q{=};
  $$str = q{,}.$1.$$str;
  die get_string('NO_END');
}

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

  return ($$str =~ s/^\050\s*//) ? _decode_array($str) :
         ($$str =~ s/^\173\s*//) ? _decode_hash($str) :
                                   _decode_scalar($str);
}
sub _edit_config
{ my ($cfg, $key, $val) = @_;
  my ($ref);

  # Eliminated nested structure
  $ref = ref($val);
  return if $ref eq 'HASH';
  $val = [grep {!ref($_)} @{$val}] if $ref;

  # Validate the value
  if ($key =~ m/^(D_[A-Z]\w*[A-Z])$/)
  { return if $ref && $key =~ m/^D_(CWD|RDA(_\w+)?)$/;
    $cfg->{$key} = $ref
      ? [map {$cfg->cat_dir($_)} @{$val}]
      : $cfg->cat_dir($val);
  }
  elsif ($key =~ m/^(F_[A-Z]\w*[A-Z])$/)
  { $cfg->{$key} = $ref
      ? [map {$cfg->cat_file($_)} @{$val}]
      : $cfg->cat_file($val);
  }
  elsif ($key =~ m/^(N_[A-Z]\w*[A-Z])$/)
  { if ($ref)
    { $cfg->{$key} = [grep {m/^\d+$/} @{$val}];
    }
    elsif ($val =~ m/^\d+$/)
    { $cfg->{$key} = $val;
    }
  }
  elsif ($key =~ m/^(R_[A-Z]\w*[A-Z])$/)
  { if ($ref)
    { $cfg->{$key} = [grep {m/^[-+]?(\d+(\.\d*)?|\.\d+)$/} @{$val}];
    }
    elsif ($val =~ m/^[-+]?(\d+(\.\d*)?|\.\d+)$/)
    { $cfg->{$key} = $val;
    }
  }
  elsif ($key =~ m/^([A-Z]_[A-Z]\w*[A-Z])$/)
  { $cfg->{$key} = $val;
  }
  return;
}

=head2 AGENT.SLEEP - Sleep command

This command suspends the program execution for the specified duration. It
supports the following attribute:

=over 14

=item B<  duration>

Specifies the sleep duration (in seconds).

=back

=cut

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

  my $dur = $req->get_first('duration');
  sleep($dur) if defined($dur) && $dur > 0;
  return $req->new('OK.Continue');
}

=head2 AGENT.START - Agent start command

This command starts a new agent. it supports the following common attributes:

=over 12

=item B<  agent>

Specifies the object identifier of the new agent.

=item B<  force>

Indicates if the command can restart an existing agent.

=item B<  no_proxy>

When true, does not check proxy to determine agent existence.

=item B<  ttl>

When negative, propagates its definition to sub agents.

=item B<  work>

Specifies the agent work directory. The attribute is handled at process start
and removed from the message passed to the initialization command. However it
adds an C<edit> attribute to construct commands.

=back

=cut

sub _do_start
{ my ($slf, $req) = @_;
  my ($agt, $flg, $oid, $sta, $ttl, $typ);

  # Validate the parameters
  $agt = $slf->{'_agt'};
  $flg = $req->get_first('force');
  $ttl = ($req->get_first('ttl', q{}) =~ m/^\s*(-\d+)\s*$/) ? $1 : 0;
  $typ = $req->get_first('type', 'LOC');
  return $req->new('INFO.NoOid')
    unless ($oid = $req->get_first(['agent','oid']));

  # Check for current agent
  if ($agt->is_local($oid, $req->get_first('no_proxy')))
  { return $req->new('INFO.Existing') unless $flg;
    $sta = 'Restarted';
  }
  else
  { $sta = 'Started';
  }

  # Start the agent
  eval {$agt->add_agent($oid, $typ, $req->get_info('att'), $ttl)};
  return $req->reply($@, $sta);
}

=head2 AGENT.STOP - Agent stop command

This command stops an agent. When a dynamic work directory has been used by
that agent, a cleaning or removal action can also be specified. It supports
the following attributes:

=over 9

=item B<  agent>

Specifies the object identifier of the agent to stop.

=item B<  work>

Specifies optional work directory action (C<clean>, C<keep>, or C<remove>).

=back

=cut

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

  eval {
    $slf->{'_agt'}->delete_agent($oid, $req->get_first('work', 'keep'))
      if ($oid = $req->get_first(['agent','oid']));
    };
  return $req->reply($@, 'Stopped');
}

=head2 AGENT.SUBMIT - Request delegation command

This command delegates request submission to the specified agent. It supports
the following attributes:

=over 11

=item B<  agent>

Specifies the agent object identifier.

=item B<  command>

Specifies the command to execute.

=back

To protect attributes from being interpreted, you can prefix the attribute
names with the object identifier of the target agent.

=cut

sub _do_submit
{ my ($slf, $req) = @_;
  my ($alt, $cmd, $cur, $nod, $rsp);

  # Get the parameters
  return $req->new('ERROR.MissingCommand')
    unless ($cmd = $req->set_value('command'));
  $cur = $slf->{'_agt'}->get_info('nod');
  $nod = $req->set_value('agent');

  # Switch execution context
  $req->set_info('msg', $cmd);
  foreach my $key ($req->grep(qr{^$nod\_}))
  { $alt = $key;
    $alt =~ s{^$nod\_}{};
    $req->set_value($alt, $req->set_value($key)) if $alt;
  }

  # Submit the request
  eval {$rsp = $slf->{'_agt'}->submit(($nod eq $cur) ? q{.} : $nod,
    $req)->pop_id};
  $rsp = $req->error('Submit', $@) if $@;

  # Restore the original context and return the result
  return $rsp;
}

=head2 AGENT.VALIDATE - File validation command

This command validates that the attached file is not altered. It supports the
following attribute:

=for stopwords checksum

=over 12

=item B<  checksum>

Specifies the file check sum.

=back

=cut

sub _do_validate
{ my ($slf, $req) = @_;
  my ($dat, $sum);

  # Validate the arguments
  return $req->new('ERROR.NoFile')
    unless defined($dat = $req->get_data);
  return $req->new('ERROR.NoChecksum')
    unless defined($sum = $req->get_first('checksum'));

  # Compare the check sums
  return $req->new((_calc_chksum(RDA::Handle::Memory->new($dat)) == $sum)
    ? 'OK.Validate'
    : 'ERROR.CheckSum');
}

sub _calc_chksum
{ my ($ifh) = @_;
  my $sum = 0;

  binmode($ifh);
  while (<$ifh>)
  { s/\$(Header|Id|Revision):\s.*?\$/\$$1\$/;
    $sum += unpack('%32C*', $_);
  }
  $ifh->close;
  return $sum % 65535;
}

=head2 AGENT.VERIFY - Check sum file verification command

This command loads and verifies the attached check sum file. When no check sum
file is provided as data, the local check sum file is used. On successful
completion, it also returns the current RDA version and build.

=cut

sub _do_verify
{ my ($slf, $req) = @_;
  my ($dat, $fil, $flg, $ifh, $tbl);

  if (defined($dat = $req->get_data))
  { $ifh = RDA::Handle::Memory->new($dat);
    $tbl = $slf;
  }
  else
  { $ifh = IO::File->new;
    $fil = $slf->{'_cfg'}->get_file('D_RDA_REL', 'rda.dat');
    return $req->new('ERROR.NoFile') unless $ifh->open("<$fil");
    $tbl = {};
  }
  return _load_chksum($slf, $tbl, $ifh)
    ? $req->new('ERROR.CheckSum')
    : $req->new('OK.Verify', version => $tbl->{'_ver'},
                             build   => $tbl->{'_bld'});
}

sub _load_chksum
{ my ($slf, $tbl, $ifh) = @_;
  my ($dir, $grp, $lin, $nam, $sum, $tot, $typ, $vms, $win);

  # Initialization
  $vms = $slf->{'_cfg'}->is_vms;
  $win = $slf->{'_cfg'}->is_windows;
  $tbl->{'_chk'} = {};
  $tbl->{'_ver'} = '0.0';
  $tbl->{'_bld'} = '00000000';

  # Load the file list
  $tot = 0;
  $grp = q{};
  while (defined($lin = $ifh->getline))
  { $lin =~ s/[\n\r\s]+$//;
    if ($lin =~ m/^\[(\w+)\]$/)
    { $tbl->{'_chk'}->{$1} = $grp = {};
    }
    elsif ($lin =~ m/^#/)
    { ($tbl->{'_ver'}, $tbl->{'_bld'}) = ($1, $2)
        if $lin =~ m/^#\s*\$Build:\s*(\d+\.\d+)\-(\d{6}\w*)\s*\$/;
      next;
    }
    else
    { ($typ, $dir, $sum, $nam) = split(/\s+/, $lin, 4);
      next unless $typ && $dir && $nam;
      $tot += $sum;
      unless ($typ eq q{-})
      { $grp->{$dir}->{$nam} =
          [$sum, $win || lc($typ) eq 'f', $typ eq lc($typ)];
        $grp->{$dir}->{lc($nam)} = $grp->{$dir}->{$nam} if $vms;
      }
    }
  }
  $ifh->close;
  return $tot % 65535;
}

=head2 AGENT.VERSION - RDA version command

This command returns the current RDA version and build.

=cut

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

  # Load the check sum file if needed
  unless (exists($slf->{'_chk'}))
  { $ifh = IO::File->new;
    $fil = $slf->{'_cfg'}->get_file('D_RDA_REL', 'rda.dat');
    return $req->new('ERROR.NoFile') unless $ifh->open("<$fil");
    return $req->new('ERROR.BadFile') if _load_chksum($slf, $slf, $ifh);
  }

  # Return the build and version
  return $req->new('OK.Version', version => $slf->{'_ver'},
                                 build   => $slf->{'_bld'});
}

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::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