# Domain.pm: Class Used for Managing Oracle WebLogic Server Domains

package RDA::Target::Domain;

# $Id: Domain.pm,v 1.30 2015/05/08 18:21:28 RDA Exp $
# ARCS: $Header: /home/cvs/cvs/RDA_8/src/scripting/lib/RDA/Target/Domain.pm,v 1.30 2015/05/08 18:21:28 RDA Exp $
#
# Change History
# 20150508  MSC  Improve the documentation.

=head1 NAME

RDA::Target::Domain - Class Used for Managing Oracle WebLogic Server Domains

=head1 SYNOPSIS

 require RDA::Target::Domain;

=head1 DESCRIPTION

The objects of the C<RDA::Target::Domain> class are used to interface with
Oracle WebLogic Server domains. It is a subclass of
L<RDA::Object::Target|RDA::Object::Target>.

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::Object;
  use RDA::Object::Rda;
  use RDA::Object::Target;
  use RDA::Object::Xml;
}

# Define the global public variables
use vars qw($STRINGS $VERSION @DUMP @ISA %SDCL);
$VERSION = sprintf('%d.%02d', q$Revision: 1.30 $ =~ /(\d+)\.(\d+)/);
@DUMP    = (
  hsh => {'RDA::Target::Base'     => 1,
          'RDA::Target::Common'   => 1,
          'RDA::Target::Database' => 1,
          'RDA::Target::Db'       => 1,
          'RDA::Target::Dbi'      => 1,
          'RDA::Target::Domain'   => 1,
          'RDA::Target::Home'     => 1,
          'RDA::Target::Instance' => 1,
          'RDA::Target::MwHome'   => 1,
          'RDA::Target::System'   => 1,
          'RDA::Target::WlHome'   => 1,
         },
  );
@ISA     = qw(RDA::Object::Target RDA::Object Exporter);
%SDCL    = (
  als => {
    ## no critic (Interpolation)
    'getDomainAttr'  => ['${CUR.O_TARGET}', 'get_attr'],
    'getProductHome' => ['${CUR.O_TARGET}', 'get_product'],
    'getServer'      => ['${CUR.O_TARGET}', 'get_server'],
    'getWlstHome'    => ['${CUR.O_TARGET}', 'get_wlst'],
    'hasDomainAttr'  => ['${CUR.O_TARGET}', 'has_attr'],
    'setServer'      => ['${CUR.O_TARGET}', 'set_server'],
    },
  dep => [qw(RDA::Target::Home)],
  inc => [qw(RDA::Object::Target RDA::Object)],
  met => {
    'get_attr'    => {ret => 0},
    'get_product' => {ret => 0},
    'get_server'  => {ret => 1},
    'get_wlst'    => {ret => 1},
    'has_attr'    => {ret => 0},
    'set_product' => {ret => 0},
    'set_server'  => {ret => 0},
    },
  );

# Define the global private constants

# Define the global private variables

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

=head2 S<$h = RDA::Target::Domain-E<gt>new($oid,$col,$def,$par[,$edt])>

The object constructor. It takes the object identifier, the collector object
reference, the definition item reference, the parent target reference, and an
optional initial attribute hash reference as arguments.

Do not use this constructor directly. Create all targets using the
L<RDA::Object::Target|RDA::Object::Target> methods.

C<RDA::Target::Domain> is represented by a blessed hash reference. The
following special keys are used:

=over 12

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

=item S<    B<'dom' > > Domain home directory

=item S<    B<'jdk' > > JDK directory

=item S<    B<'nam' > > Domain name

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

=item S<    B<'par' > > Reference to the parent target

=item S<    B<'raw' > > Raw value indicator

=item S<    B<'top' > > Domain root directory

=item S<    B<'_abr'> > Symbol definition hash

=item S<    B<'_bkp'> > Backup of environment variables

=item S<    B<'_cch'> > Reference to the Common Components home target

=item S<    B<'_chg'> > Symbol change hash

=item S<    B<'_chl'> > List of the child keys

