# Language.pm: Class Used for Controlling SDCL Code Execution

package RDA::SDCL::Language;

# $Id: Language.pm,v 1.16 2015/05/08 18:19:06 RDA Exp $
# ARCS: $Header: /home/cvs/cvs/RDA_8/src/scripting/lib/RDA/SDCL/Language.pm,v 1.16 2015/05/08 18:19:06 RDA Exp $
#
# Change History
# 20150508  MSC  Improve the documentation.

=head1 NAME

RDA::SDCL::Language - Class Used for Controlling SDCL Code Execution

=head1 SYNOPSIS

 require RDA::SDCL::Language;

=head1 DESCRIPTION

The objects of the C<RDA::SDCL::Language> class are used to execute Support
Diagnostic Collection Language (SDCL) code. It is a subclass of
L<RDA::Driver::Language|RDA::Driver::Language> and L<RDA::Object|RDA::Object>.

The following methods are available:

=cut

use strict;

BEGIN
{ use Exporter;
  use IO::File;
  use RDA::Text qw(get_string);
  use RDA::Driver::Library;
  use RDA::Object;
  use RDA::Object::Rda qw($DIR_PERMS);
  use RDA::SDCL::Block;
}

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

# Define the global private constants
my @CLASSES = qw(RDA::Object::Access
                 RDA::Object::Collect
                 RDA::Object::Content
                 RDA::Object::Display
                 RDA::Object::Env
                 RDA::Object::Item
                 RDA::Object::Pipe
                 RDA::Object::Rda
                 RDA::Object::Report
                 RDA::Object::Target
                 RDA::Object::Toc
                 RDA::Object::View
                 RDA::Object::Windows);

# Define the global private variables
my @tb_pkg = qw(Compress::Zlib
                DBI
                Digest::MD5
                Socket
                Time::HiRes);

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

=head2 S<$h = RDA::SDCL::Language-E<gt>new($agent[,$flag])>

The object constructor for language object. This method takes the agent
reference as an argument.

The following special keys are used:

=for stopwords preload

=over 12

=item S<    B<'agt' > > Reference to the agent object

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

=item S<    B<'cls' > > List of classes to preload

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

=item S<    B<'dir' > > Collect directory structure

=item S<    B<'lvl' > > Trace level

=item S<    B<'oid' > > Setup name

=item S<    B<'_blk'> > Block hash

=item S<    B<'_inf'> > Object for getting missing object attributes

=item S<    B<'_lib'> > Reference to the SDCL library driver

=item S<    B<'_opr'> > Operator definition hash

=item S<    B<'_tmp'> > Temporary block hash

=back

Internal keys are prefixed by an underscore.

=cut

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

  # Create the language object
  $cfg = $agt->get_config;
  $col = $agt->get_collector;
  $slf = bless {
    agt  => $agt,
    cfg  => $cfg,
    cls  => [@CLASSES],
    col  => $col,
    dir  => $cfg->get_group('D_RDA_COL'),
    lvl  => $agt->get_level,
    oid  => $agt->get_oid,
    _blk => {},
    _inf => $agt,
    }, ref($cls) || $cls;
  $agt->trace(get_string('SdclInit'))
    unless $slf->{'lvl'} < 10;  ## no critic (Unless)

  # Preload Perl packages, when they are available
  foreach my $pkg (@tb_pkg)
  { eval "require $pkg";
  }
  eval {
    require POSIX;
    ## no critic (Call)
    POSIX::setlocale(POSIX::LC_ALL(), 'C');
  };

  # Initialise the macros and the operators
  if ($flg)
  { $slf->get_operators;
    $slf->{'_lib'} = RDA::Driver::Library->new($col);
  }

  # 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
{ # End the libraries
  delete($_[0]->{'_lib'})->delete_object if exists($_[0]->{'_lib'});

  # Delete the object
  $_[0]->SUPER::delete_object;
  return;
}

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

This method returns a reference to the access control object.

=cut

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

=head2 S<$h-E<gt>get_agent([$name[,$default]])>

This method returns the value of an agent object attribute or the default
value when the attribute is not defined.

