# Java.pm: Class Used for Managing Java Classes

package RDA::Object::Java;

# $Id: Java.pm,v 1.18 2015/06/11 08:03:05 RDA Exp $
# ARCS: $Header: /home/cvs/cvs/RDA_8/src/scripting/lib/RDA/Object/Java.pm,v 1.18 2015/06/11 08:03:05 RDA Exp $
#
# Change History
# 20150610  MSC  Improve the interconnect method.

=head1 NAME

RDA::Object::Java - Class Used for Managing Java Classes

=head1 SYNOPSIS

 require RDA::Object::Java;

=head1 DESCRIPTION

The objects of the C<RDA::Object::Java> class are used to manage Java
classes. It is a subclass of L<RDA::Object|RDA::Object>.

The following methods are available:

=cut

use strict;

BEGIN
{ use Exporter;
  use File::Copy qw(copy);
  use IO::File;
  use IO::Handle;
  use RDA::Text qw(debug get_string);
  use RDA::Alarm qw(clear_alarm set_alarm);
  use RDA::SDCL::Block qw($SPC_OBJ $SPC_REF $SPC_VAL $CONT);
  use RDA::Object;
  use RDA::Object::Rda qw($CREATE $FIL_PERMS);
}

# Define the global public variables
use vars qw($STRINGS $VERSION @ISA %SDCL);
$VERSION = sprintf('%d.%02d', q$Revision: 1.18 $ =~ /(\d+)\.(\d+)/);
@ISA     = qw(RDA::Object Exporter);
%SDCL    = (
  cmd => {
    'java' => [\&_exe_java, \&_get_java, 'T', \&_parse_java],
    },
  beg => \&_begin_java,
  dep => [qw(RDA::Object::Inline)],
  inc => [qw(RDA::Object)],
  met => {
    'get_info'    => {ret => 0},
    'set_info'    => {ret => 0},
    'set_warning' => {ret => 0},
    },
  );

# Define the global private constants
my $JAVA = 'Java';

# Define the global private variables
my %tb_opt = (
  X      => 'B_OPT_X',
  nowarn => 'B_OPT_NOWARN',
  );

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

=head2 S<$h = RDA::Object::Java-E<gt>new($nam,$cod[,$ver[,$pkg]])>

The master control object constructor. This method takes the block name, the
code line array, the Java version, and the package as arguments.

The control objects are represented by a blessed hash reference. The following
special keys are used:

=over 12

=item S<    B<'err' > > Error indicator

=item S<    B<'oid' > > Object identifier

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

=item S<    B<'_cmd'> > Java command

=item S<    B<'_cod'> > Java code lines

=item S<    B<'_dep'> > Dependency hash

=item S<    B<'_err'> > Standard error file

=item S<    B<'_exe'> > Class file

=item S<    B<'_jar'> > Associated jar files

=item S<    B<'_jdk'> > Current JDK

=item S<    B<'_out'> > Standard output file

=item S<    B<'_seq'> > Execution sequencer

=item S<    B<'_sub'> > Optional subdirectory

=item S<    B<'_typ'> > Block type

=item S<    B<'_ver'> > Optional source Java version

=item S<    B<'_wrn'> > Acceptable warnings hash

=back

=cut

sub new
{ return shift->new_block('M', @_);
}

sub new_block
{ my ($cls, $typ, $oid, $cod, $ver, $pkg) = @_;
  my ($slf, $sub);

  # Create the object
  $slf = bless {
    err  => 0,
    oid  => $oid,
    pre  => q{},
    _cmd => $oid,
    _cod => $cod,
    _dep => [],
    _jar => [],
    _typ => $typ,
    }, ref($cls) || $cls;
  if (defined($pkg))
  { $sub = $pkg;
    $sub =~ s{\.}{/}g;
    $slf->{'_sub'} = $sub;
  }
  $slf->{'_ver'} = $ver if defined($ver) && $ver =~ m/^\d+(\.\d+)?$/;

  # Check the Java code and return the object reference
  return $slf->check;
}