=item S<    B<'_def'> > Reference to the target definition item

=item S<    B<'_det'> > Detected home directories

=item S<    B<'_dom'> > Domain attribute hash

=item S<    B<'_env'> > Environment specifications

=item S<    B<'_fcs'> > Focus hash

=item S<    B<'_hom'> > Reference to the Oracle home target

=item S<    B<'_prs'> > Symbol detection parse tree

=item S<    B<'_shr'> > Share indicator

=item S<    B<'_srv'> > Server hash

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

=item S<    B<'_wlh'> > Reference to the Oracle WebLogic Server home target

=back

Internal keys are prefixed by an underscore.

=cut

sub new  ## no critic (Complex)
{ my ($cls, $oid, $col, $def, $par, $edt) = @_;
  my ($flg, $nam, $raw, $slf, $tgt, $val, @dir);

  # Create the Oracle WebLogic Server domain object
  $raw = $def->get_first('B_RAW', 0);
  $slf = bless {
    col  => $col,
    oid  => $par->get_unique($oid),
    par  => $par,
    raw  => $raw,
    _chl => [],
    _def => $def,
    _shr => $def->get_first(['B_DEDICATED_DOMAIN','B_DEDICATED']) ? 0 : 1,
    _fcs => {},
    _typ => 'DOM',
  }, ref($cls) || $cls;

  # Load the target definition
  $slf->{'dom'} = $val
    if defined($val = $def->get_first('D_DOMAIN_HOME', undef, $raw));
  $slf->{'nam'} = $val
    if defined($val = $def->get_first('T_DOMAIN_NAME'));
  $slf->{'top'} = $val
    if defined($val = $def->get_first('D_DOMAIN_ROOT', undef, $raw));

  # Add the initial attributes
  if ($edt)
  { foreach my $key (keys(%{$edt}))
    { $slf->{$key} = $edt->{$key};
    }
  }

  # Validate the configuration
  if (!exists($slf->{'dom'}))
  { die get_string('NO_DIR', $oid)
      unless exists($slf->{'top'}) && exists($slf->{'nam'});
    $slf->{'dom'} = RDA::Object::Rda->cat_dir($slf->{'top'}, $slf->{'nam'});
    $def->set_value('T_DOMAIN_NAME', $slf->{'nam'} = $val)
      if defined($val = $slf->get_attr('DOMAIN_NAME')) && length($val)
      && $val ne $slf->{'nam'};
  }
  else
  { if (defined($val = $slf->get_attr('DOMAIN_NAME')) && length($val))
    { if (!exists($slf->{'nam'}) || $val ne $slf->{'nam'})
      { $def->set_value('T_DOMAIN_NAME', $slf->{'nam'} = $val);
      }
    }
    elsif (!exists($slf->{'nam'}))
    { @dir = RDA::Object::Rda->split_dir(
        RDA::Object::Rda->cat_dir($slf->{'dom'}));
      die get_string('BAD_DIR', $slf->{'dom'})
        unless (scalar @dir) > 1;  ## no critic (Unless)
      $slf->{'nam'} = pop(@dir);
      $slf->{'top'} = RDA::Object::Rda->cat_native(@dir, q{})
        unless exists($slf->{'top'});
    }
    $slf->{'top'} = RDA::Object::Rda->clean_native([$slf->{'dom'},
      RDA::Object::Rda->up_dir, q{}], 1)
      unless exists($slf->{'top'});
  }
  $slf->{'dom'} = RDA::Object::Rda->short($slf->{'dom'}, 1);

  # Load the associated Oracle home target
  unless ($def->get_first('B_MISSING_HOME'))
  { if (defined($val = $def->get_first('I_ORACLE_HOME')))
    { $slf->{'_hom'} = $slf->add_target($val);
      push(@{$slf->{'_chl'}}, '_hom');
    }
    elsif (defined($val = $def->get_first('W_ORACLE_HOME')))
    { $slf->{'_hom'} = $slf->get_target($val);
      push(@{$slf->{'_chl'}}, '_hom');
    }
    elsif (defined($val = _find_home($slf, $def)))
    { if (($flg = $def->get_first('B_DEDICATED_HOME'))
        || !($tgt = $par->find_target('OH',
                                      hom => RDA::Object::Rda->native($val))))
      { $nam = $oid;
        $nam =~ s/^DOM_/OH_/i;
        $tgt = $slf->add_target($nam,
          {B_DEDICATED_HOME => $flg,
           B_RAW            => $raw,
           D_ORACLE_HOME    => $val,
           T_OH_ABBR        => $def->get_prime('T_OH_ABBR'),
          });
      }
      $slf->{'_hom'} = $tgt;
      push(@{$slf->{'_chl'}}, '_hom');
    }
  }

  # Load the associated product home targets
  unless ($def->get_first('B_MISSING_PRODUCT'))
  { foreach my $key (@{_get_item($slf, 'seq', [])})
    { $val = $slf->{'_det'}->{'hom'}->{$key};
      if (($flg = $def->get_first('B_DEDICATED_PRODUCT'))
        || !($tgt = $par->find_target('OH',
                                      hom => RDA::Object::Rda->native($val))))
      { $nam = $oid;
        $nam =~ s/^DOM_/OH_$key\_/i;
        $tgt = $slf->add_target($nam,
          {B_DEDICATED_HOME => $flg,
           B_RAW            => $raw,
           D_ORACLE_HOME    => $val,
           T_OH_ABBR        => "\$$key",
          });
      }
      $slf->{"-$key"} = $tgt;
      $slf->{'_hom'} = $tgt unless exists($slf->{'_hom'});
      push(@{$slf->{'_chl'}}, "-$key");
    }
  }

  # Load the associated Oracle WebLogic Server home target
  unless ($def->get_first('B_MISSING_WL_HOME'))
  { if (defined($val = $def->get_first('I_WL_HOME')))
    { $slf->{'_wlh'} = $slf->add_target($val);
      push(@{$slf->{'_chl'}}, '_wlh');
    }
    elsif (defined($val = $def->get_first('W_WL_HOME')))
    { $slf->{'_wlh'} = $slf->get_target($val);
      push(@{$slf->{'_chl'}}, '_wlh');
    }
    elsif (defined($val = _find_wl_home($slf, $def)))
    { if (($flg = $def->get_prime('B_DEDICATED_WL_HOME'))
        || !($tgt = $par->find_target('WH',
                                      wlh => RDA::Object::Rda->native($val))))
      { $nam = $oid;
        $nam =~ s/^DOM_/WH_/i;
        $tgt = $slf->add_target($nam,
          {B_DEDICATED_COMMON  => $def->get_prime('B_DEDICATED_OC_HOME'),
           B_DEDICATED_MW_HOME => $def->get_prime('B_DEDICATED_MW_HOME'),
           B_DEDICATED_WL_HOME => $flg,
           B_MISSING_COMMON    => $def->get_prime('B_MISSING_OC_HOME'),
           B_MISSING_MW_HOME   => $def->get_prime('B_MISSING_MW_HOME'),
           B_RAW               => $raw,
           D_COMMON_HOME       => $def->get_prime('D_COMMON_HOME'),
           D_MW_HOME           => _find_mw_home($slf, $def),
           D_WL_HOME           => $val,
           I_COMMON_HOME       => $def->get_prime('I_OC_HOME'),
           I_MW_HOME           => $def->get_prime('I_MW_HOME'),
           T_CH_ABBR           => $def->get_prime('T_OC_ABBR'),
           T_MH_ABBR           => $def->get_prime('T_MH_ABBR'),
           T_WH_ABBR           => $def->get_prime('T_WH_ABBR'),
           W_COMMON_HOME       => $def->get_prime('W_OC_HOME'),
           W_MW_HOME           => $def->get_prime('W_MW_HOME'),
          });
      }
      $slf->{'_wlh'} = $tgt;
      push(@{$slf->{'_chl'}}, '_wlh');
    }
  }

  # Load the associated Common Components home target
  unless ($def->get_first('B_MISSING_COMMON'))
  { if (defined($val = $def->get_first('I_COMMON_HOME')))
    { $slf->{'_cch'} = $slf->add_target($val);
      push(@{$slf->{'_chl'}}, '_cch');
    }
    elsif (defined($val = $def->get_first('W_COMMON_HOME')))
    { $slf->{'_cch'} = $slf->get_target($val);
      push(@{$slf->{'_chl'}}, '_cch');
    }
    elsif (defined($val = _find_common($slf, $def)))
    { if (($flg = $def->get_prime('B_DEDICATED_HOME'))
        || !($tgt = $par->find_target('CH',
                                      cch => RDA::Object::Rda->native($val))))
      { $nam = $oid;
        $nam =~ s/^DOM_/CH_/i;
        $tgt = $slf->add_target($nam,
          {B_DEDICATED_COMMON => $flg,
           B_RAW              => $raw,
           D_COMMON_HOME      => $val,
           T_CH_ABBR          => $def->get_prime('T_CH_ABBR'),
          });
      }
      $slf->{'_cch'} = $tgt;
      push(@{$slf->{'_chl'}}, '_cch');
    }
  }

  # Get the Java home
  $slf->{'jdk'} = $val if defined($val = _find_java_home($slf, $def));

  # Disable any further detection
  $slf->{'_det'} = {} unless exists($slf->{'_det'});

  # Initiate the symbol management when applicable
  unless (RDA::Object::Rda->is_vms)
  { $slf->{'_abr'} = {};
    exists($slf->{'dom'})
      ? $slf->set_symbol($def->get_first('T_DH_ABBR'),
          RDA::Object::Rda->cat_native($slf->{'top'}, $slf->{'nam'}, q{}))
      : $slf->init_symbols;
    delete($slf->{'_chg'});
  }

  # Return the object reference
  return $slf;
}