It returns the agent object reference when no attribute name is specified.

=cut

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

  return defined($nam) ? $slf->{'agt'}->get_info($nam, $dft) : $slf->{'agt'};
}

=head2 S<$h-E<gt>get_collector([$name[,$default]])>

This method returns the value of an collector object attribute or the default
value when the attribute is not defined.

It returns the collector object reference when no attribute name is specified.

=cut

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

  return defined($nam) ? $slf->{'col'}->get_info($nam, $dft) : $slf->{'col'};
}

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

This method returns a reference to the RDA software configuration.

=cut

sub get_config
{ return shift->{'cfg'};
}

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

This method updates the language interface for a new collector. It returns a
reference to the language interface object.

=cut

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

  if (ref($col) eq 'RDA::Object::Collect')
  { # Delete packages
    foreach my $oid (keys(%{$slf->{'_tmp'}}))
    { delete($slf->{'_blk'}->{$oid})->delete_object;
      delete($slf->{'_tmp'}->{$oid});
    }
    foreach my $oid (keys(%{$slf->{'_blk'}}))
    { delete($slf->{'_blk'}->{$oid})->delete_object;
    }

    # Merge the collector information
    $slf->{'col'} = $col;

    # Reload macro libraries
    $slf->{'_lib'}->refresh($col) if exists($slf->{'_lib'});
  }

  # Return the object reference
  return $slf;
}

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

This method applies resume directives.

=cut

sub resume
{ my ($slf, $bkp) = @_;
  my ($lib, $hsh);

  foreach my $rec (@{$bkp})
  { ($lib, $hsh) = @{$rec};
    $lib->resume($hsh);
  }
  return;
}

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

This method resets relevant libraries and returns the resume directives.

=cut

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

  return [map {$_->suspend} $slf->get_libraries('suspend')];
}

=head1 OPERATOR MANAGEMENT METHODS

=head2 S<$h-E<gt>define_operator($name,$arg,...)>

This method defines a new SDCL operator. You can specify multiple operator
names with a name array. It uses the first definition found. It generates an
error when no definition are found.

=cut

sub define_operator
{ my ($slf, $nam, @arg) = @_;
  my ($tbl);

  $tbl = $slf->{'_opr'};
  $nam = [$nam] unless ref($nam) eq 'ARRAY';
  foreach my $itm (@{$nam})
  { return &{$tbl->{$itm}}(@arg) if exists($tbl->{$itm});
  }
  die get_string('BAD_OPERATOR', join(q{,}, @{$nam}));
}

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

This method returns the definition of an operator.

=cut

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

  return exists($slf->{'_opr'}->{$nam}) ? $slf->{'_opr'}->{$nam} : undef;
}

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

This method returns the libraries having the specified capability. When you
do not specify a capability, it returns a reference to the macro library
driver.

=cut

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

  # Load the libraries on first call
  $slf->{'_lib'} = RDA::Driver::Library->new($slf->{'col'})
    unless exists($slf->{'_lib'});

  # Return libraries having the specified capability
  return $slf->{'_lib'}->get_libraries($cap) if defined($cap);

  # Return a reference to the library driver
  return $slf->{'_lib'};
}

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

This method returns the definition of all known operators.

=cut

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

  unless (exists($slf->{'_opr'}))
  { my ($skp, @cls);

    $slf->{'agt'}->trace(get_string('Operators'))
      unless $slf->{'lvl'} < 20;  ## no critic (Unless)
    $slf->{'_opr'} = {};
    $skp = {map {$_ => 1} $slf->{'cfg'}->get_obsolete('opr')};
    if (@cls = $slf->{'cfg'}->is_compiled('OPR'))
    { foreach my $cls (@cls)
      { next if exists($skp->{$cls});
        eval "require $cls";
        if ($@)
        { $slf->{'agt'}->add_error($@, get_string('ERR_OPERATOR', $cls));
        }
        else
        { $cls->load($slf->{'_opr'});
        }
      }
    }
    else
    { _load_operators($slf, $skp, $slf->{'cfg'}->get_group('D_RDA_INC'),
        'RDA', 'Operator');
    }
  }
  return $slf->{'_opr'};
}

