# Dbd.pm: Class Used for Database Requests Using DBD

package RDA::Driver::Dbd;

# $Id: Dbd.pm,v 1.18 2015/06/06 22:53:36 RDA Exp $
# ARCS: $Header: /home/cvs/cvs/RDA_8/src/scripting/lib/RDA/Driver/Dbd.pm,v 1.18 2015/06/06 22:53:36 RDA Exp $
#
# Change History
# 20150606  MSC  Load DBD::Oracle once.

=head1 NAME

RDA::Driver::Dbd - Class Used for Database Requests Using DBD

=head1 SYNOPSIS

 require RDA::Driver::Dbd;

=head1 DESCRIPTION

The objects of the C<RDA::Driver::Dbd> class are used to interface a database
using DBD.

The timeout mechanism is only effective for UNIX systems.

The following methods are available:

=cut

use strict;

BEGIN
{ use Exporter;
  use IO::Handle;
  use RDA::Text qw(debug get_string);
  use RDA::Alarm qw(check_alarm clear_alarm set_alarm);
  use RDA::Object::Access qw($RE_EXT $RE_EZC $RE_EZD $RE_SID $RE_SVC
                             check_dsn check_sid);
  use RDA::Value::List;
  use RDA::Value::Scalar qw(new_number);
}

# Define the global public variables
use vars qw($DBD $STRINGS $VERSION @ISA);
$DBD     = undef;
$VERSION = sprintf('%d.%02d', q$Revision: 1.18 $ =~ /(\d+)\.(\d+)/);
@ISA     = qw(Exporter);

# Define the global private constants
my $ALR = '___Alarm___';
my $CUT = '___Cut___';
my $DSN = qr{^-:(=)?(.*)$};
my $OUT = qr{(ORA-01013:|timeout)}i;

## no critic (Numbered)
my $NET1 = '(DESCRIPTION = (ADDRESS = (PROTOCOL = TCP)(HOST = %s)(PORT = %s)) '
  .'(CONNECT_DATA = (SID = %s)))%s';
my $NET2 = '(DESCRIPTION = (ADDRESS = (PROTOCOL = TCP)(HOST = %s)(PORT = %s)) '
  .'(CONNECT_DATA = (SERVICE_NAME = %s)))%s';
my $NET3 = '(DESCRIPTION = (ADDRESS = (PROTOCOL = TCP)(HOST = %s)(PORT = %s)) '
  .'(CONNECT_DATA = (SERVICE_NAME = %s)'
  .'(INSTANCE_ROLE = ANY)(INSTANCE_NAME = %s)(SERVER = DEDICATED)))%s';
## use critic

# Define the global private variables
my %tb_cap = (
  LEFT       => 0x00000004,
  RIGHT      => 0x00000200,
  DAYOFMONTH => 0x00000004,
  MONTH      => 0x00000020,
  MONTHNAME  => 0x00010000,
  YEAR       => 0x00000100,
  HOUR       => 0x00000400,
  MINUTE     => 0x00000800,
  SECOND     => 0x00001000,
  );