=head2 S<$h-E<gt>find_jars($typ,$src,$jdk)>

This method returns the list of C<jar> files required to connect to the
specified database.

=cut

sub find_jars
{ my ($slf, $typ, $src, $jdk) = @_;

  return $slf->{'_wlh'}->find_jars($typ, $src, $jdk) if exists($slf->{'_wlh'});
  return;
}

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

This method returns the value of the domain attributes, extracted from the
F<$D_DOMAIN_HOME/init-info/tokenValue.properties> file. When not found, it
returns the default value.

=cut

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

  # Load all attributes on first usage
  _load_attr($slf) unless exists($slf->{'_dom'});

  # Return the attribute values
  return exists($slf->{'_dom'}->{$nam})
    ? $slf->{'_dom'}->{$nam}
    : $dft;
}

sub _load_attr
{ my ($slf) = @_;
  my ($ifh, $key, $tbl, $val);

  $ifh = IO::File->new;
  $slf->{'_dom'} = $tbl = {};
  if ($ifh->open('<'.RDA::Object::Rda->cat_file($slf->{'dom'}, 'init-info',
    'tokenValue.properties')))
  { while (<$ifh>)
    { if (m/^\@(\S+?)=(.*?)[\n\r\s]*$/)
      { $key = $1;
        $val = $2;
        $val =~ s/\\(.)/$1/g;
        $tbl->{$key} = $val;
      }
    }
    $ifh->close;
  }
  return;
}

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

