# EXTRA.pm: Command Library to Manage User Defined Data Collection.

package RDA::Request::EXTRA;

# $Id: EXTRA.pm,v 1.15 2015/05/09 14:47:00 RDA Exp $
# ARCS: $Header: /home/cvs/cvs/RDA_8/src/scripting/lib/RDA/Request/EXTRA.pm,v 1.15 2015/05/09 14:47:00 RDA Exp $
#
# Change History
# 20150507  MSC  Improve the documentation.

=head1 NAME

RDA::Request::EXTRA - Command Library to Manage User Defined Data Collection.

=head1 SYNOPSIS

 require RDA::Request::EXTRA;

=head1 DESCRIPTION

The objects of the C<RDA::Request::EXTRA> class are used to manage User
Defined Data Collections.

The following methods are available:

=cut

use strict;

BEGIN
{ use Exporter;
  use RDA::Text qw(get_string);
  use RDA::Agent;
  use RDA::Object;
  use RDA::Object::Message;
  use RDA::Object::Rda;
}

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

# Define the global private constants
my $SET = 'SETUP.RDA.EXTRA';

# Define the global private variables
my @tb_typ = qw(T_CMD T_DAT T_FIL T_DIR T_SMP);
my %tb_abr = (
  T_CMD => 'RDA_EXTRA_',
  T_DAT => 'RDA_EXTRA_',
  T_DIR => 'RDA_EXTRA_',
  T_FIL => 'RDA_EXTRA_',
  T_SMP => 'SAMPLE_EXTRA_',
  );
my %tb_cmd = (
  'EXTRA.ADD_CMD' => \&_do_add_cmd,
  'EXTRA.ADD_DAT' => \&_do_add_dat,
  'EXTRA.ADD_DIR' => \&_do_add_dir,
  'EXTRA.ADD_FIL' => \&_do_add_fil,
  'EXTRA.ADD_SMP' => \&_do_add_smp,
  'EXTRA.DELETE'  => \&_do_delete,
  'EXTRA.EXPORT'  => \&_do_export,
  'EXTRA.LIST'    => \&_do_list,
  'EXTRA.SAVE'    => \&_do_save,
  );
my %tb_def = (
  T_CMD => 'RDA.EXTRA.T_CMD',
  T_DAT => 'RDA.EXTRA.T_DAT',
  T_DIR => 'RDA.EXTRA.T_DIR',
  T_FIL => 'RDA.EXTRA.T_FIL',
  T_SMP => 'SAMPLE.EXTRA.T_SMP',
  );
my %tb_mod = (
  T_CMD => 'RDA:DCextra',
  T_DAT => 'RDA:DCextra',
  T_DIR => 'RDA:DCextra',
  T_FIL => 'RDA:DCextra',
  T_SMP => 'SAMPLE:DCextra',
  );

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

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

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

C<RDA::Request::EXTRA> 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<'_cfg'> > Reference to the RDA software configuration

=item S<  B<'_col'> > Reference to the collector object

=item S<  B<'_del'> > Report deletion indicator

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

=item S<  B<'_set'> > Reference to the setup item

=item S<  B<'_tmp'> > Change hash

=back

Internal keys are prefixed by an underscore.

=cut

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

  # Create the library object and return the object reference
  $col = $agt->get_collector;
  return bless {
    _agt => $agt,
    _cfg => $agt->get_config,
    _col => $col,
    _del => 0,
    _dsp => $agt->is_verbose,
    _set => $col->get_info('set'),
    }, 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 EXTRA COMMANDS

=head2 EXTRA.ADD_CMD - Command add command

This command adds an operating system command to collect information. It
supports the following attributes:

=over 11

=item B<  command>

Specifies the operating system command to execute.

=item B<  save>

When true, applies the changes to the result set definition.

=item B<  title>

Specifies the report title.

=back

=cut