my %tb_typ = (
  ODBC   => {dsc => 'TYPE',
             log => \&odbc_login,
             msg => qr/^\[^\]]*]{3}.*$/,
             pls => 0,
             pwd => 0,
             typ =>{'-11' => 'NUMBER',   # SQL_GUID
                    '-10' => 'LONG',     # SQL_WLONGVARCHAR
                    '-9'  => 'VARCHAR2', # SQL_WVARCHAR
                    '-8'  => 'VARCHAR2', # SQL_WCHAR
                    '-7'  => 'VARCHAR2', # SQL_BIT
                    '-6'  => 'NUMBER',   # SQL_TINYINT
                    '-5'  => 'NUMBER',   # SQL_BIGINT
                    '-4'  => 'VARCHAR2', # SQL_LONGVARBINARY
                    '-3'  => 'RAW',      # SQL_VARBINARY
                    '-2'  => 'RAW',      # SQL_BINARY
                    '-1'  => 'LONG',     # SQL_LONGVARCHAR
                    '0'   => 'VARCHAR2', # SQL_UNKNOWN_TYPE, SQL_ALL_TYPES
                    '1'   => 'CHAR',     # SQL_CHAR
                    '2'   => 'NUMBER',   # SQL_NUMERIC
                    '3'   => 'NUMBER',   # SQL_DECIMAL
                    '4'   => 'NUMBER',   # SQL_INTEGER
                    '5'   => 'NUMBER',   # SQL_SMALLINT
                    '6'   => 'NUMBER',   # SQL_FLOAT
                    '7'   => 'NUMBER',   # SQL_REAL
                    '8'   => 'NUMBER',   # SQL_DOUBLE
                    '9'   => 'DATE',     # SQL_DATETIME,SQL_DATE
                    '10'  => 'DATE',     # SQL_INTERVAL, SQL_TIME
                    '11'  => 'DATE',     # SQL_TIMESTAMP
                    '12'  => 'VARCHAR2', # SQL_VARCHAR
                    '16'  => 'BOOLEAN',  # SQL_BOOLEAN
                    '17'  => 'VARCHAR2', # SQL_UDT
                    '18'  => 'VARCHAR2', # SQL_UDT_LOCATOR
                    '19'  => 'VARCHAR2', # SQL_ROW
                    '20'  => 'VARCHAR2', # SQL_REF
                    '30'  => 'BLOB',     # SQL_BLOB
                    '31'  => 'VARCHAR2', # SQL_BLOB_LOCATOR
                    '40'  => 'CLOB',     # SQL_CLOB
                    '41'  => 'VARCHAR2', # SQL_CLOB_LOCATOR
                    '50'  => 'VARCHAR2', # SQL_ARRAY
                    '51'  => 'VARCHAR2', # SQL_ARRAY_LOCATOR
                    '55'  => 'VARCHAR2', # SQL_MULTISET
                    '56'  => 'VARCHAR2', # SQL_MULTISET_LOCATOR
                    '91'  => 'DATE',     # SQL_TYPE_DATE
                    '92'  => 'DATE',     # SQL_TYPE_TIME
                    '93'  => 'DATE',     # SQL_TYPE_TIMESTAMP
                    '94'  => 'DATE',     # SQL_TYPE_TIME_WITH_TIMEZONE
                    '95'  => 'DATE',     # SQL_TYPE_TIMESTAMP_WITH_TIMEZONE
                    '101' => 'VARCHAR2', # SQL_INTERVAL_YEAR
                    '102' => 'VARCHAR2', # SQL_INTERVAL_MONTH
                    '103' => 'VARCHAR2', # SQL_INTERVAL_DAY
                    '104' => 'VARCHAR2', # SQL_INTERVAL_HOUR
                    '105' => 'VARCHAR2', # SQL_INTERVAL_MINUTE
                    '106' => 'VARCHAR2', # SQL_INTERVAL_SECOND
                    '107' => 'VARCHAR2', # SQL_INTERVAL_YEAR_TO_MONTH
                    '108' => 'VARCHAR2', # SQL_INTERVAL_DAY_TO_HOUR
                    '109' => 'VARCHAR2', # SQL_INTERVAL_DAY_TO_MINUTE
                    '110' => 'VARCHAR2', # SQL_INTERVAL_DAY_TO_SECOND
                    '111' => 'VARCHAR2', # SQL_INTERVAL_HOUR_TO_MINUTE
                    '112' => 'VARCHAR2', # SQL_INTERVAL_HOUR_TO_SECOND
                    '113' => 'VARCHAR2', # SQL_INTERVAL_MINUTE_TO_SECOND
                    },
            },
  Oracle => {dsc => 'ora_types',
             log => \&ora_login,
             msg => qr/^((ORA|SP2)-\d{4,}):\s*(.*)/,
             pls => 1,
             pwd => 0,
             typ => {1   => 'VARCHAR2',
                     2   => 'NUMBER',
                     8   => 'LONG',
                     12  => 'DATE',
                     23  => 'RAW',
                     24  => 'LONG RAW',
                     69  => 'ROWID',
                     96  => 'CHAR',
                     100 => 'BINARY_FLOAT',
                     101 => 'BINARY_DOUBLE',
                     108 => 'User-defined',
                     111 => 'REF',
                     112 => 'CLOB',
                     113 => 'BLOB',
                     114 => 'BFILE',
                     180 => 'TIMESTAMP',
                     181 => 'TIMESTAMP WITH TIME ZONE',
                     182 => 'INTERVAL YEAR TO MONTH',
                     183 => 'INTERVAL DAY TO SECOND',
                     208 => 'UROWID',
                     231 => 'TIMESTAMP WITH LOCAL TIME ZONE',
                    },
            },
  q{?}   => {dsc => 'TYPES',
             log => \&dft_login,
             msg => qr/^\[^\]]*]{3}.*$/,
             pls => 0,
             pwd => 1,
             typ => {},
            },
  );

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

=head2 S<$h = RDA::Driver::Dbd-E<gt>new($typ,$col,$tgt)>

The object constructor. It takes the driver type, the collector and target
object references as arguments.

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

=over 12

=item S<    B<'dur' > > Remaining alarm duration

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

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

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

=item S<    B<'-con'> > Connection attributes

=item S<    B<'-dbh'> > Database handle

=item S<    B<'-def'> > Driver characteristic definition

=item S<    B<'-dft'> > Default password

=item S<    B<'-die'> > Die message

=item S<    B<'-err'> > Number of SQL request errors

=item S<    B<'-inf'> > Information required to connect and to manage passwords

=item S<    B<'-msg'> > Last error message

=item S<    B<'-nam'> > Name of the database provider

=item S<    B<'-not'> > Statistics note

=item S<    B<'-out'> > Number of SQL requests timed out

=item S<    B<'-req'> > Number of SQL requests

=item S<    B<'-skp'> > Number of SQL requests skipped

=item S<    B<'-typ'> > Driver type

=item S<    B<'-ver'> > Database version

=back

Internal keys are prefixed by a dash.

=cut