sub new_command
{ my ($cls, $oid, $cmd) = @_;

  # Create the object and return its reference
  return bless {
    err  => 0,
    oid  => $oid,
    pre  => q{},
    _cmd => $cmd,
    _dep => [],
    _jar => [],
    _typ => 'X',
    }, ref($cls) || $cls;
}

=head2 S<$h-E<gt>add_dependency($dep)>

This method adds the specified block in the dependency list. It returns the
object reference.

=cut

sub add_dependency
{ my ($slf, $dep) = @_;

  die get_string('NO_TOP') unless $slf->{'_typ'} eq 'M';
  push(@{$slf->{'_dep'}}, $dep);

  # Return the object reference
  return $slf;
}

=head2 S<$h-E<gt>add_jar($jar)>

This method associates the specified jar file for compilation and execution. It
returns the object reference.

=cut

sub add_jar
{ my ($slf, $jar) = @_;

  push(@{$slf->{'_jar'}}, RDA::Object::Rda->native($jar))
    if -f $jar || -d $jar;

  # Return the object reference
  return $slf;
}

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

This method adds a sequencer to make the file names unique. It returns the
object reference.

=cut

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

  $slf->{'_seq'} = 0;

  # Return the object reference
  return $slf;
}

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

This method checks that the code is conform to its type. It returns the object
reference.

=cut

