# Dbi.pm: Class Used to Access Databases with the DBI Interface

package RDA::Target::Dbi;

# $Id: Dbi.pm,v 1.16 2015/07/09 07:44:42 RDA Exp $
# ARCS: $Header: /home/cvs/cvs/RDA_8/src/scripting/lib/RDA/Target/Dbi.pm,v 1.16 2015/07/09 07:44:42 RDA Exp $
#
# Change History
# 20150708  MSC  Add own TNS_ADMIN management.

=head1 NAME

RDA::Target::Dbi - Class Used to Access Databases with the DBI Interface

=head1 SYNOPSIS

 require RDA::Target::Dbi;

=head1 DESCRIPTION

The objects of the C<RDA::Target::Dbi> class are used to access databases using
the C<Dbi> macro library. It is a subclass of
L<RDA::Object::Target|RDA::Object::Target>.

The following methods are available:

=cut

use strict;

BEGIN
{ use Exporter;
  use RDA::Text qw(get_string);
  use RDA::Object;
  use RDA::Object::Access qw($RE_EXT norm_credential);
  use RDA::Object::Rda;
  use RDA::Object::Target;
  use RDA::Target::Base;
}

# Define the global public variables
use vars qw($STRINGS $VERSION @DUMP @ISA %SDCL);
$VERSION = sprintf('%d.%02d', q$Revision: 1.16 $ =~ /(\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,
         },
  str => { pwd => 1 },
  );
@ISA     = qw(RDA::Object::Target RDA::Object Exporter);
%SDCL    = (
  dep => [qw(RDA::Target::Base
             RDA::Target::Database
             RDA::Target::Domain
             RDA::Target::Home
             RDA::Target::System)],
  inc => [qw(RDA::Object::Target RDA::Object)],
  met => {
    'get_access'    => {ret => 0},
    'get_prelim'    => {ret => 0},
    'get_sqlplus'   => {ret => 1},
    'is_fatal'      => {ret => 0},
    'is_enabled'    => {ret => 0},
    'is_tested'     => {ret => 0},
    'set_access'    => {ret => 0},
    'set_attempts'  => {ret => 0},
    'set_error'     => {ret => 0},
    'set_failures'  => {ret => 0},
    'set_prelim'    => {ret => 0},
    'set_trace'     => {ret => 0},
    },
  );

# Define the global private constants

# Define the global private variables
my %tb_nat = map {$_ => 1} qw(tns);

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

=head2 S<$h = RDA::Target::Dbi-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::Dbi> is represented by a blessed hash reference. The
following special keys are used:

=over 12

=item S<    B<'acc' > > DB access error flag (error outside result section)

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

=item S<    B<'dba' > > SYSDBA indicator

=item S<    B<'err' > > SQL error flag (error in result section)

=item S<    B<'jar' > > Optional list of required JAR files

=item S<    B<'jdb' > > JDBC specifications

=item S<    B<'jdk' > > Optional Java Development Kit directory

=item S<    B<'loc' > > Local database indicator

=item S<    B<'lvl' > > SQL output trace level

=item S<    B<'max' > > Maximum number of connection issues

=item S<    B<'not' > > Feedback note hash

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

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

=item S<    B<'pre' > > PRELIM indicator

=item S<    B<'pwd' > > User password

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

=item S<    B<'sid' > > System identifier

=item S<    B<'sql' > > SQL*Plus specifications

=item S<    B<'tns' > > TNS_ADMIN specification

=item S<    B<'try' > > Number of SQL script failures

=item S<    B<'typ' > > Data source type

=item S<    B<'usr' > > User name

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

=item S<    B<'_bas'> > Reference to the Oracle base target

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

=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<'_drv'> > Reference to the driver target

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

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

=item S<    B<'_ldb'> > Reference to the database target

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

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

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

=item S<    B<'_val'> > Validity indicator

=back

Internal keys are prefixed by an underscore.