sub _do_add_cmd
{ my ($slf, $req) = @_;
  my ($cnt, $ttl, @cmd);

  # Validate the parameters
  return $req->error('NoTitle')
    unless ($ttl = $req->get_first('title'));
  return $req->error('NoCommand')
    unless (@cmd = grep {defined($_)} $req->get_value('command'))
    && length($cmd[0]);

  # Perform the request
  eval {
    $slf->{'_dsp'}->dsp_line(get_string('V_AddCmd')) if $slf->{'_dsp'};
    push(@{_get_array($slf, 'T_CMD')}, [$ttl, @cmd]);
    $cnt = _save($slf) if $req->get_first('save');
    };

  # Indicate the completion status
  return $req->reply($@, 'AddCommand', setup => $cnt);
}

=head2 EXTRA.ADD_DAT - Data file add command

This command adds the specified data files to the list of extra elements to
collect. It supports the following attributes:

=over 9

=item B<  files>

Lists binary files to add.

=item B<  save>

When true, applies the changes to the result set definition.

=back

=cut

sub _do_add_dat
{ my ($slf, $req) = @_;
  my ($cnt, @fil);

  # Validate the parameters
  return $req->error('NoFiles')
    unless (@fil = grep {defined($_) && length($_)} $req->get_value('files'));

  # Perform the request
  eval {
    $slf->{'_dsp'}->dsp_line(get_string('V_AddDat')) if $slf->{'_dsp'};
    push(@{_get_array($slf, 'T_DAT')}, @fil);
    $cnt = _save($slf) if $req->get_first('save');
    };

  # Indicate the completion status
  return $req->reply($@, 'AddData', setup => $cnt);
}

=head2 EXTRA.ADD_DIR - Directory add command

This command adds a directory to analyze. RDA will collect from it all files
matching the associated pattern and search options. It supports the following
attributes:

=over 13

=item B<  directory>

Specifies the directory to analyze.

=item B<  options>

Specifies the search options.

=item B<  pattern>

Specifies a Perl regular expression used for selecting or rejecting files.

=item B<  save>

When true, applies the changes to the result set definition.

=back

Valid options are as follows:

=over 7

=item B<  'i' >

Ignores case distinctions in both the pattern and the results.

=item B<  'p' >

Converts the paths to a full path (implied).

=item B<  'r' >

Searches files recursively under each subdirectory. To avoid loops in the
directory structure, the recursion level is limited to 8.

=item B<  'v' >

Inverts the sense of matching to select non-matching files.

=back

=cut

sub _do_add_dir
{ my ($slf, $req) = @_;
  my ($cnt, $dir, $opt);

  # Validate the parameters
  return $req->error('NoDirectory')
    unless defined($dir = $req->get_first('directory')) && length($dir);
  $opt = $req->get_first('options', q{});
  $opt =~ s/p//g;

  # Perform the request
  eval {
    $slf->{'_dsp'}->dsp_line(get_string('V_AddDir')) if $slf->{'_dsp'};
    push(@{_get_array($slf, 'T_DIR')},
      [$dir, $req->get_first('pattern', q{.}), 'p'.$opt]);
    $cnt = _save($slf) if $req->get_first('save');
    };

  # Indicate the completion status
  return $req->reply($@, 'AddDir', setup => $cnt);
}

=head2 EXTRA.ADD_FIL - File add command

This command adds files to the list of extra elements to collect. It support
the following attributes:

=over 9

=item B<  files>

Lists files to add.

=item B<  save>

When true, applies the changes to the result set definition.

=back

=cut

sub _do_add_fil
{ my ($slf, $req) = @_;
  my ($cnt, @fil);

  # Validate the parameters
  return $req->error('NoFiles')
    unless (@fil = grep {defined($_) && length($_)} $req->get_value('files'));

  # Perform the request
  eval {
    $slf->{'_dsp'}->dsp_line(get_string('V_AddFil')) if $slf->{'_dsp'};
    push(@{_get_array($slf, 'T_FIL')}, @fil);
    $cnt = _save($slf) if $req->get_first('save');
    };

  # Indicate the completion status
  return $req->reply($@, 'AddFiles', setup => $cnt);
}

=head2 EXTRA.ADD_SMP - Sample add command