sub check
{ my ($slf) = @_;
  my ($err, $nam, $nxt, $pat, $tbl, $typ, %tbl);

  # Determine the validation rules
  $nam = $slf->{'oid'};
  $typ = $slf->{'_typ'};
  %tbl = (
    C => {top => [qr/^\s*(public\s+)?class\s+\Q$nam\E\b/m,
                  'NO_CLASS',
                  'end'], # Text:NO_CLASS
          end => [],
         },
    I => {top => [qr/^\s*(public\s+)?interface\s+\Q$nam\E\b/m,
                  'NO_INTERFACE',
                  'end'], # Text:NO_INTERFACE
          end => [],
         },
    M => {top => [qr/^\s*(public\s+)?(static\s+)?class\s+\Q$nam\E\b/m,
                  'NO_CLASS',
                  'met'], # Text:NO_CLASS
          end => [],
          met => [qr/^[\{\s]*public\s+static\s+void\s+main\b/m,
                  'NO_MAIN',
                  'end'], # Text:NO_MAIN
         },
    );
  die get_string('BAD_TYPE', $typ) unless exists($tbl{$typ});
  $tbl = $tbl{$typ};

  # Apply the validation rules
  ($pat, $err, $nxt) = @{$tbl->{'top'}};
  TEST: foreach my $lin (@{$slf->{'_cod'}})
  { while ($lin =~ $pat)
    { ($pat, $err, $nxt) = @{$tbl->{$nxt}};
      last TEST unless $nxt;
    }
  }
  die get_string($err, $nam) if $err;

  # Return the object reference
  return $slf;
}

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

This method removes the associated files.

=cut

sub clear
{ my ($slf) = @_;
  my ($pth);

  foreach my $key (qw(_out _err))
  { next unless defined($pth = delete($slf->{$key}));
    1 while unlink($pth);
  }
  return $slf;
}

=head2 S<$h-E<gt>compile($ctl)>

This method compiles the code.

=cut

sub compile  ## no critic (Complex)
{ my ($slf, $ctl) = @_;
  my ($bkp, $cmd, $ctx, $dir, $err, $exe, $nam, $ofh, $ret, $src, $sys, $trc,
      @opt);

  # Get the language context
  $ctx = $ctl->get_context($JAVA);
  $trc = $ctx->{'N_TRACE'} ? 'JAVA]' : q{};

  # Compile the Java class when not yet available
  $dir = exists($slf->{'_sub'})
    ? RDA::Object::Rda->create_dir(RDA::Object::Rda->cat_dir($ctl->get_cache,
        $slf->{'_sub'}))
    : $ctl->get_cache;
  $nam = $slf->{'oid'};
  $exe = RDA::Object::Rda->cat_file($dir, $nam.$ctx->{'EXE'});
  if ($ctx->{'B_CACHE'} && -f $exe)
  { debug("JAVA] Reuse: $exe") if $trc;
  }
  elsif ($ctx->{'B_CACHE'}
    && -f ($src = $ctl->get_compiled($nam.$ctx->{'EXE'})))
  { debug("JAVA] Use: $src") if $trc;
    copy($src, $exe) or die get_string('ERR_COPY', $!);
  }
  elsif (defined($cmd = _find_cmd($slf, $ctx, 'JAVAC', 'javac')))
  { # Write the source file
    $ofh = IO::File->new;
    $src = RDA::Object::Rda->cat_file($dir, $nam.$ctx->{'SRC'});
    debug("JAVA] Save block $src") if $trc;
    if ($ofh->open($src, $CREATE, $FIL_PERMS))
    { print {$ofh} join(qq{\n}, @{$slf->{'_cod'}}, q{});
      $ofh->close;
    }

    # Modify the environment
    $bkp = $ctx->{'Sys'}->set_context({
      CLASSPATH => join($ctx->{'SEP'},
                     RDA::Object::Rda->native($ctl->get_cache),
                     @{$slf->{'_jar'}},
                     map {RDA::Object::Rda->native($_)} @{$ctx->{'classpath'}}),
      %{$ctx->{'Env'}}
      }, $trc);

    # Compile the Java class
    $cmd = RDA::Object::Rda->quote($cmd);
    $err = RDA::Object::Rda->cat_file($dir, $nam.'.err');
    @opt = ('-deprecation');
    if (exists($slf->{'_ver'}))
    { push(@opt, '-source', $slf->{'_ver'});
      if (_has_option($slf, $ctx, 'nowarn', $cmd, $trc))
      { push(@opt, '-nowarn');
      }
      elsif (_has_option($slf, $ctx, 'X', $cmd, $trc))
      { push(@opt, '-Xlint:none');
      }
    }
    $cmd = _conv_cmd(join(q{ }, $cmd, @opt,
      RDA::Object::Rda->quote(RDA::Object::Rda->native($src)),
      '>'.RDA::Object::Rda->quote($err), '2>&1'));
    debug("JAVA] Execute: $cmd") if $trc;
    $ret = system($cmd);
    debug("JAVA] Compilation exit code: $ret") if $trc;
    if (-s $err && _has_errors($slf, $err))
    { $slf->{'err'} = 1;
      1 while unlink($exe);
      die get_string('ERR_COMPILE', $nam);
    }
    1 while unlink($err);

    # Restore the environment
    $ctx->{'Sys'}->restore_context($bkp, $trc);

    # Remove the source file
    unless ($ctx->{'B_KEEP'})
    { 1 while unlink($src);
    }
  }
  else
  { $slf->{'err'} = 1;
    debug('JAVA] No Java compiler found') if $trc;
    die get_string('NO_JAVAC');
  }
  $slf->{'_exe'} = $exe;

  # Return the completion status
  return $ret;
}

=head2 S<$h-E<gt>execute($ctl,@arg)>

This method executes the named block in the specified context.

=cut

sub execute  ## no critic (Complex)
{ my ($slf, $ctl, @arg) = @_;
  my ($bkp, $cmd, $ctx, $dir, $err, $ifh, $lim, $nam, $out, $pid, $trc, @tbl);

  # Get the language context
  $ctx = $ctl->get_context($JAVA);
  $trc = $ctx->{'N_TRACE'} ? 'JAVA]' : q{};
  unless (defined($cmd = _find_cmd($slf, $ctx, 'JAVA', 'java')))
  { debug('JAVA] No Java runtime found') if $trc;
    die get_string('NO_JAVA')
  }
  $lim = $ctx->{'N_TIMEOUT'};

  # Modify the environment
  $dir = $ctl->get_cache;
  $bkp = $ctx->{'Sys'}->set_context({
    CLASSPATH => join($ctx->{'SEP'},
                   RDA::Object::Rda->native($dir),
                   @{$slf->{'_jar'}},
                   map {RDA::Object::Rda->native($_)} @{$ctx->{'classpath'}}),
    %{$ctx->{'Env'}}
    }, $trc);

  # Execute the Java code
  $nam = $slf->{'oid'};
  $nam .= q{_}.(++$slf->{'_seq'}) if exists($slf->{'_seq'});
  $out = RDA::Object::Rda->cat_file($dir, "$nam.out");
  $err = RDA::Object::Rda->cat_file($dir, "$nam.err");
  1 while unlink($out, $err);
  $cmd = _conv_cmd(join(q{ }, RDA::Object::Rda->quote($cmd), $slf->{'_cmd'},
    (grep {defined($_) && !ref($_)} @arg),
    '>'.RDA::Object::Rda->quote($out),
    '2>'.RDA::Object::Rda->quote($err)));
  debug("JAVA] Execute: $cmd")   if $trc;
  debug("JAVA] Limit: $lim sec") if $lim;
  eval {
    local $SIG{'ALRM'} = sub { die "Alarm\n" } if $lim;
    set_alarm($lim) if $lim;
    close(OUT) if ($pid = open(OUT, "| $cmd"));  ## no critic (Handle,Open)
    clear_alarm() if $lim;
  };
  if ($@)
  { debug("JAVA] Process identifier: $pid") if $trc;
    RDA::Object::Rda->kill_child($pid);
    $ctl->{'pkg'}->get_collector->log_timeout($ctl->{'pkg'},
      $JAVA.q{.}.$slf->{'oid'}, @arg);
    debug('JAVA] Execution timeout') if $trc;
  }

  # Restore the environment
  $ctx->{'Sys'}->restore_context($bkp, $trc);

  # Extract and return the results
  die get_string('ERR_EXEC', $slf->{'oid'}) if -s $err;
  1 while unlink($err);
  $ifh = IO::File->new;
  if ($ifh->open("<$out"))
  { while(<$ifh>)
    { s/[\n\r\s]+$//;
      push(@tbl, $_);
      debug('JAVA> ', $_) if $trc;
    }
    $ifh->close;
  }
  unless ($ctx->{'B_KEEP'})
  { 1 while unlink($out);
  }
  return @tbl;
}

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

This method returns the block language.

=cut

sub get_language
{ return $JAVA;
}

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

This method returns the block name.

=cut

sub get_name
{ return shift->{'oid'};
}

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

This method indicates whether the named block or its dependencies has errors.

=cut

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

  foreach my $dep (@{$slf->{'_dep'}})
  { return 1 if $dep->{'err'};
  }
  return $slf->{'err'};
}