=cut

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

  # Create the database object
  $dft = $col->get_info('dft');
  $raw = $def->get_first('B_RAW', 0);
  $slf = bless {
    acc  => $def->get_first('B_ACCESS', $dft->get_first('B_ACCESS', 0)),
    col  => $col,
    dba  => $def->get_first('B_SYSDBA', '0'),
    err  => $def->get_first('B_ERROR', $dft->get_first('B_ERROR', 0)),
    jdk  => $def->get_first('D_JDK'),
    loc  => $def->get_first('B_LOCAL', 0),
    lvl  => $col->get_trace('SQL'),
    max  => $def->get_first('N_ATTEMPTS', $dft->get_first('N_ATTEMPTS', 3)),
    not  => {},
    oid  => $par->get_unique($oid),
    par  => $par,
    pre  => $def->get_first('B_PRELIM', $dft->get_first('B_PRELIM', 0)),
    raw  => $raw,
    sid  => $def->get_first(['T_SOURCE', 'T_ORACLE_SID']),
    try  => $def->get_first('N_TRIES', 0),
    typ  => $def->get_first('T_TYPE', 'oracle'),
    usr  => $def->get_first('T_USER', '/@ AS SYSDBA'),
    _chl => [],
    _def => $def,
    _fcs => {},
    _shr => $def->get_first(['B_DEDICATED_QUERY','B_DEDICATED']) ? 0 : 1,
    _typ => 'DQ',
    _val => 1,
  }, ref($cls) || $cls;

  # Load the target definition
  $slf->{'tns'} = undef
    if $def->get_first('B_NO_TNS_ADMIN');
  $slf->{'tns'} = $val
    if defined($val = $def->get_first('D_TNS_ADMIN', undef, $raw));

  # Add the initial attributes
  if ($edt)
  { foreach my $key (keys(%{$edt}))
    { $slf->{$key} = exists($tb_nat{$key})
        ? RDA::Object::Rda->native($edt->{$key})
        : $edt->{$key};
    }
  }

  # Validate attributes
  delete($slf->{'jar'}) unless ref($slf->{'jar'}) eq 'ARRAY';
  delete($slf->{'jdk'}) unless defined($slf->{'jdk'}) && -d $slf->{'jdk'};

  # Load the JAR files
  $slf->{'jar'} = [$def->get_value('F_JAR')]
    if !exists($slf->{'jar'}) && $def->is_defined('F_JAR');

  # Load the associated driver target
  unless ($def->get_first('B_MISSING_DRIVER'))
  { if (defined($val = $def->get_first('I_DRIVER')))
    { $slf->{'_drv'} = $slf->add_target($val);
      push(@{$slf->{'_chl'}}, '_drv');
    }
    elsif (defined($val = $def->get_first('W_DRIVER')))
    { $slf->{'_drv'} = $slf->get_target($val);
      push(@{$slf->{'_chl'}}, '_drv');
    }
    elsif (defined($val = $def->get_prime('D_DOMAIN_HOME', undef, $raw)))
    { $tid = $oid;
      $tid =~ s/^DQ_/DOM_/i;
      $tgt = ($flg = $def->get_prime('B_DEDICATED_DRIVER'))
        ? undef
        : $par->find_target('DOM', dom => RDA::Object::Rda->native($val));
      $slf->{'_drv'} = $tgt || $slf->add_target($tid,
        {B_DEDICATED_DOMAIN => $flg,
         B_RAW              => $raw,
         D_DOMAIN_HOME      => $val,
         T_DH_ABBR          => $def->get_prime('T_DH_ABBR'),
        });
      push(@{$slf->{'_chl'}}, '_drv');
    }
    elsif (defined($val = $def->get_prime('D_ORACLE_HOME', undef, $raw)))
    { $tid = $oid;
      $tid =~ s/^DQ_/OH_/i;
      $tgt = ($flg = $def->get_prime('B_DEDICATED_DRIVER'))
        ? undef
        : $par->find_target('OH', hom => RDA::Object::Rda->native($val));
      $slf->{'_drv'} = $tgt || $slf->add_target($tid,
        {B_DEDICATED_HOME => $flg,
         B_RAW            => $raw,
         D_ORACLE_HOME    => $val,
         T_OH_ABBR        => $def->get_prime('T_OH_ABBR'),
        });
      push(@{$slf->{'_chl'}}, '_drv');
    }
  }

  # Initiate the symbol management when applicable
  unless (RDA::Object::Rda->is_vms)
  { $slf->{'_abr'} = {};
    $slf->init_symbols;
    delete($slf->{'_chg'});
  }

  # Return the object reference
  return $slf;
}