This method returns the environment variable specifications as a hash
reference.

=cut

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

  # Determine the environment specifications on first usage
  unless (exists($slf->{'_env'}))
  { my ($dft, $dir, $dom, $env, $lib, $sep, %tbl);

    # Get the default specifications
    $dft = exists($slf->{'_hom'})
      ? $slf->{'_hom'}
      : $slf->get_default;
    $slf->{'_env'} = $env = {%{$dft->get_env}};

    # Add common target specifications
    $dom = $slf->{'dom'};
    $env->{'DOMAIN_HOME'} = RDA::Object::Rda->short($dom);
    $env->{'LONG_DOMAIN_HOME'} = RDA::Object::Rda->native($dom);
    $env->{'MW_ORA_HOME'} = $env->{'ORACLE_HOME'}
      if exists($env->{'ORACLE_HOME'});
    $slf->{'_wlh'}->adjust_env($env) if exists($slf->{'_wlh'});

    # Add operating system specific target specifications
    unless (RDA::Object::Rda->is_vms)
    { $sep = RDA::Object::Rda->get_separator;

      # Adapt the command path
      %tbl = map {$_ => 1} split(/$sep/, $env->{'PATH'});
      $dir = RDA::Object::Rda->cat_dir($dom, 'bin');
      $env->{'PATH'} = join($sep, $dir, $env->{'PATH'})
        unless exists($tbl{$dir})  ## no critic (Unless)
            || !defined($dir = $slf->get_top('sys')->is_restricted($dir));

      # Adapt the shared library path
      if (defined($lib = RDA::Object::Rda->get_shlib))
      { %tbl = map {$_ => 1} split(/$sep/, $env->{$lib});
        $env->{$lib} = join($sep, $dir, $env->{$lib})
          if -d ($dir = RDA::Object::Rda->cat_dir($dom, 'lib'))
          && !exists($tbl{$dir});
      }
    }
  }

  # Return the environment specifications
  return $slf->{'_env'};
}

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

