# Library.pm: Class Used for Managing SDCL Libraries

package RDA::Driver::Library;

# $Id: Library.pm,v 1.16 2015/05/08 18:09:24 RDA Exp $
# ARCS: $Header: /home/cvs/cvs/RDA_8/src/scripting/lib/RDA/Driver/Library.pm,v 1.16 2015/05/08 18:09:24 RDA Exp $
#
# Change History
# 20150508  MSC  Improve the documentation.

=head1 NAME

RDA::Driver::Library - Class Used for Managing SDCL Libraries

=head1 SYNOPSIS

 require RDA::Driver::Library;

=head1 DESCRIPTION

The objects of the C<RDA::Driver::Library> class are used to manage Support
Diagnostic Collection Language (SDCL) libraries.

The following methods are available:

=cut

use strict;

BEGIN
{ use Exporter;
  use IO::File;
  use IO::Handle;
  use RDA::Text qw(get_string);
  use RDA::Alarm qw(check_alarm clear_alarm set_alarm);
  use RDA::Handle::Block;
  use RDA::Object;
  use RDA::Object::Buffer;
  use RDA::Object::Rda qw($CREATE $EXE_PERMS $TMP_PERMS);
}

# Define the global public variables
use vars qw($PWF $STRINGS $VERSION $WRK @DELETE @EXPORT_OK @ISA);
$PWF       = 'pwf.txt';
$VERSION   = sprintf('%d.%02d', q$Revision: 1.16 $ =~ /(\d+)\.(\d+)/);
$WRK       = 'fil.txt';
@DELETE    = qw(_blk);
@EXPORT_OK = qw($PWF $WRK
                cnv_command exe_command get_alarm get_command get_output
                gen_command log_timeout);
@ISA       = qw(Exporter);

# Define the global private constants
my $CMD = RDA::Object::Rda->as_bat('cmd');

# Define the global private variables
my @tb_cap = qw(_rel _rst _thr _use);
my %tb_cap = (
  'refresh' => '_col',
  'reload'  => '_rel',
  'rda'     => '_rda',
  'reset'   => '_rst',
  'suspend' => '_sus',
  'thread'  => '_thr',
  'usage'   => '_use',
  );

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

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

The object constructor for the driver associated to the language object. This
method takes the language object reference as an argument.

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

The object constructor for the driver associated to a collector object. This
method takes the collector reference as an argument.

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

The object constructor for the driver associated to a package object.

The following special keys are used:

=over 12

=item S<    B<'_agt'> > Reference to the RDA agent (L)

=item S<    B<'_cap'> > Capability used for refreshing libraries (L)

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

=item S<    B<'_ctl'> > Reference to the control object (L,R)

=item S<    B<'_col'> > Libraries that require collector initialization (L,R)

=item S<    B<'_def'> > Macro definition hash (B,L,R)

=item S<    B<'_lib'> > Macro library hash (B,L,R)

=item S<    B<'_lvl'> > Trace level (L)

=item S<    B<'_par'> > Reference to the parent object (B,R)

=item S<    B<'_rel'> > Libraries to reload after setting changes (L,R)

=item S<    B<'_rst'> > Libraries to reset (L,R)

=item S<    B<'_sus'> > Libraries to suspend (L,R)

=item S<    B<'_thr'> > Libraries that require thread initialization (L,R)

=item S<    B<'_use'> > Libraries that provide usage statistics (L,R)

=back

Internal keys are prefixed by an underscore.

=cut