sub _load_operators
{ my ($slf, $skp, $top, @dir) = @_;
  my ($cls, $pth, @sub);

  # Load the operators
  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_OPERATOR', $cls));
        }
        else
        { $cls->load($slf->{'_opr'});
        }
      }
      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_operators($slf, $skp, $top, @dir, $sub);
  }
  return;
}

=head1 PACKAGE MANAGEMENT METHODS

=head2 S<$h-E<gt>add_package($group,$name)>

This method creates a new package and returns its reference. It clears previous
errors.

=cut

sub add_package
{ my ($slf, $grp, $nam) = @_;
  my ($obj, $oid);

  $slf->{'agt'}->abort(get_string('NO_NAME')) unless defined($nam);
  $obj = RDA::SDCL::Block->new($slf, $grp, $nam);
  $oid = lc($obj->get_oid);
  $slf->{'_blk'}->{$oid}->delete_object if exists($slf->{'_blk'}->{$oid});
  return $slf->{'_blk'}->{$oid} = $slf->{'_tmp'}->{$oid} = $obj;
}

=head2 S<$h-E<gt>detach_package($package...)>

This method removes packages from the cache without deleting them. It accepts
package references or identifiers as arguments.

=cut

sub detach_package
{ my ($slf, @pkg) = @_;
  my ($oid);

  foreach my $pkg (@pkg)
  { $oid = lc(ref($pkg) ? $pkg->get_oid : $pkg);
    delete($slf->{'_blk'}->{$oid});
    delete($slf->{'_tmp'}->{$oid});
  }
  return 1;
}

=head2 S<$h-E<gt>find_package($oid[,$group])>

This method returns a reference to the specified package. Otherwise, it returns
an undefined value.

=cut

sub find_package
{ my ($slf, $nam, $grp) = @_;
  my ($oid);

  return $slf->{'_blk'}->{$nam}
    if exists($slf->{'_blk'}->{$nam = lc($nam)});
  $grp = ['RDA'] unless ref($grp) eq 'ARRAY';
  foreach my $alt (@{$grp})
  { return $slf->{'_blk'}->{$oid}
      if exists($slf->{'_blk'}->{$oid = lc($alt).q{:}.$nam});
  }
  return;
}

=head2 S<$h-E<gt>keep_package($package...)>

This method makes packages persistent. It accepts package references or
identifiers as arguments.

=cut

sub keep_package
{ my ($slf, @pkg) = @_;

  foreach my $pkg (@pkg)
  { delete($slf->{'_tmp'}->{lc(ref($pkg) ? $pkg->get_oid : $pkg)});
  }
  return 1;
}

=head2 S<$h-E<gt>load_data($ifh,$group,$name[,$classes])>

This method creates new package, parses its code from the specified input file
handle, and returns its reference. You can specify the list of classes to
preload.

=cut

sub load_data
{ my ($slf, $ifh, $grp, $nam, $cls) = @_;

  return $slf->add_package($grp, $nam)->parse($ifh, $cls);
}

=head2 S<$h-E<gt>load_file($name[,$directory[,$classes]])>

This method creates new package, parses its code from the specified file, and
returns its reference. It returns an undefined value when it cannot open the
file. You can specify the list of classes to preload.

=cut

sub load_file
{ my ($slf, $nam, $dir, $cls) = @_;
  my ($ifh, $obj);

  $dir = $slf->{'dir'} unless defined($dir);
  $slf->{'agt'}->abort(get_string('NO_PATH')) unless defined($nam);
  $nam =~ s/\.(ctl|cfg)$//i;
  $ifh = IO::File->new;
  if ($ifh->open('<'.RDA::Object::Rda->cat_file($dir, "$nam.ctl")))
  { $obj = $slf->load_data($ifh, undef, $nam, $cls);
    $obj->set_info('dir', $dir);
  }
  return $obj;
}

=head2 S<$h-E<gt>load_package($module[,$classes])>