This method returns the product home target when defined. When an attribute
name is specified as an argument, it returns its value. When the attribute is
not found, it returns the default value.

=cut

sub get_product
{ my ($slf, $nam, $key, $dft) = @_;
  my ($prd);

  $prd = q{-}.uc($nam);
  return
    !exists($slf->{$prd})        ? $dft :
    !defined($key)               ? $slf->{$prd} :
    exists($slf->{$prd}->{$key}) ? $slf->{$prd}->{$key} :
                                   $dft;
}

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

This method returns the list of all identifiers associated to the specified
server name. By default, it returns all identifiers.

=cut

sub get_server
{ my ($slf, $nam, $src) = @_;
  my ($srv, $tbl, @dst, @src);

  $tbl = $slf->{'_srv'};

  # Determine the candidates
  if (ref($src) eq 'ARRAY')
  { foreach my $uid (@{$src})
    { push(@src, $uid) if exists($tbl->{$uid});
    }
  }
  else
  { @src = keys(%{$tbl});
  }

  # Select the identifiers
  return @src unless defined($nam);
  foreach my $uid (@src)
  { if (ref($srv = $tbl->{$uid}))
    { push(@dst, $uid) if exists($srv->{$nam});
    }
    else
    { push(@dst, $uid);
    }
  }
  return @dst;
}

=head2 S<$h-E<gt>get_wlst([$flag])>

This method returns the list of the homes containing the WebLogic Server
Scripting Tool (WLST). When the flag is set, it stops the search at the first
matching home.

=cut

sub get_wlst
{ my ($slf, $flg) = @_;
  my ($fct, @dir, %dup);

  # Get the list of detected homes
  push(@dir, $slf->{'_cch'}->{'cch'}) if exists($slf->{'_cch'});
  push(@dir, $slf->{'_hom'}->{'hom'}) if exists($slf->{'_hom'});
  push(@dir,
    map {$slf->{'_det'}->{'hom'}->{$_}} @{_get_item($slf, 'seq', [])});
  push(@dir, $slf->{'_wlh'}->{'wlh'}) if exists($slf->{'_wlh'});

  # Return directories containing WLST
  $fct = (RDA::Object::Rda->is_windows || RDA::Object::Rda->is_cygwin)
    ? \&_chk_wlst_w
    : \&_chk_wlst_u;
  return (grep {&$fct($_, \%dup)} @dir) unless $flg;
  foreach my $dir (@dir)
  { return ($dir) if &$fct($dir, \%dup);
  }
  return ();
}