sub new
{ my ($cls, $ctl) = @_;
  my ($cap, $cfg, $ref, $slf);

  # Create a slave driver object
  if ($ref = ref($cls))
  { $slf = bless {
      _def => {},
      _lib => {},
      _par => $cls,
      }, $ref;

    # Reload the relevant libraries
    if (ref($ctl))
    { $slf->{'_ctl'} = $ctl;
      foreach my $cap (@tb_cap)
      { $slf->{$cap} = {%{$cls->{$cap}}};
      }

      # Reload relevant libraries
      $cap = (defined($cap = $ctl->get_info('cap')) && exists($tb_cap{$cap}))
         ? $tb_cap{$cap}
         : '_col';
      if (exists($cls->{$cap}))
      { foreach my $lib (values(%{$cls->{$cap}}))
        { $lib->new($slf, $ctl);
        }
      }

      # Generate the macro definitions
      _get_macros($slf);
    }
  }
  else
  { my ($skp, @cls);

    # Create a master driver object
    $cfg = $ctl->get_config;
    $slf = bless {
      _agt => $ctl->get_agent,
      _cap => '_col',
      _cfg => $cfg,
      _ctl => $ctl,
      _lib => {},
      _lvl => $ctl->get_level,
      }, $cls;

    # Load the macro libraries
    $slf->{'_agt'}->trace(get_string('Libraries'))
      unless $slf->{'_lvl'} < 20;  ## no critic (Unless)
    $skp = {map {$_ => 1} $cfg->get_obsolete('lib')};
    if (@cls = $cfg->is_compiled('LIB'))
    { foreach my $cls (@cls)
      { next if exists($skp->{$cls});
        eval "require $cls";
        if ($@)
        { $slf->{'_agt'}->add_error($@, get_string('ERR_LIBRARY', $cls));
        }
        else
        { $cls->new($slf, $ctl);
        }
      }
    }
    else
    { _load_libraries($slf, $ctl, $skp, $cfg->get_group('D_RDA_INC'),
        'RDA', 'Library');
    }

    # Generate the macro definitions
    _get_macros($slf);
  }

  # Return the object reference
  return $slf;
}

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

This method deletes an object and all subobjects, thus handling circular
references.

=cut