This command adds an operating system command to sample. It supports the
following attributes:

=over 11

=item B<  command>

Specifies the operating system command to execute.

=item B<  name>

Specifies the name of the report used to accumulate the corresponding
samples. It must start with a letter.

=item B<  save>

When true, applies the changes to the result set definition.

=back

=cut

sub _do_add_smp
{ my ($slf, $req) = @_;
  my ($cnt, $nam, @cmd);

  # Validate the parameters
  return $req->error('NoName')
    unless ($nam = $req->get_first('name', q{})) =~ m/^[A-Za-z]/;
  return $req->error('NoCommand')
    unless (@cmd = grep {defined($_)} $req->get_value('command'))
    && length($cmd[0]);

  # Perform the request
  eval {
    $slf->{'_dsp'}->dsp_line(get_string('V_AddSmp')) if $slf->{'_dsp'};
    push(@{_get_array($slf, 'T_SMP')}, [$nam, @cmd]);
    $cnt = _save($slf) if $req->get_first('save');
    };

  # Indicate the completion status
  return $req->reply($@, 'AddSample', setup => $cnt);
}

=head2 EXTRA.DELETE - Delete command

This command deletes files or directories from the list of extra elements to
collect. They are referenced by their position in the list.

=over 11

=item B<  all>

When true, deletes all elements.

=item B<  offsets>

Specifies the offsets of the elements to suppress. RDA discards any offset that
is not integer number greater than zero or that is not an offset range, where
two offsets are separated by a dash.

=item B<  save>

When true, applies the changes to the result set definition.

=back

=cut

sub _do_delete
{ my ($slf, $req) = @_;
  my ($cnt, $off, $tmp, @tbl, %skp);

  # Perform the request
  eval {
    $slf->{'_dsp'}->dsp_line(get_string('V_Delete')) if $slf->{'_dsp'};
    $slf->{'_del'} = 1;
    $tmp = _load($slf);
    if ($req->get_first('all'))
    { foreach my $typ (keys(%{$tmp}))
      { $tmp->{$typ} = [];
      }
    }
    else
    { $off = 0;
      %skp = map {$_ => 1} map {_get_offsets($_)} $req->get_value('offsets');
      foreach my $typ (@tb_typ)
      { @tbl = ();
        foreach my $val (@{$tmp->{$typ}})
        { push(@tbl, $val) unless exists($skp{++$off});
        }
        $tmp->{$typ} = [@tbl];
      }
    }

    # Set up the module
    $cnt = _save($slf) if $req->get_first('save');
    };

  # Indicate the completion status
  return $req->reply($@, 'Delete', setup => $cnt);
}

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

  return () unless $str =~ m/^(\d+)(-(\d+))?$/;
  return ($1) unless $2;
  return ($1 .. $3);
}

=head2 EXTRA.EXPORT - Export command

This command exports the extra collection settings. It generates commands to
re-create them.

=cut