=head2 S<RDA::Object::Java-E<gt>init($ctx,$col)>

This method initializes the compilation and execution context.

=cut

sub init
{ my ($slf, $ctx, $col) = @_;
  my ($agt, $sys, $tbl);

  $agt = $col->get_agent;
  $sys = $agt->get_system;

  # Initialize the context
  $ctx->{'BIN'} = 'bin' unless exists($ctx->{'BIN'});
  $ctx->{'EXE'} = '.class';
  $ctx->{'SRC'} = '.java';
  $ctx->{'SEP'} = $sys->get_native->get_separator;

  # Clean up the Java class path
  $ctx->{'classpath'} = $tbl = [$sys->get_list('cp')];

  # Keep the collector and system view references
  $ctx->{'Agt'} = $agt;
  $ctx->{'Col'} = $col;
  $ctx->{'Env'} = {};
  $ctx->{'Sys'} = $sys;

  # Return the context description
  return $ctx;
}

=head2 S<$h-E<gt>interconnect($ifh,$ofh,$efh,$ctl,@arg)>

This method creates a bidirectional communication channel with the named block,
which is executed in the specified context with the specified arguments. It
returns the process identifier.

=cut

sub interconnect
{ my ($slf, $ifh, $ofh, $efh, $ctl, @arg) = @_;
  my ($bkp, $cmd, $ctx, $dir, $err, $nam, $pid, $trc, @cmd);

  # Get the language context (spawn requires file extension)
  $ctx = $ctl->get_context($JAVA);
  die get_string('NO_JAVA')
    unless defined($cmd = _find_cmd($slf, $ctx, 'JAVA',
      RDA::Object::Rda->is_windows ? 'java.exe' : 'java'));
  $trc = $slf->{'pre'}     ? $slf->{'pre'}.q{]} :
         $ctx->{'N_TRACE'} ? q{JAVA]} :
                             q{};

  # Modify the environment
  $dir = $ctl->get_cache;
  $bkp = $ctx->{'Sys'}->set_context({
    CLASSPATH => join($ctx->{'SEP'},
                   RDA::Object::Rda->native($dir),
                   @{$slf->{'_jar'}},
                   map {RDA::Object::Rda->native($_)} @{$ctx->{'classpath'}}),
    %{$ctx->{'Env'}}
    }, $trc);

  # Execute the Java code
  $nam = $slf->{'oid'};
  $nam .= q{_}.(++$slf->{'_seq'}) if exists($slf->{'_seq'});
  $err = RDA::Object::Rda->cat_file($dir, "$nam.err");
  @cmd = ($cmd, $slf->{'_cmd'}, grep {defined($_) && !ref($_)} @arg);
  debug(join(q{ }, "$trc Interconnect:", @cmd)) if $trc;
  require RDA::Handle::Agent;
  $pid = RDA::Handle::Agent::exec_command($ifh, $ofh, $efh, @cmd);
  debug("$trc Pid: $pid") if $trc;
  unless ($ctx->{'B_KEEP'})
  { $slf->{'_err'} = $err;
  }

  # Restore the environment
  $ctx->{'Sys'}->restore_context($bkp, $trc);

  # Return the process identifier
  return $pid;
}

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