sub delete_object
{ # Delete the macro libraries
  foreach my $lib (values(%{$_[0]->{'_lib'}}))
  { $lib->[0]->delete_object;
  }

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

=head1 COMMON LIBRARY METHODS

=head2 S<$h-E<gt>resume($bkp)>

This method restores library attributes.

=cut

sub resume
{ return $_[0]->switch({}, $_[1]);
}

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

This method saves library attributes and resets the library. It returns the
resume directives.

=cut

sub suspend
{ my ($bkp, $ref);

  $ref = ref($_[0]);
  $bkp = eval qq{\$$ref\:\:SUSPEND};  ## no critic(Eval);
  return [$_[0], $_[0]->switch({}, $bkp)];
}

=head2 S<$h-E<gt>switch($bkp,$dsc)>

This method switches specified attributes. It returns their previous values.

=cut

sub switch
{ my ($slf, $bkp, $rec, $flg) = @_;

  # Restore saved attributes
  foreach my $key (keys(%{$rec}))
  { $slf->{$key} = $bkp->{$key} if exists($bkp->{$key});
    if (defined($rec->{$key}))
    { $bkp->{$key} = $slf->{$key};
      $slf->{$key} = (ref($rec->{$key}) eq 'CODE')
        ? &{$rec->{$key}}($slf)
        : $rec->{$key};
    }
    else
    { $bkp->{$key} = delete($slf->{$key});
    }
  }

  # Return the value of the modified attributes
  return $bkp;
}

=head1 LIBRARY MANAGEMENT METHODS

=head2 S<$h-E<gt>get_libraries([$cap])>

This method returns the control objects of libraries that have the specified
capability.

=cut

sub get_libraries
{ my ($slf, $cap) = @_;

  if (defined($cap))
  { my ($key);

    return values(%{$slf->{$key}})
      if exists($tb_cap{$cap}) && exists($slf->{$key = $tb_cap{$cap}});
    return ();
  }
  return values(%{$slf->{'_lib'}});
}

=head2 S<$h-E<gt>refresh($collector)>

This method updates the library control objects for a new collector. It returns
a reference to the driver object.

=cut

sub refresh
{ my ($slf, $col) = @_;

  # Refresh macro libraries
  if (exists($slf->{'_cap'}))
  { # Reload relevant libraries
    foreach my $lib (values(%{$slf->{$slf->{'_cap'}}}))
    { $lib->refresh($col);
    }

    # Generate the macro definitions
    _get_macros($slf);
  }

  # Return the object reference
  return $slf;
}

=head2 S<$h-E<gt>register($object,$list[,$cap,...])>

This method registers a list of macros associated with the specified
object. You can specify a list of additional capabilities.

=cut

sub register
{ my ($slf, $obj, $lst, @cap) = @_;
  my ($cls);

  $cls = ref($obj);

  # Delete previous capabilities
  foreach my $key (values(%tb_cap))
  { delete($slf->{$key}->{$cls});
  }

  # Define new capabilities
  foreach my $cap (@cap)
  { $slf->{$tb_cap{$cap}}->{$cls} = $obj if exists($tb_cap{$cap});
  }

  # Store the macro list
  return $slf->{'_lib'}->{$cls} = [$obj, $lst];
}

=head1 MACRO MANAGEMENT METHODS

=head2 S<$h-E<gt>define($name,$definition)>

This method adds a macro definition.

=cut

sub define
{ my ($slf, $nam, $def) = @_;

  return $slf->{'_def'}->{$nam} = $def;
}

=head2 S<$h-E<gt>find_macro($name)>

This method finds the macro and returns its definition. It generates an error
when it does not find the macro definition.

=cut

sub find_macro
{ my ($slf, $nam) = @_;

  while (!exists($slf->{'_def'}->{$nam}))
  { return unless exists($slf->{'_par'});
    $slf = $slf->{'_par'};
  }
  return $slf->{'_def'}->{$nam};
}

=head2 S<$h-E<gt>share($library,$name)>

This method shares a macro definition with the current library.

=cut

sub share
{ my ($slf, $src, $nam) = @_;

  return unless exists($src->{'_def'}->{$nam});
  return $slf->{'_def'}->{$nam} = $src->{'_def'}->{$nam};
}

=head1 COMMON LIBRARY ROUTINES

The common routines use the following library keys:

=over 12

=item S<    B<'err' > > Last command exit code

=item S<    B<'lim' > > Execution time limit (in sec)

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

=item S<    B<'_sys'> > Reference to the system view object

=item S<    B<'_out'> > Number of operating system requests timed out

=item S<    B<'_trc'> > Execution time recording indicator

=item S<    B<'_vms'> > VMS indicator

=item S<    B<'_win'> > Windows indicator

=item S<    B<'_wrk'> > Reference to the work file manager

=back

Internal keys are prefixed by an underscore.

=head2 S<cnv_command($lib,$cmd)>

This routine adapts the command for VMS or Windows.

=cut

sub cnv_command
{ my ($slf, $cmd) = @_;

  return $cmd unless $cmd;
  if ($slf->{'_win'})
  { $cmd =~ s{/dev/null}{NUL}g;
  }
  elsif (RDA::Object::Rda->is_unix || RDA::Object::Rda->is_cygwin)
  { $cmd = qq{exec $cmd};
  }
  elsif ($slf->{'_vms'} && $cmd =~ m/[\<\>\|\&]/ && $cmd !~ m/^PIPE /i)
  { $cmd = qq{PIPE $cmd};
    $cmd =~ s{2>&1}{2>SYS\$OUTPUT}g;
    $cmd =~ s{/dev/null}{NLA0:}g;
  }
  return $cmd;
}

=head2 S<exe_command($fct,$ret,$lib,$ctx,$req,$typ[,$inc[,@arg]])>

This routine execute the commands from the request and processes the result.

=cut

sub exe_command
{ my ($fct, $ret, $slf, $ctx, $cmd, $typ, $inc, @arg) = @_;
  my ($env, $err, $ifh, $pid, $pre, $tmp, @cln);

  $slf->{'err'} = 0;
  ++$slf->{'_req'};

  $ifh = IO::Handle->new;
  if (exists($slf->{'_wrk'}))
  { # When requested, treat the command output through a temporary file
    ($slf->{'err'}, undef, $tmp) = get_output($slf, $ctx, $cmd, $typ, 1);
    if (ref($tmp))
    { &{$fct}($ret, $slf, $ctx, $tmp->get_handle, 0, 0, 0, 0, @arg);
      $slf->{'_wrk'}->clean_work($WRK);
    }
    elsif ($tmp)
    { &{$fct}($ret, $slf, $ctx, $ifh, 0, 0, 0, 0, @arg)
        if open($ifh, q{<}.$tmp);  ## no critic (Handle,Open)
      $slf->{'_wrk'}->clean_work($WRK);
    }
  }
  else
  { # Treat the command output on the fly
    local $SIG{'__WARN__'} = sub { };
    ($cmd, $pre, $env, $inc, @cln) = get_command($slf, $ctx, $cmd, $inc);
    if ($cmd)
    { $env = $slf->{'_sys'}->set_context($env) if $env;
      $slf->{'_col'}->log_start if $slf->{'_trc'};
      &{$fct}($ret, $slf, $ctx, $ifh, 0, $pre.$cmd, get_alarm($slf, $inc),
        $pid, @arg)
        if ($pid = open($ifh, "$cmd |"));  ## no critic (Handle,Open)
      $slf->{'_col'}->log_end($ctx, $pre.$cmd) if $slf->{'_trc'};
      $slf->{'_sys'}->restore_context($env) if $env;
      for (@cln)
      { $slf->{'_col'}->clean_work($_);
      }
    }
    elsif ($pre)
    { &{$fct}($ret, $slf, $ctx, $pre->get_handle, 0, 0, 0, 0, @arg);
    }
  }
  return $ret;
}

=head2 S<get_alarm($lim)>

This routine gets the alarm duration.

=cut

sub get_alarm
{ my ($slf, $val) = @_;

  return $slf->{'lim'} unless defined($val);
  return 0 unless $slf->{'lim'} > 0 && $val > 0;  ## no critic (Unless)
  $val *= $slf->{'lim'};
  return ($val > 1) ? int($val) : 1;
}

=head2 S<get_command($lib,$ctx,$req,$inc,$flg)>

This routine generates the command from the request. It supports the following
variants for the command argument:

=over 2

=item o A string

=item o An array of strings

=item o A hash describing the command

=back

The request hash can contain the following keys:

=over 11

=item S<    B<'cmd'> > Specifies the command (string or array).

=item S<    B<'env'> > Specifies environment alterations for the command.

=item S<    B<'flg'> > When true, does not transform the command.

=item S<    B<'inc'> > When present, specifies the timeout incremental ratio.

=item S<    B<'pwd'> > Controls password injection.

=item S<    B<'pwf'> > Controls password file use.

=item S<    B<'pre'> > Trace command prefix.

=item S<    B<'sap'> > When true, uses a short absolute path for password file.

=item S<    B<'src'> > Specifies a file to source before executing the command.

=item S<    B<'tag'> > Uses the tag for retrieving a previous execution.

=back

When a command is in an array format, RDA obtains the command by joining all
defined array items with spaces.

When the command must be executed, it returns a list containing the command,
the trace command prefix, the environment alterations, and the work files to
clean.

When it found a previous execution, it returns a list containing an undefined
value as command and a reference to a buffer pointing to the previous execution
results.

=cut

sub get_command  ## no critic (Complex)
{ my ($slf, $ctx, $req, $inc, $flg) = @_;
  my ($buf, $cmd, $env, $fmt, $ofh, $pth, $pre, $ref, @cln, @pwd);

  $pre = q{};
  $ref = ref($req);
  $ref = ref($req = $req->eval_as_data(1)) if $ref =~ m/^RDA::Value::\w+$/;
  if ($ref eq 'HASH')
  { return () unless ($cmd = gen_command($req->{'cmd'}));
    die get_string('IS_TAINTED', $cmd)
      if RDA::Object->is_tainted($cmd);
    return (undef, RDA::Object::Buffer->new('B', RDA::Handle::Block->new(
      RDA::Object::Rda->cat_file($ctx->get_collector->get_dir($buf->[2]),
                                 $buf->[3]), $buf->[0], $buf->[1])))
      if exists($req->{'tag'}) && defined($buf =
        $ctx->get_output->find_block(split(/\@/, $req->{'tag'})));
    $flg = 1 if $req->{'flg'};
    $inc = $req->{'inc'} if exists($req->{'inc'});
    $pre = $req->{'pre'} if exists($req->{'pre'});

    # Check for environment alterations
    $env = $req->{'env'} if ref($req->{'env'}) eq 'HASH';

    # Treat a password request
    if (exists($req->{'pwf'}))
    { ($fmt, @pwd) = @{$fmt} if ref($fmt = $req->{'pwf'}) eq 'ARRAY';
      $ofh = IO::File->new;
      $pth = $slf->{'_col'}->get_work($PWF, 1);
      $ofh->open($pth, $CREATE, $TMP_PERMS)
        or die get_string('ERR_WORK', $pth, $!);
      $buf = sprintf($fmt, $slf->{'_col'}->get_access->get_password(@pwd));
      $ofh->syswrite($buf, length($buf));
      $ofh->close;
      $pth = RDA::Object::Rda->short(RDA::Object::Rda->cat_file(
        $slf->{'_col'}->get_config->get_group('D_CWD'), $pth))
        if $req->{'sap'} && $slf->{'_sap'};
      unless ($cmd = sprintf($cmd, RDA::Object::Rda->quote($pth)))
      { $slf->{'_col'}->clean_work($PWF);
        return ();
      }
      push(@cln, $PWF);
    }
    elsif (exists($req->{'pwd'}))
    { @pwd = @{$fmt} if ref($fmt = $req->{'pwd'}) eq 'ARRAY';
      return () unless ($cmd = sprintf($cmd, RDA::Object::Rda->quote(
        $slf->{'_col'}->get_access->get_password(@pwd))));
    }

    # Treat a source request
    if (exists($req->{'src'}) && defined($buf = gen_command($req->{'src'})))
    { $ofh = IO::File->new;
      $pth = $slf->{'_col'}->get_work($CMD, 1);
      $ofh->open($pth, $CREATE, $EXE_PERMS)
        or die get_string('ERR_WORK', $pth, $!);
      $buf =
        (RDA::Object::Rda->is_unix)
          ? join(qq{\n}, ". $buf", $cmd, q{}) :
        (RDA::Object::Rda->is_windows || RDA::Object::Rda->is_cygwin)
          ? join(qq{\r\n}, q{@echo off},  ## no critic (Interpolation)
                           q{setlocal},
                           qq{call $buf},
                           $cmd,
                           q{endlocal},
                           q{}) :
        join(qq{\n}, $buf, $cmd, q{});
      $ofh->syswrite($buf, length($buf));
      $ofh->close;
      $cmd = $pth;
      push(@cln, $CMD);
    }
  }
  else
  { return () unless ($cmd = gen_command($req));
    die get_string('IS_TAINTED', $cmd)
      if RDA::Object->is_tainted($cmd);
  }
  return ($flg ? $cmd : cnv_command($slf, $cmd), $pre, $env, $inc, @cln);
}

=head2 S<get_output($lib,$ctx,$req,$typ[,$inc])>

This routine gets the output of a command in a temporary file.

=cut

sub get_output
{ my ($slf, $ctx, $req, $typ, $inc) = @_;
  my ($arg, $cmd, $env, $err, $lim, $out, $pid, $pre, $ret, $sta, $tmp, @cln);
  local $SIG{'__WARN__'} = sub { };

  # Abort when the command is missing
  return (0) unless $req;

  # Execute the command
  $lim = get_alarm($slf, $inc);
  $tmp = $slf->{'_wrk'}->get_work($WRK, 1);
  ($cmd, $pre, $env, $inc, @cln) = get_command($slf, $ctx, $req, $inc, 1);
  if ($cmd)
  { $out = RDA::Object::Rda->quote($tmp);
    $arg = $cmd;
    $arg =~ s{(\s+2>&1)?\s*$}{ >$out $1};
    $arg = cnv_command($slf, $arg);
    $env = $slf->{'_sys'}->set_context($env) if $env;
    eval {
      local $SIG{'ALRM'} = sub { die "Alarm\n" } if $lim;
      local $SIG{'PIPE'} = 'IGNORE';

      # Limit its execution to prevent RDA hangs
      set_alarm($lim) if $lim;

      # Execute the command
      $slf->{'_col'}->log_start if $slf->{'_trc'};
      if ($pid = open(OUT, qq{| $arg}))  ## no critic (Handle,Open)
      { local $SIG{'ALRM'} =
          sub { $sta = RDA::Object::Rda->kill_child($pid); } if $lim;
        close(OUT);
      }
      $slf->{'_col'}->log_end($ctx, $pre.$cmd) if $slf->{'_trc'};

      # Disable alarms
      clear_alarm() if $lim;
    };
    $err = $?;
    $sta = $@ unless $sta;
    $slf->{'_sys'}->restore_context($env) if $env;
    for (@cln)
    { $slf->{'_col'}->clean_work($_);
    }
    return ($err) unless $pid;
    if ($sta)
    { RDA::Object::Rda->kill_child($pid);
      $err = log_timeout($slf, $ctx, $typ, $pre.$cmd);
    }
  }
  elsif ($pre)
  { return (0, 0, $pre);
  }

  # Return the file name
  return ($err, $sta, $tmp);
}

=head2 S<gen_command($cmd)>

This routine generates the command. When a command is in an array format, it
obtains the command by joining all defined array items with spaces.

=cut

sub gen_command
{ my ($cmd) = @_;
  my ($ref);

  $ref = ref($cmd);
  return
    ($ref eq 'ARRAY') ? join(q{ }, grep {defined($_) && !ref($_)} @{$cmd}) :
    $ref              ? undef :
                        $cmd;
}

=head2 S<log_timeout($lib,$ctx,$typ,@arg)>

This routine logs a timeout event.

=cut

sub log_timeout
{ my ($slf, $ctx, $typ, @arg) = @_;

  $slf->{'_col'}->log_timeout($ctx, $typ, @arg);
  ++$slf->{'_out'};
  return $slf->{'err'} = -1;
}

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

# Generate the macro definitions
sub _get_macros
{ my ($slf) = @_;
  my ($def);

  $slf->{'_def'} = $def = {};
  foreach my $rec (get_libraries($slf))
  { my $lib = $rec->[0];
    foreach my $nam (@{$rec->[1]})
    { $def->{$nam} = $lib;
    }
  }
  return;
}

# Load the existing libraries
sub _load_libraries
{ my ($slf, $ctl, $skp, $top, @dir) = @_;
  my ($cls, $pth, @sub);

  # Load the libraries
  if (opendir(LIB, $pth = RDA::Object::Rda->cat_dir($top, @dir)))
  { foreach my $sub (readdir(LIB))
    { next unless $sub =~ m/^(\w+)(\.(dir|pm))?$/i;
      $sub = ucfirst(lc($1));
      if (defined($2) && lc($3) eq 'pm')
      { $cls = join(q{::}, @dir, $sub);
        next if exists($skp->{$cls});
        eval "require $cls";
        if ($@)
        { $slf->{'_agt'}->add_error($@, get_string('ERR_LIBRARY', $cls));
        }
        else
        { $cls->new($slf, $ctl);
        }
      }
      elsif (-d RDA::Object::Rda->cat_dir($pth, $sub))
      { push(@sub, $sub) if $sub ne 'Cvs';
      }
    }
    closedir(LIB);
  }

  # Treat subdirectories
  foreach my $sub (@sub)
  { _load_libraries($slf, $ctl, $skp, $top, @dir, $sub);
  }
  return;
}

1;

__END__

=head1 SEE ALSO

L<RDA::Agent|RDA::Agent>,
L<RDA::Alarm|RDA::Alarm>,
L<RDA::Handle::Block|RDA::Handle::Block>,
L<RDA::Object|RDA::Object>,
L<RDA::Object::Buffer|RDA::Object::Buffer>,
L<RDA::Object::Collect|RDA::Object::Collect>,
L<RDA::Object::Log|RDA::Object::Log>,
L<RDA::Object::Output|RDA::Object::Output>,
L<RDA::Object::Rda|RDA::Object::Rda>,
L<RDA::Object::View|RDA::Object::View>,
L<RDA::SDCL::Block|RDA::SDCL::Block>,
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