sub new
{ my ($cls, $typ, $col, $tgt) = @_;
  my ($slf);

  # Create the object
  $slf = bless {
    dur  => 0,
    lim  => check_alarm($col->get_first('DEFAULT.N_DBI_TIMEOUT', 30)),
    try  => 0,
    -agt => $col->get_agent,
    -col => $col,
    -def => $tb_typ{exists($tb_typ{$typ}) ? $typ : q{?}},
    -dft => $col->is_isolated ? q{?} : undef,
    -err => 0,
    -out => 0,
    -req => 0,
    -skp => 0,
    -tgt => $tgt,
    -typ => $typ,
    }, ref($cls) || $cls;

  # Set the connection properties
  $slf->{'-con'} = {
    LongReadLen => 1024,
    LongTruncOk => 1,
    RaiseError  => 0,
    };
  $slf->{'-con'}->{'ReadOnly'} = 1
    unless $DBI::VERSION < 1.55;  ## no critic (Explicit,Number,Unless)
  $slf->{'-con'}->{'TraceLevel'} = $tgt->get_level
    unless $DBI::VERSION < 1.21;  ## no critic (Explicit,Number,Unless)

  # Determine the login information
  eval {$slf->{'-inf'} = &{$slf->{'-def'}->{'log'}}($slf, $tgt)};
  if ($@)
  { $slf->{'-msg'} = $slf->{'-die'} = $@;
    $tgt->set_failures(-1);
  }

  # Return the object reference
  return $slf;
}

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

This method deletes the object.

=cut

sub delete_object
{ disconnect($_[0]);
  undef %{$_[0]};
  undef $_[0];
  return;
}

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

This method resets the object for its new environment to allow a thread-save
execution.

=cut

sub reset  ## no critic (Builtin)
{ my ($slf) = @_;

  return;
}

=head1 OBJECT METHODS

=head2 S<$h-E<gt>connect($ctx[,$lim[,$inc]])>

This method connects to the database.

=cut

sub connect  ## no critic (Builtin)
{ my ($slf, $ctx, $lim, $inc) = @_;

  # Abort when the number of tries have been reached
  ++$slf->{'-req'};
  if (exists($slf->{'-die'}))
  { $slf->{'-msg'} = $slf->{'-die'};
    ++$slf->{'-skp'};
    return;
  }
  unless ($slf->{'-tgt'}->is_enabled)
  { $slf->{'-msg'} = get_string('DISABLED');
    ++$slf->{'-skp'};
    return;
  }

  # Delete the previous message
  delete($slf->{'-msg'});

  # Connect on the first call
  unless (exists($slf->{'-dbh'}))
  { my ($acc, $err, $flg, $grp, $pwd, $sid, $txt, $typ, $usr);

    # Get the target information
    ($typ, $grp, $usr, $txt, $sid) = @{$slf->{'-inf'}};

    # Get the password
    $acc = $ctx->get_access;
    $flg = $slf->{'-def'}->{'pwd'};
    if ($flg < 0)
    { $pwd = $acc->return_password($typ, $grp, $usr);
    }
    else
    { $pwd = $acc->obtain_password($typ, $grp, $usr, $lim, $txt,
        $slf->{'-dft'});
      die get_string('NO_PASSWORD')
        unless defined($pwd) || $flg;
    }

    # Connect to the database
    unless (defined($slf->{'-dbh'} =
      DBI->connect('dbi:'.$slf->{'-typ'}.q{:}.$sid,  ## no critic (Explicit)
        $usr, $pwd, $slf->{'-con'})))
    { $err = $DBI::errstr;  ## no critic (Explicit,Var)
      $err =~ s/[\n\r\s]+$//;
      $slf->{'-msg'} = $err;
      ++$slf->{'-err'};
      $err =~ $tb_typ{$slf->{'-typ'}}->{'msg'};
      die get_string('SQL_ERROR', "$3 ($1)")  ## no critic (Capture)
        if $slf->{'-tgt'}->get_access;
      return;
    }
  }

  # Set timeout
  $slf->{'-dbh'}->{'odbc_query_timeout'} = $slf->get_alarm($inc)
    if $slf->{'-typ'} eq 'ODBC' && defined($slf->{'-dbh'});

  # Return the database handle
  return $slf->{'-dbh'};
}

=head2 S<$h-E<gt>describe($ctx,$obj)>

This method returns a hash describing the specified table or view.

=cut