This method indicates whether the named block is already compiled.

=cut

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

  return exists($slf->{'_exe'}) && -f $slf->{'_exe'};
}

=head2 S<$h-E<gt>launch($ofh,$ctl,@arg)>

This method creates a pipe to the named block, which is executed in the
specified context with the specified arguments. It returns the process
identifier in a scalar context, the process identifier, the output and error
files in a list context.

=cut

sub launch
{ my ($slf, $ofh, $ctl, @arg) = @_;
  my ($bkp, $cmd, $ctx, $dir, $err, $ifh, $nam, $out, $pid, $trc);

  # Get the language context
  $ctx = $ctl->get_context($JAVA);
  die get_string('NO_JAVA')
    unless defined($cmd = _find_cmd($slf, $ctx, 'JAVA', 'java'));
  $trc = $slf->{'pre'}     ? $slf->{'pre'}.q{]} :
         $ctx->{'N_TRACE'} ? q{JAVA]} :
                             q{};

  # Modify the environment
  $dir = $ctl->get_cache;
  $bkp = $ctx->{'Sys'}->set_context({
    CLASSPATH => join($ctx->{'SEP'},
                   RDA::Object::Rda->native($dir),
                   @{$slf->{'_jar'}},
                   map {RDA::Object::Rda->native($_)} @{$ctx->{'classpath'}}),
    %{$ctx->{'Env'}}
    }, $trc);

  # Execute the Java code
  $nam = $slf->{'oid'};
  $nam .= q{_}.(++$slf->{'_seq'}) if exists($slf->{'_seq'});
  $err = RDA::Object::Rda->cat_file($dir, "$nam.err");
  $out = RDA::Object::Rda->cat_file($dir, "$nam.out");
  1 while unlink($out, $err);
  $cmd = join(q{ }, RDA::Object::Rda->quote($cmd), $slf->{'_cmd'},
    (grep {defined($_) && !ref($_)} @arg));
  $cmd .= (!$trc)                 ? q{ >}.RDA::Object::Rda->quote($out) :
          $ctx->{'Agt'}->is_slave ? q{ >&2} :
                                    q{};
  $cmd .= ' 2>'.RDA::Object::Rda->quote($err);
  $cmd = _conv_cmd($cmd);
  debug("$trc Launch: $cmd") if $trc;
  $pid = open($ofh, "| $cmd");  ## no critic (Close,Open)
  debug("$trc Pid: $pid") if $trc;
  unless ($ctx->{'B_KEEP'})
  { $slf->{'_err'} = $err;
    $slf->{'_out'} = $out;
  }

  # Restore the environment
  $ctx->{'Sys'}->restore_context($bkp, $trc);

  # Return the process identifier
  return ($pid, $out, $err) if wantarray;
  return $pid;
}