sub _chk_wlst_u
{ my ($dir, $dup) = @_;
  my ($fil);

  $fil = RDA::Object::Rda->cat_file($dir, 'common', 'bin', 'wlst.sh');
  return 0 if exists($dup->{$fil});
  return $dup->{$fil} = -f $fil && -x $fil;
}

sub _chk_wlst_w
{ my ($dir, $dup) = @_;
  my ($fil);

  $fil = RDA::Object::Rda->cat_file($dir, 'common', 'bin', 'wlst.cmd');
  return 0 if exists($dup->{$fil});
  return $dup->{$fil} = (-f $fil);
}

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

This method indicates how many domain attributes are available.

=cut

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

  # Load all attributes on first usage
  _load_attr($slf) unless exists($slf->{'_dom'});

  # Indicate how many attributes are available
  return scalar keys(%{$slf->{'_dom'}});
}

=head2 S<$h-E<gt>set_product([$name])>

This method selects a product home target as Oracle home target. The argument
can be the product name or a hash reference indicating the preferences.

The hash associates a value to product names. The method selects the product
that is present and that has the highest value.

By default, it selects the first product.

It returns the previous Oracle home target or an undefined value when not
defined.

=cut

sub set_product
{ my ($slf, $nam) = @_;
  my ($key, $old, $ref);

  $old = $slf->{'_hom'} if exists($slf->{'_hom'});
  $ref = ref($nam);
  if ($ref =~ m/^RDA::Object::/)
  { $slf->{'_hom'} = $nam;
  }
  elsif ($ref eq 'HASH')
  { foreach my $itm (sort {$nam->{$b} <=> $nam->{$a}}  ## no critic (Reverse)
                          keys(%{$nam}))
    { if (exists($slf->{$key = q{-}.uc($itm)}))
      { delete($slf->{'_env'});
        $slf->{'_hom'} = $slf->{$key};
        last;
      }
    }
  }
  elsif (defined($nam))
  { if (exists($slf->{$key = q{-}.uc($nam)}))
    { delete($slf->{'_env'});
      $slf->{'_hom'} = $slf->{$key};
    }
  }
  elsif (exists($slf->{$key = q{-}._get_item($slf, 'seq', [q{}])->[0]}))
  { delete($slf->{'_env'});
    $slf->{'_hom'} = $slf->{$key};
  }
  elsif ($old)
  { delete($slf->{'_env'});
    delete($slf->{'_hom'});
  }
  return $old;
}

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

This method associates a list of server names to the specified identifier. It
discards empty server names. When no server array is specified, the
C<get_server> method will select the identifier for any server.

It returns the number of server names associated to the identifier.

=cut

sub set_server
{ my ($slf, $uid, $srv) = @_;
  my ($cnt, $tbl);

  # Validate the argument
  die get_string('BAD_SERVER') unless defined($uid) && $uid =~ m/^\w+$/;

  # Associate servers to the identifier
  return $slf->{'_srv'}->{$uid} = undef unless ref($srv) eq 'ARRAY';

  $cnt = 0;
  $slf->{'_srv'}->{$uid} = $tbl = {};
  foreach my $nam (@{$srv})
  { $tbl->{$nam} = ++$cnt if length($nam);
  }
  return $cnt;
}

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

# Find the Common Components home directory
sub _find_common
{ my ($slf, $def) = @_;

  return $def->get_prime('D_COMMON_HOME', undef, $slf->{'raw'})
    || _get_item($slf, 'com');
}

# Find the Oracle home directory
sub _find_home
{ my ($slf, $def) = @_;

  return $def->get_prime('D_ORACLE_HOME', undef, $slf->{'raw'})
    || _get_item($slf, 'ora');
}

# Find the Java home directory
sub _find_java_home
{ my ($slf, $def) = @_;

  return $def->get_prime('D_JAVA_HOME', undef, $slf->{'raw'})
    || _get_item($slf, 'jdk');
}