This method creates new package, parses its code from the SDCL directory group,
and returns its reference. It returns an undefined value when it cannot open
the corresponding specification file. You can specify the list of classes to
preload.

=cut

sub load_package
{ my ($slf, $mod, $cls) = @_;
  my ($ifh, $pth);

  $slf->{'agt'}->abort(get_string('NO_MODULE'))
    unless $mod =~ m/^(\w+):(\w+)$/;
  $pth = RDA::Object::Rda->cat_file($slf->{'dir'}, $1, "$2.ctl");
  return ($ifh = IO::File->new)->open("<$pth")
    ? $slf->load_data($ifh, $1, $2, $cls)
    : undef;
}

=head2 S<$h-E<gt>norm_package($group,$name[,$default])>

This method returns a normalized module name, which includes the module group
and the package identifier.

=cut

sub norm_package
{ my ($slf, $grp, $nam, $dft) = @_;
  my ($dir, @grp);

  if ($nam =~ m/^(\w+):(\w+)$/)
  { @grp = ($1);
    $nam = $2
  }
  elsif (ref($grp) eq 'ARRAY')
  { @grp = @{$grp};
  }
  else
  { @grp = ($grp);
  }

  $dir = $slf->{'dir'};
  foreach my $sub (@grp)
  { return join(q{:}, $sub, $nam)
      if -f RDA::Object::Rda->cat_file($dir, $sub, "$nam.ctl");
  }
  return unless wantarray;
  return @{$dft} if ref($dft) eq 'ARRAY';
  return ($dft)  if defined($dft);
  return ();
}

=head2 S<$h-E<gt>remove_package([$package...])>

This method removes specified packages. It accepts package references or
identifiers as arguments. When no arguments are provided, it removes all
temporary packages. It returns the number of packages effectively removed.

=cut

sub remove_package
{ my ($slf, @pkg) = @_;
  my ($cnt, $oid);

  $cnt = 0;
  @pkg = keys(%{$slf->{'_tmp'}}) unless @pkg;
  foreach my $pkg (@pkg)
  { $oid = lc(ref($pkg) ? $pkg->get_oid : $pkg);
    next unless exists($slf->{'_tmp'}->{$oid});
    delete($slf->{'_blk'}->{$oid})->delete_object;
    delete($slf->{'_tmp'}->{$oid});
    ++$cnt;
  }
  return $cnt;
}

=head2 S<$h-E<gt>search_package($group,$name[,$classes])>

This method creates new package and parses its code. When the specified name is
in the module format, it attempts to run C<load_package>. Otherwise, the file
containing its code is searched in the specified groups. You can specify the
list of classes to preload. It returns a package reference on successful search
or an undefined value otherwise.

=cut

sub search_package
{ my ($slf, $grp, $nam, $cls) = @_;
  my ($bas, $dir, $ifh, $pth);

  # Determine the applicable groups
  $slf->{'agt'}->abort(get_string('NO_NAME')) unless defined($nam);
  return $slf->load_package($nam, $cls) if $nam =~ m/^(\w+):(\w+)$/;
  $grp = [$grp] unless ref($grp) eq 'ARRAY';

  # Search in the specified groups
  $bas = RDA::Object::Rda->basename($nam);
  $dir = $slf->{'dir'};
  $ifh = IO::File->new;
  foreach my $sub (@{$grp})
  { # Search for a SDCL package
    if (-f ($pth = RDA::Object::Rda->cat_file($dir, $sub, "$bas.ctl")))
    { $ifh->open("<$pth")
        or $slf->{'agt'}->abort($!, get_string('ERR_OPEN', $pth));
      return $slf->load_data($ifh, $sub, $bas, $cls);
    }
  }
  return;
}

1;

__END__

=head1 SEE ALSO

L<RDA::Agent|RDA::Agent>,
L<RDA::Driver::Library|RDA::Driver::Library>,
L<RDA::Object|RDA::Object>,
L<RDA::Object::Collect|RDA::Object::Collect>,
L<RDA::Object::Env|RDA::Object::Env>,
L<RDA::Object::Rda|RDA::Object::Rda>,
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