sub new_bad
{ my ($cls, $oid, $col, $def, $par) = @_;
  my ($dft);

  $dft = $col->get_info('dft');
  return bless {
    acc  => $dft->get_first('B_ACCESS', 0),
    col  => $col,
    dba  => 0,
    err  => $dft->get_first('B_ERROR', 0),
    jar  => [],
    loc  => 0,
    lvl  => $col->get_trace('SQL'),
    max  => 0,
    not  => {},
    oid  => $oid,
    par  => $par,
    pre  => 0,
    pwd  => q{},
    raw  => 0,
    sid  => q{},
    try  => 0,
    typ  => q{+},
    usr  => q{},
    _chl => [],
    _def => $def,
    _fcs => {},
    _shr => 0,
    _typ => 'DQ',
    _val => 0,
    }, ref($cls) || $cls;
}

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

This method returns a reference to the JDBC context.

=cut

sub find_jdbc
{ my ($slf) = @_;
  my ($jar, $jdk, $sid, $typ, %ctx);

  # Use the JDBC-specific context when available
  return $slf->{'jdb'} if exists($slf->{'jdb'});

  # Determine specific JDK directory
  if (exists($slf->{'jdk'}))
  { $ctx{'HOME'} = $jdk = $slf->{'jdk'};
  }
  elsif (exists($slf->{'_drv'}))
  { $ctx{'HOME'} = $jdk if defined($jdk = $slf->{'_drv'}->get_info('jdk'));
  }

  # Determine the required JAR files
  if (exists($slf->{'jar'}))
  { $jar = $slf->{'jar'};
  }
  elsif (exists($slf->{'_drv'}))
  { ($typ, $sid) = norm_credential($slf->{'typ'}, $slf->{'sid'});
    $jar = [$slf->{'_drv'}->find_jars($typ, $sid, $jdk)];
  }
  else
  { $jar = [];
  }

  # Create a JDBC-specific context
  return $slf->{'jdb'} = {ctx => {%ctx}, env => {}, jar => $jar};
}

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

This method returns a reference to the SQL*Plus context.

=cut

sub find_sqlplus
{ my ($slf) = @_;
  my ($env, $sql);

  # Use the database-specific context when available
  return $slf->{'sql'} if exists($slf->{'sql'});

  # Determine the SQL*Plus context
  $sql = $slf->SUPER::find_sqlplus || $slf->search_sqlplus;

  # Examine previous test results
  return $sql unless $slf->{'_def'}->get_first('B_INITIAL');

  # Create a database-specific context
  $env = {%{$sql->{'env'}}};
  $env->{'ORACLE_HOME'} = $env->{'INITIAL_HOME'};
  return $slf->{'sql'} = {cmd => $sql->{'cmd'}, env => $env, typ => 'DQ'};
}

=head2 S<$h-E<gt>get_env([$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);

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

    # Add the database specifications
    if (!$slf->{'loc'})
    { $slf->{'_env'}->{'ORACLE_SID'} = undef
        if index($slf->{'usr'}, q{@}) >= 0
        || (defined($slf->{'sid'}) && length($slf->{'sid'}));
    }
    elsif (defined($slf->{'sid'}))
    { $slf->{'_env'}->{'ORACLE_SID'} = ($slf->{'sid'} =~ $RE_EXT)
        ? undef
        : $slf->{'sid'};
    }
    $slf->{'_env'}->{'TNS_ADMIN'} = $slf->{'tns'} if exists($slf->{'tns'});
  }

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

=head1 DATABASE METHODS

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

This method increments the number of SQL script failures.

=cut

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

  return $slf->{'_def'}->set_temp('N_TRIES', ++$slf->{'try'});
}

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

This method clears the database-specific SQL*Plus context, reverting to the use
of the Oracle home in database accesses.

=cut

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

  $slf->{'_def'}->set_temp('B_INITIAL', 0);
  return delete($slf->{'sql'})
}

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

This method indicates whether access/connect errors are fatal.

=cut

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

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

This method indicates whether the C<prelim> option is set.

=cut

sub get_prelim
{ return shift->{'pre'};
}

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

This method indicates whether a SQL statement will be executed.

=cut

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

  return $slf->{'try'} < $slf->{'max'};
}

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

This method indicates whether SQL errors are fatal.