# Find the Oracle Middleware home directory
sub _find_mw_home
{ my ($slf, $def) = @_;
  my ($dir);

  # Check the definition
  return $dir
    if defined($dir = $def->get_prime('D_MW_HOME', undef, $slf->{'raw'}));

  # Try to detect the Oracle Middleware home directory
  return ($def->get_first('B_NO_DETECT'))
    || !defined($dir = $slf->get_attr('BEA_HOME') || !length($dir))
    ? undef
    : RDA::Object::Rda->cat_dir($dir);
}

# Find the Oracle WebLogic Server home directory
sub _find_wl_home
{ my ($slf, $def) = @_;

  # Check the definition
  return $def->get_prime('D_WL_HOME', undef, $slf->{'raw'})
    || _get_item($slf, 'wlh');
}

# Detect the domain-associated homes
sub _get_homes
{ my ($slf) = @_;
  my ($det, $key, $ifh);

  # Return the detection result when already available
  return $slf->{'_det'} if exists($slf->{'_det'});

  # Detect the associated home directories on first use
  $slf->{'_det'} = $det = {};
  _get_homes_xml($slf, $det) ||
    (RDA::Object::Rda->is_windows ? _get_homes_cmd($slf, $det) :
     RDA::Object::Rda->is_cygwin  ? _get_homes_cmd($slf, $det) :
                                    _get_homes_sh($slf, $det))
    unless $slf->{'_def'}->{'B_NO_DETECT'};
  return $det;
}

sub _get_homes_cmd
{ my ($slf, $det) = @_;
  my ($key, $ifh);

  $ifh = IO::File->new;
  if ($ifh->open('<'.RDA::Object::Rda->cat_file($slf->{'dom'}, 'bin',
    'setDomainEnv.cmd')))
  { while (<$ifh>)
    { if (m/^\s*set\s+(\w+)_ORACLE_HOME=(.*?)\s*$/)
      { push(@{$det->{'seq'}}, $key)
          unless exists($det->{'hom'}->{$key = uc($1)});
        $det->{'hom'}->{$key} = RDA::Object::Rda->cat_dir($2);
      }
      elsif (m/^\s*set\s+COMMON_COMPONENTS_HOME=(.*?)\s*$/)
      { $det->{'com'} = RDA::Object::Rda->cat_dir($1);
      }
      elsif (m/^\s*set\s+(?:MW_ORA|ORACLE)_HOME=(.*?)\s*$/)
      { $det->{'ora'} = RDA::Object::Rda->cat_dir($1);
      }
      elsif (m/^\s*set\s+WL_HOME=(.*?)\s*$/)
      { $det->{'wlh'} = RDA::Object::Rda->cat_dir($1);
      }
      elsif (m/^\s*set\s+JAVA_HOME=(.*?)\s*$/)
      { $det->{'jdk'} = RDA::Object::Rda->cat_dir($1);
        last;
      }
      elsif (m/^\s*set\s+JAVA_HOME=/)
      { last;
      }
    }
    $ifh->close;
  }
  return;
}