sub describe
{ my ($slf, $ctx, $obj) = @_;
  my ($cur, $dbh, $dsc, $err, $lim, $nam, $nul, $off, $sth, $tbl, $typ);

  $dsc = {row => [], typ => {}};
  $lim = ($slf->{'-typ'} eq 'ODBC') ? 0 : $slf->get_alarm;
  eval {
    local $SIG{'__WARN__'} = sub {};
    local $SIG{'ALRM'}     = sub { die "$ALR\n" } if $lim;

    set_alarm($lim) if $lim;
    eval {
      if (($dbh = $slf->connect($ctx, $lim))
        && ($sth = $dbh->prepare("SELECT * FROM $obj")))
      { $nam = $sth->{'NAME'};
        $nul = $sth->{'NULLABLE'};
        $typ = $sth->{$slf->{'-def'}->{'dsc'}};
        $tbl = $slf->{'-def'}->{'typ'};
        $off = $sth->{'NUM_OF_FIELDS'};
        while ($off > 0)
        { $cur = lc($nam->[--$off]);
          unshift(@{$dsc->{'row'}}, $cur);
          $dsc->{'nul'}->{$cur} = $nul->[$off] ? 1 : 0;
          $dsc->{'typ'}->{$cur} = uc($tbl->{$typ->[$off]} || $typ->[$off]);
        }
        $sth->finish;
      }
      };
    clear_alarm() if $lim;
    die $@ if $@;
    };

  # Detect and treat interrupts
  if ($err = $@)
  { unless ($err =~ m/^$ALR\n/ || $err =~ $OUT)
    { ++$slf->{'-err'};
      die $err;
    }
    $slf->_log_timeout($ctx, $slf->{'-tgt'}, "DESC $obj");
  }

  # Return the object description
  return $dsc;
}

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

This method disconnects from the database.

=cut

sub disconnect
{ my ($dbh);

  $dbh->disconnect if ($dbh = delete(shift->{'-dbh'}));
  return;
}

=head2 S<$h-E<gt>execute($ctx,$job,$inc,$fct,$arg)>

This method executes a database job.

=cut