=head2 S<$h-E<gt>prepare($ctl)>

This method compiles the code when not yet available.

=cut

sub prepare
{ my ($slf, $ctl) = @_;

  unless ($slf->{'_typ'} eq 'X')
  { die get_string('NO_TOP') unless $slf->{'_typ'} eq 'M';
    foreach my $dep (@{$slf->{'_dep'}})
    { $dep->compile($ctl) unless $dep->is_compiled;
    }
    $slf->compile($ctl) unless $slf->is_compiled;
  }
  return;
}

=head2 S<$h-E<gt>set_warning([$typ[,$skp]])>

This method indicates that a specified warning should be ignored and the
number of additional lines to skip. When the number of lines is undefined, it
suppressed the warning type. When the type is undefined, it no longer accepts
warnings.

=cut

sub set_warning
{ my ($slf, $typ, $skp) = @_;

  if (!defined($typ))
  { delete($slf->{'_wrn'});
  }
  elsif (!defined($skp))
  { delete($slf->{'_wrn'}->{$typ});
  }
  else
  { $slf->{'_wrn'}->{$typ} = $skp;
  }
  return $slf;
}

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

# Adapt the command for VMS
sub _conv_cmd
{ my ($cmd) = @_;

  return $cmd unless $cmd;
  if (RDA::Object::Rda->is_windows)
  { $cmd =~ s{/dev/null}{NUL}g;
  }
  elsif (RDA::Object::Rda->is_unix || RDA::Object::Rda->is_cygwin)
  { $cmd = qq{exec $cmd};
  }
  elsif (RDA::Object::Rda->is_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;
}

# Find a JDK command commnad
sub _find_cmd
{ my ($slf, $ctx, $key, $cmd) = @_;
  my ($pth);

  return
    exists($ctx->{$key})            ? $ctx->{$key} :
    ($pth = _find_jdk($slf, $ctx))  ? RDA::Object::Rda->cat_file($pth,
                                        $ctx->{'BIN'}, $cmd) :
    !RDA::Object::Rda->is_unix
      ? undef :
    (-l ($pth = "/usr/bin/$cmd") ||
     -l ($pth = "/bin/$cmd"))       ? $pth :
                                      undef;
}

# Detect a JDK directory
sub _find_jdk
{ my ($slf, $ctx) = @_;
  my ($col, $dir, $pth, $sys);

  $sys = $ctx->{'Sys'};
  return $dir
    if defined($dir = $sys->test_dir('d', $slf->{'_jdk'})) ||
       (exists($ctx->{'HOME'})
         && defined($dir = $sys->test_dir('d', $ctx->{'HOME'}))) ||
       defined($dir = $sys->get_dir('JAVA_HOME')) ||
       (defined($dir = $sys->get_dir('ORACLE_HOME'))
         && -d ($dir = RDA::Object::Rda->cat_dir($dir, 'jdk')));

  $col = $ctx->{'Col'};
  foreach my $key ($col->grep('^D_ORACLE_HOME$', 'r'))
  { return $dir
      if -d ($dir = RDA::Object::Rda->cat_dir($col->get_first($key), 'jdk'));
  }
  if (defined($dir = $col->get_first('SETUP.RDA.BEGIN.D_ORACLE_PARENT'))
    && opendir(MWH, $dir))
  { foreach my $itm (readdir(MWH))
    { next unless $itm =~ m/^((jdk\d+|jrockit_\d+)[\000-\377]*)$/ &&
        -d ($pth = RDA::Object::Rda->cat_dir($dir, $1));
      closedir(MWH);
      return $pth;
    }
    closedir(MWH);
  }
  return;
}

# Check errors presence
sub _has_errors
{ my ($slf, $pth) = @_;
  my ($cnt, $ifh);

  # Report an error when no acceptable warnings are defined
  return 1 unless exists($slf->{'_wrn'});

  # Ignore specified warnings
  $ifh = IO::File->new;
  if ($ifh->open(q{<}.$pth))
  { while (<$ifh>)
    { if (m/:\d+:\s+warning:\s+\[(.+?)\]/ && exists($slf->{'_wrn'}->{$1}))
      { $cnt = $slf->{'_wrn'}->{$1};
        <$ifh> while $cnt-- > 0;
        next;
      }
      elsif (m/^(?:Note:\s|\d+\s+warning)/)
      { next;
      }
      return 1;
    }
    $ifh->close;
  }
  return 0;
}

# Check compiler option availability
sub _has_option
{ my ($slf, $ctx, $opt, $cmd, $trc) = @_;
  my ($flg, $key);

  return unless exists($tb_opt{$opt});

  if (exists($ctx->{$key = $tb_opt{$opt}}))
  { $flg = $ctx->{$key};
    debug("JAVA] -$opt enforced") if $trc && $flg;
  }
  elsif (open(CHK, _conv_cmd("$cmd -help 2>&1 |")))  ## no critic (Handle,Open)
  { debug('JAVA] Check option support') if $trc;
    foreach my $val (values(%tb_opt))
    { $ctx->{$val} = 0 unless exists($ctx->{$val});
    }
    while (<CHK>)
    { if (m/^\s+-(X|nowarn)\s/)
      { $ctx->{$tb_opt{$1}} = 1;
        debug("JAVA] => -$1 supported") if $trc;
      }
    }
    close(CHK);
    $flg = $ctx->{$key};
  }
  return $flg;
}

# --- SDCL extensions ---------------------------------------------------------

# Force a Java context
sub _begin_java
{ my ($pkg) = @_;

  $pkg->get_inline->force_context('Java');
  return;
}

# Declare a Java block
sub _exe_java
{ my ($slf, $spc) = @_;
  my ($dir, $obj);

  # Declare the block
  $obj = $spc->[$SPC_OBJ];
  $slf->get_inline->add_code($obj);
  $obj->{'_jdk'} =  ## no critic (Chain)
    $slf->get_collector->get_target->get_current->get_detail('jdk', 'jdk');

  # Indicate the successful completion
  return $CONT;
}

# Get a Java block name
sub _get_java
{ my ($slf, $spc, $str) = @_;

  $spc->[$SPC_OBJ] = $1 if $$str =~ s/^(\d+(\.\d+)?)\s+//;
  die get_string('NO_NAME') unless $$str =~ s/^([A-Za-z]\w*)\s*//;
  $spc->[$SPC_REF] = $1;
  return;
}

# Parse a Java block
sub _parse_java
{ my ($slf, $spc) = @_;

  return $slf->get_collector->get_inline->add_block($slf->get_package('oid'),
    $spc->[$SPC_OBJ] = __PACKAGE__->new($spc->[$SPC_REF], $spc->[$SPC_VAL],
      $spc->[$SPC_OBJ]));
}

1;

__END__

=head1 SEE ALSO

L<RDA::Agent|RDA::Agent>,
L<RDA::Alarm|RDA::Alarm>,
L<RDA::Object|RDA::Object>,
L<RDA::Object::Inline|RDA::Object::Inline>,
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