sub _get_homes_sh
{ my ($slf, $det) = @_;
  my ($key, $ifh);

  $ifh = IO::File->new;
  if ($ifh->open('<'.RDA::Object::Rda->cat_file($slf->{'dom'}, 'bin',
    'setDomainEnv.sh')))
  { while (<$ifh>)
    { if (m/^[^\043]*\b(\w+)_ORACLE_HOME=([\042\047])(.*?)\2\s*$/)
      { push(@{$det->{'seq'}}, $key)
          unless exists($det->{'hom'}->{$key = uc($1)});
        $det->{'hom'}->{$key} = $3;
      }
      elsif (m/^[^\043]*\b(\w+)_ORACLE_HOME=(\S+)/)
      { push(@{$det->{'seq'}}, $key)
          unless exists($det->{'hom'}->{$key = uc($1)});
        $det->{'hom'}->{$key} = $2;
      }
      elsif (m/^[^\043]*\bCOMMON_COMPONENTS_HOME=([\042\047])(.*?)\1\s*$/)
      { $det->{'com'} = $2;
      }
      elsif (m/^[^\043]*\bCOMMON_COMPONENTS_HOME=(\S+)/)
      { $det->{'com'} = $1;
      }
      elsif (m/^[^\043]*\b(?:MW_ORA|ORACLE)_HOME=([\042\047])(.*?)\1\s*$/)
      { $det->{'ora'} = $2;
      }
      elsif (m/^[^\043]*\b(?:MW_ORA|ORACLE)_HOME=(\S+)/)
      { $det->{'ora'} = $1;
      }
      elsif (m/^[^\043]*\bWL_HOME=([\042\047])(.*?)\1\s*$/)
      { $det->{'wlh'} = $2;
      }
      elsif (m/^[^\043]*\bWL_HOME=(\S+)/)
      { $det->{'wlh'} = $1;
      }
      elsif (m/^[^\043]*\bJAVA_HOME=([\042\047])(.*?)\1\s*$/)
      { $det->{'jdk'} = $2;
        last;
      }
      elsif (m/^[^\043]*\bJAVA_HOME=(\S+)/)
      { $det->{'jdk'} = $1;
        last;
      }
      elsif (m/^[^\043]*\bJAVA_HOME=/)
      { last;
      }
    }
    $ifh->close;
  }
  return;
}

sub _get_homes_xml
{ my ($slf, $det) = @_;
  my ($dir, $key, $xml);

  # Check the attributes presence
  return 0 unless defined(get_attr($slf, 'DOMAIN_NAME'));
  $det->{'wlh'} = $dir
    if defined($dir = get_attr($slf, 'WL_HOME')) && length($dir);

  # Load product homes
  ($xml) = RDA::Object::Xml->new($slf->{'col'}->get_trace('XML'))->parse_file(
    RDA::Object::Rda->cat_file($slf->{'dom'}, 'init-info', 'domain-info.xml')
    )->find('domain-info');
  return 0 unless $xml;
  $det->{'jdk'} = $dir
    if defined($dir = $xml->get_value('javahome')) && length($dir);
  foreach my $itm ($xml->find('install-comp-ref'))
  { $key = $itm->get_value('symbol');
    if ($key =~ m/_oracle_common_ORACLE_HOME$/)
    { $det->{'com'} = $dir unless exists($det->{'com'})  ## no critic (Unless)
        || !defined($dir = $itm->get_value('product_home'))
    }
    elsif ($key =~ m/_([A-Za-z]+)\d*_ORACLE_HOME$/i)
    { next if exists($det->{'hom'}->{$key = uc($1)})
        || !defined($dir = $itm->get_value('product_home'))
        || $dir =~ m/[\\\/]oracle_common$/;
      $det->{'hom'}->{$key} = $dir;
      push(@{$det->{'seq'}}, $key)
    }
  }

  # Derive an Oracle home
  if (defined($dir = get_attr($slf, 'ORACLE_HOME')) && length($dir))
  { $det->{'ora'} = $dir;
  }
  elsif (exists($det->{'seq'}))
  { $det->{'ora'} = $det->{'hom'}->{$det->{'seq'}->[0]};
  }

  # Indicate the successful completion
  return 1;
}

# Get a detected item
sub _get_item
{ my ($slf, $key, $dft) = @_;
  my ($det);

  $det = _get_homes($slf);
  return exists($det->{$key}) ? $det->{$key} : $dft;
}

1;

__END__

=head1 SEE ALSO

L<RDA::Agent|RDA::Agent>,
L<RDA::Object|RDA::Object>,
L<RDA::Object::Collect|RDA::Object::Collect>,
L<RDA::Object::Item|RDA::Object::Item>,
L<RDA::Object::Rda|RDA::Object::Rda>,
L<RDA::Object::Target|RDA::Object::Target>,
L<RDA::Object::Xml|RDA::Object::Xml>,
L<RDA::Target::Common|RDA::Target::Common>,
L<RDA::Target::Home|RDA::Target::Home>,
L<RDA::Target::MwHome|RDA::Target::MwHome>,
L<RDA::Target::WlHome|RDA::Target::WlHome>,
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