sub _do_export
{ my ($slf, $req) = @_;
  my ($buf, $def, $exe, $lgt, $lin, $rem, $sep, @rda, @tbl);

  eval {
    @rda = $slf->{'_cfg'}->get_value('T_SELF');

    if (RDA::Object::Rda->is_windows)
    { $buf = qq{\@echo off\n};
      $exe = q{};
      $lin = q{REM }.(q{#} x 75).qq{\n};
      $rem = q{REM };
      $sep = q{};
    }
    elsif (RDA::Object::Rda->is_vms)
    { $buf = q{};
      $exe = q{$ };
      $lin = q{$!}.(q{#} x 77).qq{\n};  ## no critic (Interpolation)
      $rem = q{$! };                    ## no critic (Interpolation)
      $sep = q{"};
    }
    else
    { $buf = qq{#!/bin/sh\n};
      $exe = q{};
      $lin = (q{#} x 79).qq{\n};
      $rem = q{# };
      $sep = q{};
    }

    # Delete all existing elements
    $buf .= $lin.$rem.get_string('Clean').qq{\n}.$lin;
    $buf .= $exe.join(q{ }, @rda, qq{$sep-qXExtra$sep delete $sep-a$sep})
      .qq{\n\n};

    # Treat the commands
    if (@tbl = _get_list($slf, 'T_CMD'))
    { $buf .= $lin.$rem.get_string('Commands').qq{\n}.$lin;
      foreach my $rec (@tbl)
      { $buf .= $exe.join(q{ }, @rda, qq{$sep-qXExtra$sep add command},
          map {_exp_str($_)} @{$rec}).qq{\n};
      }
      $buf .= qq{\n};
    }

    # Treat the binary files
    if (@tbl = _get_list($slf, 'T_DAT'))
    { $buf .= $lin.$rem.get_string('Binaries').qq{\n}.$lin;
      foreach my $fil (@tbl)
      { $buf .= $exe.join(q{ }, @rda, qq{$sep-qXExtra$sep add data},
          _exp_str($fil)).qq{\n};
      }
      $buf .= qq{\n};
    }

    # Treat the files
    if (@tbl = _get_list($slf, 'T_FIL'))
    { $buf .= $lin.$rem.get_string('Files').qq{\n}.$lin;
      foreach my $fil (@tbl)
      { $buf .= $exe.join(q{ }, @rda, qq{$sep-qXExtra$sep add file},
          _exp_str($fil)).qq{\n};
      }
      $buf .= qq{\n};
    }

    # Treat the directories
    if (@tbl = _get_list($slf, 'T_DIR'))
    { $buf .= $lin.$rem.get_string('Directories').qq{'\n}.$lin;
      foreach my $rec (@tbl)
      { $buf .= $exe.join(q{ }, @rda, qq{$sep-qXExtra$sep add dir},
          join(q{ }, map {_exp_str($_)} @{$rec})).qq{\n};
      }
      $buf .= qq{\n};
    }

    # Treat the sample commands
    if (@tbl = _get_list($slf, 'T_SMP'))
    { $buf .= $lin.$rem.get_string('Samples').qq{\n}.$lin;
      foreach my $rec (@tbl)
      { $buf .= $exe.join(q{ }, @rda, q{-qXExtra add sample},
          join(q{ }, map {_exp_str($_)} @{$rec})).qq{\n};
      }
      $buf .= qq{\n};
    }

    # Display the export script
    syswrite($slf->{'_agt'}->get_screen, $buf, $lgt) if ($lgt = length($buf));
    };

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

sub _exp_str
{ my ($val) = @_;

  $val =~ s/([^\040-\041\050-\133\135-\176])/sprintf("\\0x\%02X", ord($1))/eg;
  return q{"}.$val.q{"};
}

=head2 EXTRA.LIST - List command

This command lists the extra elements to collect.

=cut

sub _do_list
{ my ($slf, $req) = @_;
  my ($buf, $cnt, $def, $nam, @cmd, @tbl);

  eval {
    $buf = q{};

    # Treat the commands
    if (@tbl = _get_list($slf, 'T_CMD'))
    { $buf .= q{.M 3 '}.get_string('Commands').qq{:'\n};
      foreach my $rec (@tbl)
      { ($nam, @cmd) = @{$rec};
        $buf .= sprintf("%3d.|'%s'|%s\\040\n", ++$cnt, $nam, join(q{ }, @cmd));
      }
      $buf .= qq{\n};
    }

    # Treat the binary files
    if (@tbl = _get_list($slf, 'T_DAT'))
    { $buf .= q{.M 2 '}.get_string('Binaries').qq{:'\n};
      foreach my $fil (@tbl)
      { $buf .= sprintf("%3d.|%s\\040\n", ++$cnt, $fil);
      }
      $buf .= qq{\n};
    }

    # Treat the files
    if (@tbl = _get_list($slf, 'T_FIL'))
    { $buf .= q{.M 2 '}.get_string('Files').qq{:'\n};
      foreach my $fil (@tbl)
      { $buf .= sprintf("%3d.|%s\\040\n", ++$cnt, $fil);
      }
      $buf .= qq{\n};
    }

    # Treat the directories
    if (@tbl = _get_list($slf, 'T_DIR'))
    { $buf .= q{.M 4 '}.get_string('Directories').qq{:'\n};
      foreach my $rec (@tbl)
      { $buf .= sprintf("%3d.|%s|%s|%s\\040\n", ++$cnt, @{$rec});
      }
      $buf .= qq{\n};
    }

    # Treat the sample commands
    if (@tbl = _get_list($slf, 'T_SMP'))
    { $buf .= q{.M 3 '}.get_string('Samples').qq{:'\n};
      foreach my $rec (@tbl)
      { ($nam, @cmd) = @{$rec};
        $buf .= sprintf("%3d.|%s|%s\\040\n", ++$cnt, $nam, join(q{ }, @cmd));
      }
      $buf .= qq{\n};
    }

    # Detect empty report
    $buf = qq{.P\n}.get_string('None').qq{\n} unless $buf;
    };

  # Display the report on successful completion
  $slf->{'_agt'}->submit(q{.},
    RDA::Object::Message->new('DISPLAY.DSP_REPORT')->add_data($buf)) unless $@;

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

=head2 EXTRA.SAVE - Save command

This command saves the pending changes.

=cut

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

  # Perform the request
  $cnt = eval {_save($slf)};

  # Indicate the completion status
  return $req->reply($@, 'Save', setup => $cnt);
}

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

# Get a change array
sub _get_array
{ my ($slf, $typ) = @_;

  return $slf->{'_tmp'}->{$typ}
    if exists($slf->{'_tmp'}) && exists($slf->{'_tmp'}->{$typ});
  return $slf->{'_tmp'}->{$typ} = [$slf->{'_set'}->get_value($tb_def{$typ})];
}

# Get a list
sub _get_list
{ my ($slf, $typ) = @_;

  return @{$slf->{'_tmp'}->{$typ}}
    if exists($slf->{'_tmp'}) && exists($slf->{'_tmp'}->{$typ});
  return ($slf->{'_set'}->get_value($tb_def{$typ}));
}

# Load the whole definition
sub _load
{ my ($slf) = @_;
  my ($def, $set);

  $set = $slf->{'_set'};
  foreach my $typ (@tb_typ)
  { $slf->{'_tmp'}->{$typ} = [$set->get_value($tb_def{$typ})]
      unless exists($slf->{'_tmp'}->{$typ});
  }
  return $slf->{'_tmp'};
}

# Save the definition
sub _save
{ my ($slf) = @_;
  my ($cnt, $col, $def, $set, $tbl, %abr, %mod);

  if (exists($slf->{'_tmp'}))
  { $slf->{'_dsp'}->dsp_line(get_string('V_Save')) if $slf->{'_dsp'};

    # Replicate the changes
    $set = $slf->{'_set'};
    foreach my $typ (keys(%{$tbl = $slf->{'_tmp'}}))
    { $set->set_temp($tb_def{$typ}, $tbl->{$typ});
      $abr{$tb_abr{$typ}} = 1;
      $mod{$tb_mod{$typ}} = 1;
    }

    # Update the module
    $col = $slf->{'_col'};
    $col->add_setup([], 0, 1, keys(%mod));
    $cnt = $col->end_setup(0);
    if ($slf->{'_del'})
    { foreach my $abr (keys(%abr))
      { $col->delete_reports($abr);
      }
      $slf->{'_del'} = 0;
    }
    $col->save;

    # Delete the change hash
    delete($slf->{'_tmp'});
  }
  return $cnt;
}

1;

__END__

=head1 NOTE

Any deletion operation causes the removal of the data previously collected by
the C<RDA.EXTRA> and C<SAMPLE.EXTRA> modules.

=head1 SEE ALSO

L<RDA::Agent|RDA::Agent>,
L<RDA::Object|RDA::Object>,
L<RDA::Object::Collect|RDA::Object::Collect>,
L<RDA::Object::Message|RDA::Object::Message>,
L<RDA::Object::Rda|RDA::Object::Rda>,
L<RDA::Request::DISPLAY|RDA::Request::DISPLAY>,
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