=cut

sub is_fatal
{ return shift->{'err'};
}

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

This method returns previous test result. When the flag is set and the target
is valid, it ignores any previous test.

=cut

sub is_tested
{ my ($slf, $flg) = @_;

  return ($flg && $slf->{'_val'})
    ? undef
    : $slf->{'_def'}->get_value('T_TEST');
}

=head2 S<$h-E<gt>set_access($flag)>

This method manages the access/connect error flag. When the flag is set, it
generates an error when an access/connect error is detected.

It returns the previous value of the flag.

=cut

sub set_access
{ my ($slf, $flg) = @_;

  return $slf->{'_def'}->set_temp('B_ACCESS', $slf->{'acc'} = $flg ? 1 : 0);
}

=head2 S<$h-E<gt>set_attempts($cnt)>

This method manages the maximum number of SQL execution attempts. It returns
the previous value of the counter.

=cut

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

  $cnt = 0 unless defined($cnt);
  return $slf->{'_def'}->set_temp('N_ATTEMPTS', $slf->{'max'} = $cnt);
}

=head2 S<$h-E<gt>set_error($flag)>

This method manages the SQL error flag. When the flag is set, the database
agent generates an error when a SQL error is detected.

It returns the previous value of the flag.

=cut

sub set_error
{ my ($slf, $flg) = @_;

  return $slf->{'_def'}->set_temp('B_ERROR', $slf->{'err'} = $flg ? 1 : 0);
}

=head2 S<$h-E<gt>set_failures($cnt)>

This method manages the number of SQL script failures. A negative value disables
any further database connection.

It returns the previous value of the counter.

=cut

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

  $cnt = 0 unless defined($cnt);
  return $slf->{'_def'}->set_temp('N_TRIES',
    $slf->{'try'} = ($cnt < 0) ? $slf->{'max'} : $cnt);
}

=head2 S<$h-E<gt>set_prelim($flag)>

This method controls the C<prelim> option. When the flag is set, it activates
the option. Otherwise, it removes the option.

It returns the previous status.

=cut

sub set_prelim
{ my ($slf, $flg) = @_;

  return $slf->{'_def'}->set_temp('B_PRELIM', $slf->{'pre'} = $flg ? 1 : 0);
}

=head2 S<$h-E<gt>set_test($text)>

This method stores the test result and returns the result text.

=cut

sub set_test
{ my ($slf, $txt) = @_;

  $slf->{'_def'}->set_temp('T_TEST', $txt);
  return $txt;
}

=head2 S<$h-E<gt>set_trace($flag)>

This method manages the SQL trace flag. When the flag is set, it prints all SQL
lines to the screen. It returns the previous value of the flag.

=cut

sub set_trace
{ my ($slf, $flg) = @_;

  ($slf->{'lvl'}, $flg) = ($flg, $slf->{'lvl'});
  return $flg;
}

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

This method indicates whether RDA should make an another connection test based
on the initial Oracle home.

=cut

sub test_initial
{ my ($slf) = @_;
  my ($cmd, $def, $env);

  # Determine if the test is applicable
  $def = $slf->{'_def'};
  return 0 unless $slf->{'loc'}  ## no critic (Unless)
               && !$def->is_defined('B_INITIAL');
  ($cmd, $env) = $slf->get_sqlplus;
  unless (exists($env->{'INITIAL_HOME'}))
  { $def->set_temp('B_INITIAL', 0);
    return 0;
  }

  # Prepare the database specific context
  $def->set_temp('B_INITIAL', 1);
  $env = {%{$env}};
  $env->{'ORACLE_HOME'} = delete($env->{'INITIAL_HOME'});
  $slf->{'sql'} = {cmd => $cmd, env => $env, typ => 'DQ'};
  return 1;
}

1;

__END__

=head1 SEE ALSO

L<RDA::Agent|RDA::Agent>,
L<RDA::Object|RDA::Object>,
L<RDA::Object::Access|RDA::Object::Access>,
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::Target::Base|RDA::Target::Base>,
L<RDA::Target::Database|RDA::Target::Database>,
L<RDA::Target::Domain|RDA::Target::Domain>,
L<RDA::Target::Home|RDA::Target::Home>,
L<RDA::Target::System|RDA::Target::System>,
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