sub execute  ## no critic (Complex)
{ my ($slf, $ctx, $job, $inc, $fct, $arg) = @_;
  my ($dbh, $err, $flg, $lim, $lin, $lng, $row, $sth, $tag, $tgt, $trc, @job);

  # Abort when job is missing or when the number of tries have been reached
  unless ($job)
  { $slf->{'-msg'} = get_string('NO_SQL');
    ++$slf->{'-req'};
    ++$slf->{'-err'};
    return 0;
  }
  $tgt = $slf->{'-tgt'};
  unless ($tgt->is_enabled)
  { $slf->{'-msg'} = get_string('DISABLED');
    ++$slf->{'-req'};
    ++$slf->{'-skp'};
    return 0;
  }

  # Execute the job
  if ($trc = $tgt->get_level)
  { for (split(/\n/, $job))
    { debug('SQL: ', $_);
    }
  }
  $flg = 1;
  $lim = ($slf->{'-typ'} eq 'ODBC') ? 0 : $slf->get_alarm($inc);
  @job = split(/\n/, $job);
  eval {
    local $SIG{'ALRM'}     = sub { die "$ALR\n" } if $lim;
    local $SIG{'__WARN__'} = sub {};

    set_alarm($lim) if $lim;
    eval {
      if ($dbh = $slf->connect($ctx, $lim, $inc))
      { while (defined($lin = shift(@job)))
        { $tag = q{};
          if ($lin =~ m/^#\s*(SQL\d*)\s*$/)
          { my (@row, @sql);

            $tag = $1;
            push(@sql, $lin) while defined($lin = shift(@job)) && $lin ne q{/};
            next unless @sql;
            unless (($sth = $dbh->prepare(join(qq{\n}, @sql))) && $sth->execute)
            { $row = $DBI::errstr;  ## no critic (Explicit,Var)
              $row =~ s/[\n\r\s]+$//;
              die "$ALR\n" if $row =~ $OUT;
              if ($flg)
              { last if &$fct($slf, $arg, 'ERROR in SQL request:');
                last if &$fct($slf, $arg, $row);
                next;
              }
              die get_string('SQL_ERROR', $row) if $tgt->get_access;
              $slf->{'-msg'} = $row;
              last;
            }
            while (@row = $sth->fetchrow_array)
            { $row = join(q{|}, @row);
              debug('SQL> ', $row) if $trc;
              if ($row =~ $CUT)
              { $flg = !$flg;
              }
              elsif ($flg)
              { if ($row =~ m/^\[\[\[\012(.*)\012\]\]\]$/s)
                { $row = $1;
                  $row =~ s/[\n\r]//gs;
                }
                last if &$fct($slf, $arg, $row);
              }
            }
            $sth->finish;
          }
          elsif ($lin =~ m/^#\s*(PLSQL\d*)\s*$/)
          { my ($buf, $cat, @sql);

            die get_string('NO_PLSQL')
              unless $tb_typ{$slf->{'-typ'}}->{'pls'};
            $tag = $1;
            push(@sql, $lin) while defined($lin = shift(@job)) && $lin ne q{/};
            next unless @sql;
            $dbh->func(1000000, 'dbms_output_enable');
            unless (($sth = $dbh->prepare(join(qq{\n}, @sql))) && $sth->execute)
            { $row = $DBI::errstr;  ## no critic (Explicit,Var)
              $row =~ s/[\n\r\s]+$//;
              if ($flg)
              { last if &$fct($slf, $arg, 'ERROR in PL/SQL request:');
                last if &$fct($slf, $arg, $row);
                next;
              }
              die get_string('SQL_ERROR', $row) if $tgt->get_access;
              $slf->{'-msg'} = $row;
              last;
            }
            $cat = 0;
            foreach my $res ($dbh->func('dbms_output_get'))
            { debug('SQL> ', $res) if $trc;
              if ($res =~ $CUT)
              { $flg = !$flg;
              }
              elsif ($flg)
              { if ($cat)
                { if ($res =~ m/^\]\]\]$/)
                  { last if &$fct($slf, $arg, $buf);
                    $cat = 0;
                  }
                  else
                  { $buf .= $res;
                  }
                }
                elsif ($res =~ m/^\[\[\[$/)
                { $buf = q{};
                  $cat = 1;
                }
                elsif ($res =~ m/^\[\[\[\012(.*)\012\]\]\]$/s)
                { $buf = $1;
                  $buf =~ s/[\n\r]//gs;
                  last if &$fct($slf, $arg, $buf);
                }
                else
                { last if &$fct($slf, $arg, $res);
                }
              }
            }
            $sth->finish;
          }
          elsif ($lin =~ m/^#\s*MACRO\s+((caller:)?\w+)\((\d+)\)\s*$/)
          { &$fct($slf, $arg, "___Macro_$1($3)___") if $flg;
          }
          elsif ($lin =~ m/^#\s*CUT\s*$/)
          { $flg = !$flg;
          }
          elsif ($lin =~ m/^#\s*CALL\s+(caller:)?(\w+)\((\d+)\)\s*$/)
          { my ($blk, $val);

            $blk = $1 ? $ctx->get_current : $ctx;
            $val = new_number($3);
            $val = RDA::Value::List->new($val);
            $val = $blk->define_operator([$2, '.macro.'], $blk, $2, $val);
            $val->eval_value;
          }
          elsif ($lin =~ m/^#\s*CAPTURE\s+ONLY\s+(\w+)\s*$/)
          { &$fct($slf, $arg, "___Capture_Only_$1___") if $flg;
          }
          elsif ($lin =~ m/^#\s*CAPTURE\s+(\w+)\s*$/)
          { &$fct($slf, $arg, "___Capture_$1___") if $flg;
          }
          elsif ($lin =~ m/^#\s*ECHO(\s+(.*))?$/)
          { &$fct($slf, $arg, $2) if $flg && defined($1);
          }
          elsif ($lin =~ m/^#\s*END\s*$/)
          { &$fct($slf, $arg, '___End_Capture___') if $flg;
          }
          elsif ($lin =~ m/^#\s*(EXIT|QUIT)\s*$/)
          { $slf->disconnect;
            last;
          }
          elsif ($lin =~ m/^#\s*LONG\((\d+)\)\s*$/)
          { $dbh->{'LongReadLen'} = $1;
            $lng = 1;
          }
          elsif ($lin =~ m/^#\s*SLEEP\((\d+)\)\s*$/)
          { sleep($1);
          }
        }
      }
      else
      { $row = $DBI::errstr;  ## no critic (Explicit,Var)
        $row =~ s/[\n\r\s]+$//;
        die get_string('SQL_ERROR', $row) if $tgt->get_access;
        $slf->{'-msg'} = $row;
      }
      };
    clear_alarm() if $lim;
    die $@ if $@;
    };
  $dbh->{'LongReadLen'} = 1024 if $lng;

  # Detect and treat interrupts
  if ($err = $@)
  { unless ($err =~ m/^$ALR\n/)
    { ++$slf->{'-err'};
      die $err;
    }
    $slf->_log_timeout($ctx, $tgt, $tag);
  }

  # Terminate the output treatment
  return exists($slf->{'-msg'}) ? 0 : 1;
}

=head2 S<$h-E<gt>get_alarm($val)>

This method returns 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;
}
*use_alarm = \&get_alarm;

=head2 S<$h-E<gt>get_date_fmt($fct)>

This method returns the date format using the specified concatenation function.

=cut

sub get_date_fmt
{ my ($slf, $fct) = @_;
  my ($cap, $str);

  # Test the function availability
  ## no critic (Bit);
  return '%s' unless ($cap = $slf->{'-dbh'}->get_info(50))
    && ($cap & $tb_cap{'LEFT'})
    && ($cap & $tb_cap{'RIGHT'})
    && ($cap = $slf->{'-dbh'}->get_info(52))
    && ($cap & $tb_cap{'DAYOFMONTH'})
    && ($cap & $tb_cap{'MONTH'})
    && ($cap & $tb_cap{'YEAR'})
    && ($cap & $tb_cap{'HOUR'})
    && ($cap & $tb_cap{'MINUTE'})
    && ($cap & $tb_cap{'SECOND'});

  # Return the date format
  $str = ($cap & $tb_cap{'MONTHNAME'})
    ? '{fn LEFT({fn MONTHNAME(%s)},3)}'
    : '{fn RIGHT('.&$fct('\'0\'', '{fn MONTH(%s)}').',2)}';
  return &$fct('{fn RIGHT('.&$fct('\'0\'',
    '{fn DAYOFMONTH(%s)}').',2)}', '\'-\'', $str, '\'-\'',
    '{fn RIGHT('.&$fct('\'000\'', '{fn YEAR(%s)}').',4)}', '\' \'',
    '{fn RIGHT('.&$fct('\'0\'', '{fn HOUR(%s)}').',2)}', '\':\'',
    '{fn RIGHT('.&$fct('\'0\'', '{fn MINUTE(%s)}').',2)}', '\':\'',
    '{fn RIGHT('.&$fct('\'0\'', '{fn SECOND(%s)}').',2)}');
}

=head2 S<$h-E<gt>get_dialects($ctx)>

This method returns the list of the dialects that this interface understands.

=cut

sub get_dialects
{ my ($slf, $ctx) = @_;
  my (@tbl);

  push(@tbl, lc($slf->{'-nam'})) if $slf->get_provider($ctx);
  push(@tbl, 'odbc')             if $slf->{'-typ'} eq 'ODBC';
  return (@tbl, q{?});
}

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

This method returns the elements to manage the user password and to connect to
the database. The result list contains the credential type, the system
identifier, the user name, the connection suffix, and the target context.

=cut

sub get_connection
{ return shift->{'-inf'};
}

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

This method returns the error message of the last SQL execution. If no error is
detected, it returns C<undef>.

=cut

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

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

=head2 S<$h-E<gt>get_provider($ctx)>

This method returns the name of the database provider. It returns an undefined
value in case of problems.

=cut

sub get_provider
{ my ($slf, $ctx) = @_;

  unless (exists($slf->{'-nam'}))
  { my ($dbh, $err, $lim);

    # Execute the request
    $lim = ($slf->{'-typ'} eq 'ODBC') ? 0 : $slf->get_alarm;
    eval {
      local $SIG{'__WARN__'} = sub {};
      local $SIG{'ALRM'}     = sub { die "$ALR\n" } if $lim;

      set_alarm($lim) if $lim;
      eval {
        $slf->{'-nam'} = $dbh->get_info(17)
          if ($dbh = $slf->connect($ctx, $lim));
        };
      clear_alarm() if $lim;
      die $@ if $@;
      };

    # Detect and treat interrupts
    if ($err = $@)
    { unless ($err =~ m/^$ALR\n/ || $err =~ $OUT)
      { ++$slf->{'-err'};
        die $err;
      }
      $slf->_log_timeout($ctx, $slf->{'-tgt'}, 'DBprovider');
      return;
    }
  }
  return $slf->{'-nam'};
}

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

This method returns the list of the available data sources.

=cut

sub get_sources
{ my ($slf) = @_;
  my ($nam, %tbl);

  eval {
    foreach my $src (DBI->data_sources($slf->{'-typ'}))  ## no critic (Explicit)
    { (undef, undef, $nam) = split(/:/, $src, 3);
      $tbl{$nam} = 1;
    }
    };
  return (sort keys(%tbl));
}

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

This method returns the definition target.

=cut

sub get_target
{ return shift->{'-tgt'};
}

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

This method returns the current duration of the SQL timeout. If this mechanism
is disabled, it returns 0.

=cut

sub get_timeout
{ return shift->{'lim'};
}

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

This method returns the current usage and resets the counters.

=cut

sub get_usage
{ my ($slf) = @_;
  my ($rec, $str);

  # Consolidate the usage
  $rec = {};
  $rec->{'req'} += $slf->{'-req'};
  $rec->{'err'} += $slf->{'-err'};
  $rec->{'out'} += $slf->{'-out'};
  $rec->{'skp'} += $slf->{'-skp'};
  $rec->{'lim'} = $slf->{'lim'};
  $rec->{'not'} = $str if defined($str = delete($slf->{'-not'}));

  # Reset the usage
  $slf->{'-req'} = $slf->{'-err'} = $slf->{'-out'} = $slf->{'-skp'} = 0;

  # Return the usage
  return $rec;
}

=head2 S<$h-E<gt>get_version($ctx)>

This method returns the database version. It returns an undefined value in case
of problems.

=cut

sub get_version
{ my ($slf, $ctx) = @_;

  unless (exists($slf->{'-ver'}))
  { my ($dbh, $err, $lim);

    # Execute the request
    $lim = ($slf->{'-typ'} eq 'ODBC') ? 0 : $slf->get_alarm;
    eval {
      local $SIG{'__WARN__'} = sub {};
      local $SIG{'ALRM'}     = sub { die "$ALR\n" } if $lim;

      set_alarm($lim) if $lim;
      eval {
        $slf->{'-ver'} = $dbh->get_info(18)
          if ($dbh = $slf->connect($ctx, $lim));
        };
      clear_alarm() if $lim;
      die $@ if $@;
      };

    # Detect and treat interrupts
    if ($err = $@)
    { unless ($err =~ m/^$ALR\n/ || $err =~ $OUT)
      { ++$slf->{'-err'};
        die $err;
      }
      $slf->_log_timeout($ctx, $slf->{'-tgt'}, 'DBversion');
      return;
    }
  }
  return $slf->{'-ver'};
}

=head2 S<reset_timeout([$inc])>

This method resets the remaining alarm time to the SQL timeout value. To allow
more time for executing statements, you can specify a factor as an argument. 1
is the default. For a positive value, the maximum execution time is obtained by
multiplying the SQL timeout value by this factor. Otherwise, it disables the
alarm mechanism.

The effective value is returned.

=cut

sub reset_timeout
{ my ($slf, $inc) = @_;
  my ($lim);

  $lim = $slf->get_alarm($inc);
  $slf->{'-dbh'}->{'odbc_query_timeout'} = $slf->{'lim'}
    if defined($inc) && $slf->{'-typ'} eq 'ODBC'
    && exists($slf->{'-dbh'}) && defined($slf->{'-dbh'});
  return $slf->{'dur'} = $lim;
}

=head2 S<$h-E<gt>set_timeout($sec)>

This method sets the SQL timeout, specified in seconds, only if the value is
greater than zero. Otherwise, the timeout mechanism is disabled. It is disabled
also if the alarm function is not implemented.

It returns the effective value.

=cut

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

  $lim = check_alarm($val);
  $slf->{'-dbh'}->{'odbc_query_timeout'} = $lim
    if $slf->{'-typ'} eq 'ODBC'
    && exists($slf->{'-dbh'}) && defined($slf->{'-dbh'});
  return $slf->{'lim'} = $lim;
}

=head2 S<$h-E<gt>test($ctx)>

This method tests the database connection. In case of problems, further access
is disabled.

=cut

sub test
{ my ($slf, $ctx) = @_;
  my ($dbh, $flg, $lim, $tgt);

  return $slf->{'-msg'} = $slf->{'-die'} if exists($slf->{'-die'});

  $tgt = $slf->{'-tgt'};
  $tgt->set_failures(0);
  delete($slf->{'-not'});

  # Execute the request
  $lim = ($slf->{'-typ'} eq 'ODBC') ? 0 : $slf->get_alarm;
  $flg = 1;
  eval {
    local $SIG{'__WARN__'} = sub {};
    local $SIG{'ALRM'}     = sub { die "$ALR\n" } if $lim;

    set_alarm($lim) if $lim;
    eval {
      if ($dbh = $slf->connect($ctx, $lim))
      { if ($dbh->ping)
        { $flg = 0;
        }
        else
        { $slf->{'-msg'} = $DBI::errstr;  ## no critic (Explicit,Var)
          $slf->{'-msg'} =~ s/[\n\r\s]+$//;
          $dbh->disconnect;
        }
      }
      };
    clear_alarm() if $lim;
    die $@ if $@;
    };
  return $tgt->set_test(q{}) unless $@ || $flg;

  # Detect and treat interrupts
  _log_timeout($slf, $ctx, $tgt, 'Test') if $@ =~ m/^$ALR\n/;
  ++$slf->{'-err'};
  $slf->{'-not'} = get_string('NoAccess');

  # Disable further access to the database in case of problems
  $tgt->set_failures(-1);
  return $tgt->set_test(get_string('NO_CONNECTION'));
}

=head2 S<$h-E<gt>use_alarm($val)>

This method indicates whether the driver uses C<alarm> calls for the current
context.

=cut

# --- Default-specific methods ------------------------------------------------

sub dft_login
{ my ($slf, $tgt) = @_;
  my ($pwd, $sid, $txt, $typ, $usr) = @_;

  $typ = lc($slf->{'-typ'});

  # Get the target information
  $pwd = $tgt->get_info('pwd');
  $sid = $tgt->get_info('sid');
  $usr = $tgt->get_info('usr');

  # Store provided password
  if (defined($pwd))
  { $slf->{'-col'}->get_access->set_password($typ, $sid, $usr, $pwd);
  }
  elsif (length($usr))
  { $txt = (defined($sid) && length($sid))
      ? get_string('PasswordAt', $usr, $sid)
      : get_string('Password', $usr);
  }

  # Return the target information
  return [$typ, $sid, $usr, $txt, $sid];
}

# --- ODBC-specific methods -------------------------------------------------

sub odbc_login
{ my ($slf, $tgt) = @_;
  my ($dsn, $pwd, $txt, $usr);

  # Get the target information
  $dsn = $tgt->get_info('sid');
  $pwd = $tgt->get_info('pwd');
  $usr = $tgt->get_info('usr');

  # Determine the login information
  if (defined($usr))
  { ($usr, $dsn) = ($1, $2) if $usr =~ m/^(.*)\@(.*)$/;
    ($usr, $pwd) = ($1, $2) if $usr =~ m/^(.*?)\/(.*)$/;
  }
  else
  { $usr = $pwd = q{};
  }
  die get_string('NO_DSN') unless $dsn;
  $dsn = check_dsn($dsn);

  # Store provided password
  if (defined($pwd))
  { $slf->{'-col'}->get_access->set_password('odbc', $dsn, $usr, $pwd);
  }
  elsif (length($usr))
  { $txt = get_string('PasswordAt', $usr, $dsn);
  }

  # Return the target information
  return ['odbc', $dsn, $usr, $txt, $dsn];
}

# --- Oracle-specific methods -------------------------------------------------

sub ora_login  ## no critic (Complex)
{ my ($slf, $tgt) = @_;
  my ($env, $grp, $loc, $mod, $pwd, $sid, $str, $suf, $txt, $usr);

  # Load the Oracle driver
  if (defined($DBD))
  {die $DBD if $DBD;
  }
  else
  {eval {require DBD::Oracle};
   die $DBD if ($DBD = $@)
  }

  # Get the target information
  $grp =
    check_sid($slf->{'-col'}->get_agent->get_env('ORACLE_SID', q{}));
  $loc = $tgt->get_info('loc');
  $mod = $tgt->get_info('dba') ? 2 : 0;
  $pwd = $tgt->get_info('pwd');
  $sid = $tgt->get_info('sid');
  $usr = $tgt->get_info('usr');

  # Determine the user
  $env = $sid;
  $str = $suf = q{};
  if ($usr =~ m/^(.*)\@(\S+)(.*?)\s*$/i)
  { ($usr, $sid, $suf)= ($1, $2, $3);
    $mod = ($suf =~ s/\s+as\s+sysdba$//i)  ? 2 :
           ($suf =~ s/\s+as\s+sysoper$//i) ? 4 :
                                             $mod;
    if (!defined($env) || $sid ne $env || !$loc)
    { $env = undef;
      $grp = check_sid($sid);
      $str = "\@$grp$suf";
      $loc = 0;
    }
    else
    { $str = $suf;
    }
  }
  elsif ($usr =~ m/^(.*)\@(.*)$/)
  { ($usr, $suf) = ($1, $2);
    $mod = ($suf =~ s/\s+as\s+sysdba$//i)  ? 2 :
           ($suf =~ s/\s+as\s+sysoper$//i) ? 4 :
                                             $mod;
    $str = $suf;
  }
  ## no critic (Numbered)
  $sid = !defined($sid)    ? q{} :
         ($sid =~ $RE_EZC) ? sprintf($NET2, $2, $3,  uc($4), q{}) :
         ($sid =~ $RE_EZD) ? sprintf($NET2, $2, 1521, uc($3), q{}) :
         ($sid =~ $RE_SID) ? sprintf($NET1, $1, $2, uc($3), q{}) :
         ($sid =~ $RE_SVC) ? (length($3)
                               ? sprintf($NET3, $1, $2, uc($4), $3, q{})
                               : sprintf($NET2, $1, $2, uc($4), q{})) :
         ($loc)            ? q{} :
                             uc($sid);
  ## use critic

  $pwd = $1 if $usr =~ s/\/(.*?)[\n\r]*$// && length($1);
  $usr = uc($usr);

  unless ($DBD::Oracle::VERSION < 1.03)  ## no critic (Number,Unless)
  { if ($mod)
    { $slf->{'-con'}->{'ora_session_mode'} = $mod;
      $str .= ' as SYSDBA'  if $mod == 2;
      $str .= ' as SYSOPER' if $mod == 4;
    }
    unless ($DBD::Oracle::VERSION < 1.20)  ## no critic (Number,Unless)
    { $slf->{'-con'}->{'ora_charset'} = 'AL32UTF8';
      $slf->{'-con'}->{'ora_envhp'}   = 0;
    }
  }

  # Store provided password
  $grp = check_sid($env) if defined($env);
  if (defined($pwd))
  { $slf->{'-col'}->get_access->set_password('oracle', $grp, $usr, $pwd);
  }
  elsif (length($usr))
  { $txt = defined($env)
      ? get_string('PasswordAt', $usr.$str, $env)
      : get_string('Password', $usr.$str);
  }

  # Return the target information
  return ['oracle', $grp, $usr, $txt, $sid];
}

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

# Log a timeout event
sub _log_timeout
{ my ($slf, $ctx, $tgt, @arg) = @_;

  $tgt->add_failure;
  $slf->{'-col'}->log_timeout($ctx, 'SQL', @arg);
  $slf->{'-msg'} = get_string('TIMEOUT');
  return ++$slf->{'-out'};
}

1;

__END__

=head1 SEE ALSO

L<RDA::Agent|RDA::Agent>,
L<RDA::Alarm|RDA::Alarm>,
L<RDA::Library::Dbi|RDA::Library::Dbi>,
L<RDA::Object::Access|RDA::Object::Access>,
L<RDA::Object::Collect|RDA::Object::Collect>,
L<RDA::Object::Target|RDA::Object::Target>,
L<RDA::SDCL::Block|RDA::SDCL::Block>,
L<RDA::Target::Base|RDA::Target::Base>,
L<RDA::Target::Database|RDA::Target::Database>,
L<RDA::Target::Dbi|RDA::Target::Dbi>,
L<RDA::Target::Home|RDA::Target::Home>,
L<RDA::Text|RDA::Text>,
L<RDA::Value::List|RDA::Value::List>,
L<RDA::Value::Scalar|RDA::Value::Scalar>

=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