# Jdbc.pm: Class Used for Database Requests Using JDBC

package RDA::Driver::Jdbc;

# $Id: Jdbc.pm,v 1.21 2015/07/09 08:11:06 RDA Exp $
# ARCS: $Header: /home/cvs/cvs/RDA_8/src/scripting/lib/RDA/Driver/Jdbc.pm,v 1.21 2015/07/09 08:11:06 RDA Exp $
#
# Change History
# 20150708  MSC  Add own TNS_ADMIN management.

=head1 NAME

RDA::Driver::Jdbc - Class Used for Database Requests Using JDBC

=head1 SYNOPSIS

 require RDA::Driver::Jdbc;

=head1 DESCRIPTION

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

The timeout mechanism is only effective for UNIX systems.

The following methods are available:

=cut

use strict;

BEGIN
{ use Exporter;
  use IO::Handle;
  use IO::File;
  use RDA::Text qw(debug get_string);
  use RDA::Object::Access qw(norm_credential);
  use RDA::Object::Java;
  use RDA::Object::Rda;
  use RDA::Value::List;
  use RDA::Value::Scalar qw(new_number);
}

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

# Define the JDBC interface
my $NAM = 'RdaJdbc';
my $VER = '1.3';
my $COD = <<EOF;  ## no critic (Quoted)
import java.io.*;
import java.lang.*;
import java.sql.*;
import java.util.*;
import java.util.regex.*;

class $NAM
{// Define the common variables
 private static Connection dbh;  // Connection handle

 // Define the common constants
 private final static String DBA = "DBA";
 private final static String DRV = "DRV";
 private final static String EOL = System.getProperty("line.separator");
 private final static String LIM = "LIM";
 private final static String PWD = "PWD";
 private final static String TNS = "TNS";
 private final static String URL = "URL";
 private final static String USR = "USR";
 private final static String WRK = "WRK";

 // Default constructor
 public $NAM()
 {
 }

 // Disconnect from the database
 private static boolean disconnect()
 {try
  {dbh.close();
  }
  catch (Exception err)
  {
  }
  return true;
 }

 // Execute a CONNECT request
 private static boolean doConnect(PrintStream ofh, Hashtable ctx)
 {try
  {if (ctx.containsKey(LIM))
   {Integer lim = new Integer((String) ctx.get(LIM));
    DriverManager.setLoginTimeout(lim.intValue());
   }
   if (ctx.containsKey(TNS))
    System.setProperty("oracle.net.tns_admin", (String) ctx.get(TNS));
   DriverManager.registerDriver(
     ((java.sql.Driver) Class.forName((String) ctx.get(DRV)).newInstance()));
   Properties prp = new Properties();
   prp.put("user", (String) ctx.get(USR));
   prp.put("password", (String) ctx.get(PWD));
   if (ctx.containsKey(DBA))
    prp.put("internal_logon", (String) ctx.get(DBA));
   dbh = DriverManager.getConnection((String) ctx.get(URL), prp);
   dbh.setAutoCommit(false);
  }
  catch (Exception err)
  {System.err.println("CONNECT exception: " + err.toString());
   return true;
  }
  return false;
 }

 // Execute a DESC request
 private static boolean doDesc(PrintStream ofh, String dat, Hashtable ctx)
 {try
  {Statement sth = dbh.createStatement();
   if (ctx.containsKey(LIM))
   {Integer lim = new Integer((String) ctx.get(LIM));
    sth.setQueryTimeout(lim.intValue());
   }
   ResultSet res = sth.executeQuery("SELECT * FROM " + dat);
   ResultSetMetaData dsc = res.getMetaData();
   int max = dsc.getColumnCount();
   for (int i = 1; i <= max; i++ )
    ofh.println(dsc.getColumnName(i) + "|" +
                dsc.getColumnTypeName(i) + "|" +
                dsc.getColumnType(i) + "|" +
                dsc.isNullable(i) + "|");
   sth.close();
  }
  catch (SQLException err)
  {String msg = err.getMessage();
   if (msg.startsWith("ORA-01013:") || msg.indexOf("timeout") >= 0)
   {System.err.println("DESC timeout");
    return disconnect();
   }
   printMessage(ofh, "describe", msg);
  }
  catch (Exception err)
  {System.err.println("DESC exception: " + err.toString());
   return disconnect();
  }
  return false;
 }

 // Execute a META request
 private static boolean doMeta(PrintStream ofh, Hashtable ctx)
 {try
  {DatabaseMetaData dsc = dbh.getMetaData();

   // Get the database provider
   ofh.println("-nam='" + dsc.getDatabaseProductName() + "'");

   // Get the database version
   String str = dsc.getDatabaseProductVersion();
   Matcher pat = Pattern.compile("(\\\\d+(\\\\.\\\\d+)+)").matcher(str);
   if (pat.find())
    ofh.println("-ver='" + pat.group(1) + "'");
  }
  catch (SQLException err)
  {String msg = err.getMessage();
   if (msg.startsWith("ORA-01013:") || msg.indexOf("timeout") >= 0)
   {System.err.println("META timeout");
    return disconnect();
   }
   printMessage(ofh, "meta", msg);
  }
  catch (Exception err)
  {System.err.println("META exception: " + err.toString());
   return disconnect();
  }
  return false;
 }

 // Execute a PLSQL request
 private static boolean doPlSql(PrintStream ofh, String dat, Hashtable ctx)
 {try
  {CallableStatement blk;

   // Enable dbms_output
   blk = dbh.prepareCall("begin dbms_output.enable(1000000); end;");
   blk.execute();

   // Execute the PL/SQL block
   blk = dbh.prepareCall(dat);
   if (ctx.containsKey(LIM))
   {Integer lim = new Integer((String) ctx.get(LIM));
    blk.setQueryTimeout(lim.intValue());
   }
   blk.execute();

   // Retrieve the block output
   int sta = 0;
   blk = dbh.prepareCall("{call sys.dbms_output.get_line(?,?)}");
   blk.registerOutParameter(1,java.sql.Types.VARCHAR);
   blk.registerOutParameter(2,java.sql.Types.NUMERIC);
   while (true)
   {blk.execute();
    sta = blk.getInt(2);
    if (sta != 0)
     break;
    ofh.println(blk.getString(1));
   }
  }
  catch (SQLException err)
  {String msg = err.getMessage();
   if (msg.startsWith("ORA-01013:") || msg.indexOf("timeout") >= 0)
   {System.err.println("PL/SQL timeout");
    return disconnect();
   }
   printMessage(ofh, "PL/SQL", err);
  }
  catch (Exception err)
  {System.err.println("PLSQL Exception: " + err.toString());
   return disconnect();
  }
  return false;
 }

 // Execute an SQL request
 private static boolean doSql(PrintStream ofh, String dat, Hashtable ctx)
 {try
  {Statement sth = dbh.createStatement();
   if (ctx.containsKey(LIM))
   {Integer lim = new Integer((String) ctx.get(LIM));
    sth.setQueryTimeout(lim.intValue());
   }
   try
   {ResultSet res = sth.executeQuery(dat);
    int max = res.getMetaData().getColumnCount();
    while (res.next())
    {StringBuffer buf = new StringBuffer();
     for (int i = 0 ; i < max ; )
     {if (i++ > 0)
       buf.append("|");
      buf.append(res.getString(i));
     }
     ofh.println(buf.toString());
    }
   }
   catch (SQLException err)
   {String msg = err.getMessage();
    if (msg.startsWith("ORA-01013:") || msg.indexOf("timeout") >= 0)
    {System.err.println("SQL timeout");
     return disconnect();
    }
    printMessage(ofh, "SQL", err);
   }
   sth.close();
  }
  catch (Exception err)
  {System.err.println("SQL exception: " + err.toString());
   return disconnect();
  }
  return false;
 }

 // Execute a request
 private static boolean execRequest(String cmd, String dat, Hashtable ctx)
 {boolean flg = false;

  // Detect an exit request
  if ("QUIT".equals(cmd))
   return true;

  // Treat other requests
  try
  {// Create and open the output file
   String wrk = (String) ctx.get(WRK);
   File fil = new File(wrk);
   fil.createNewFile();
   PrintStream ofh = new PrintStream(new FileOutputStream(fil));

   // Process the request
   if ("CONNECT".equals(cmd))
    flg = doConnect(ofh, ctx);
   else if ("DESC".equals(cmd))
    flg = doDesc(ofh, dat, ctx);
   else if ("META".equals(cmd))
    flg = doMeta(ofh, ctx);
   else if ("PLSQL".equals(cmd))
    flg = doPlSql(ofh, dat, ctx);
   else if ("SQL".equals(cmd))
    flg = doSql(ofh, dat, ctx);

   // Close and rename the output file
   ofh.close();
   wrk = wrk.replaceAll("tmp\$", "txt");
   fil.renameTo(new File(wrk));
  }
  catch (IOException err)
  {System.err.println("Request exception: " + err.toString());
   return true;
  }

  // Accept a new request
  return flg;
 }

 // Print the formatted SQL error message to the output file
 private static void printMessage(PrintStream ofh, String typ, String msg)
 {ofh.println("ERROR in " + typ + " request:");
  ofh.println(msg.replaceAll("(\\n|\\r)"," "));
 }

 private static void printMessage(PrintStream ofh, String typ, SQLException err)
 {ofh.println("ERROR in " + typ + " request:");
  ofh.println(err.getMessage().replaceAll("(\\n|\\r)"," "));
 }

 // Parse input and manage requests
 public static void main(String[] argv) throws IOException
 {BufferedReader stdin = new BufferedReader(new InputStreamReader(System.in));
  Hashtable ctx = new Hashtable();

  String cmd, lin;
  StringBuffer buf = new StringBuffer();
  boolean flg = true;
  int beg, end;

  cmd = "";
  while ((lin = stdin.readLine()) != null)
  {if (flg)
   {if ((beg = lin.indexOf("='")) > 0 &&
        (end = lin.lastIndexOf("'")) > 0 &&
        end > beg)
     ctx.put(lin.substring(0, beg), lin.substring(beg + 2, end));
    else if (lin.startsWith("#"))
    {cmd = lin.substring(1);
     flg = false;
    }
   }
   else
   {if ("/".equals(lin))
    {// Execute the request
     if (execRequest(cmd, buf.toString(), ctx))
      break;

     // Prepare the next command
     buf = new StringBuffer();
     cmd = "";
     ctx = new Hashtable();
     flg = true;
    }
    else
    {buf.append(lin);
     buf.append(EOL);
    }
   }
  }
 }
}
EOF

# Define the global private constants
my $ALR = 'timeout';
my $CUT = '___Cut___';
my $EOD = "#QUIT\n/\n";
my $OUT = qr{timeout};
my $WRK = 'jdbc.tmp';

# 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_map = (
  '-11' => 'NUMBER',   # SQL_GUID
  '-10' => 'LONG',     # SQL_WLONGVARCHAR
  '-9'  => 'VARCHAR2', # SQL_WVARCHAR
  '-8'  => 'CHAR',     # 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
  );
my %tb_txt = (
  db2       => 'AskDb2',        # Text:AskDb2
  odbc      => 'AskOdbc',       # Text:AskOdbc
  oracle    => 'AskOracle',     # Text:AskOracle
  sqlserver => 'AskSqlserver',  # Text:AskSqlserver
  );

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

=head2 S<$h = RDA::Driver::Jdbc-E<gt>new($ctx,$tgt)>

The object constructor. It takes the context and target object references as
arguments.

C<RDA::Driver::Jdbc> 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<'-col'> > Reference to the collector object

=item S<    B<'-ctl'> > Reference to the language control object

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

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

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

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

=item S<    B<'-ief'> > Interface error file

=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<'-pid'> > Process identifier of the Java interface

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

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

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

=item S<    B<'-url'> > JDBC connection URL

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

=back

Internal keys are prefixed by a dash.

=cut

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

  # Create the object
  $ctl = $ctx->get_inline->force_context('Java');
  $slf = bless {
    dur  => 0,
    lim  => _chk_alarm($col->get_first('DEFAULT.N_JDBC_TIMEOUT', 30)),
    -col => $col,
    -ctl => $ctl,
    -dft => $col->is_isolated ? q{?} : undef,
    -err => 0,
    -out => 0,
    -req => 0,
    -skp => 0,
    -tgt => $tgt,
    }, ref($cls) || $cls;

  # Analyze the login information
  $slf->{'-inf'} = _get_info($slf, $tgt);

  # 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)
{ 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'};
  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 ($dba, $drv, $msg, $pwd, $tns, $txt, $typ, $url, $usr, $val, $var, $wrk);

    # Get the target information
    ($typ, $url, $usr, $txt, $drv, $dba, $tns) = @{$slf->{'-inf'}};

    # Get the password
    delete($slf->{'-die'});
    $pwd = $ctx->get_access->obtain_password($typ, $url, $usr, $lim, $txt,
      $slf->{'-dft'});
    die get_string('NO_PASSWORD') unless defined($pwd);

    # Open the pipe
    eval {
      my ($ctl, $dsc, $env, $lng, @old, %ctx);

      $ctl = $slf->{'-ctl'};
      $lng = $ctl->add_common(RDA::Object::Java->new($NAM,
        [$COD], $VER))->add_sequence->get_language;

      # Adapt the context
      $dsc = $slf->{'-tgt'}->find_jdbc;
      foreach my $key (keys(%{$dsc->{'ctx'}}))
      { $ctx{$key} = $ctl->set_context($lng, $key, $dsc->{'ctx'}->{$key});
      }
      $env = $ctl->set_env($lng, $dsc->{'env'});
      @old = $ctl->set_path($lng, 'classpath', @{$dsc->{'jar'}});

      # Launch the interface
      ($slf->{'-pid'}, undef, $slf->{'-ief'}) =
        $ctl->pipe_code($slf->{'-dbh'} = IO::File->new, $lng, $NAM);

      # Restore the context
      foreach my $key (keys(%ctx))
      { $ctl->set_context($lng, $key, $ctx{$key});
      }
      $ctl->set_env($lng, $env);
      $ctl->set_path($lng, 'classpath', @old);
      };
    if ($msg = $@)
    { $msg =~ s/[\n\r\s]+$//;
      $slf->{'-die'} = $slf->{'-msg'} = $msg;
      die get_string('ERR_LAUNCH', $msg)
        if $slf->{'-tgt'}->get_access;
      return $slf->{'-dbh'} = undef;
    }

    # Connect to the database
    $var = {
      DRV => $drv,
      PWD => $pwd,
      URL => $url,
      USR => $usr,
      };
    $var->{'DBA'} = $dba if $dba;
    $var->{'LIM'} = $val if ($val = $slf->get_alarm($inc));
    $var->{'TNS'} = $tns if defined($tns);
    unless ($wrk = _request($slf, $slf->{'lim'}, '#CONNECT', $var))
    { $slf->{'-col'}->clean_work($WRK);
      die get_string('ERR_TIMEOUT')
        if $slf->{'-msg'} =~ $OUT;
      die get_string('ERR_REQUEST', $slf->{'-die'})
        if $slf->{'-tgt'}->get_access;
      return;
    }
    1 while unlink($wrk);
  }

  # 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 ($dsc, $err, $ifh, $nam, $tgt, $trc, $wrk);

  # Execute the describe request
  $dsc = {row => [], typ => {}};
  $tgt = $slf->{'-tgt'};
  $trc = $tgt->get_level;
  eval {
    local $SIG{'__WARN__'} = sub {};

    debug("SQL: describe $obj") if $trc;
    if ($slf->connect($ctx))
    { die get_string('ERR_REQUEST', $slf->{'-msg'})
        unless ($wrk = _request($slf, 0, '#DESC', {}, $obj));
      $ifh = IO::File->new;
      if ($ifh->open("<$wrk"))
      { while (<$ifh>)
        { s/[\n\r\s]+$//;
          debug('SQL> ', $_) if $trc;
          if ($_ =~ /^([^\|]+)\|([^\|]+)\|(?:[^\|]+)\|([^\|]+)\|/)
          { $nam = lc($1);
            push(@{$dsc->{'row'}}, $nam);
            $dsc->{'typ'}->{$nam} = uc(exists($tb_map{$2}) ? $tb_map{$2} : $2);
            $dsc->{'nul'}->{$nam} = $3;
          }
        }
        $ifh->close;
      }
      1 while unlink($wrk);
    }
    };

  # Detect and treat interrupts
  if ($err = $@)
  { unless ($err =~ $OUT)
    { ++$slf->{'-err'};
      die $err;
    }
    $slf->disconnect;
    _log_timeout($slf, $ctx, $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 ($slf) = @_;
  my ($dbh);

  if (defined($dbh = delete($slf->{'-dbh'})))
  { $dbh->syswrite($EOD, length($EOD));
    $dbh->close;
  }
  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 ($buf, $cat, $err, $flg, $ifh, $lim, $lin, $tag, $tgt, $trc, $var, @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
  $cat = 0;
  $flg = 1;
  $ifh = IO::File->new;
  $var = ($lim = $slf->get_alarm($inc)) ? {LIM => $lim} : {};
  @job = split(/\n/, $job);
  if ($trc = $tgt->get_level)
  { for (@job)
    { debug('SQL: ', $_);
    }
  }
  eval {
    local $SIG{'__WARN__'} = sub {};

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

          $tag = $1;
          push(@sql, $lin) while defined($lin = shift(@job)) && $lin ne q{/};
          next unless @sql;
          die get_string('ERR_REQUEST', $slf->{'-msg'})
            unless ($wrk = _request($slf, 0, '#SQL', $var, @sql));
          if ($ifh->open("<$wrk"))
          { while (<$ifh>)
            { s/[\n\r\s]+$//;
              debug('SQL> ', $_) if $trc;
              if ($_ =~ $CUT)
              { $flg = !$flg;
              }
              elsif ($flg)
              { if ($cat)
                { if (m/^\]\]\]$/)
                  { last if &$fct($slf, $arg, $buf);
                    $cat = 0;
                  }
                  else
                  { $buf .= $_;
                  }
                }
                elsif (m/^\[\[\[$/)
                { $buf = q{};
                  $cat = 1;
                }
                else
                { last if &$fct($slf, $arg, $_);
                }
              }
            }
            $ifh->close;
          }
          1 while unlink($wrk);
        }
        elsif ($lin =~ m/^#\s*(PLSQL\d*)\s*$/)
        { my ($wrk, @row, @sql);

          $tag = $1;
          push(@sql, $lin) while defined($lin = shift(@job)) && $lin ne q{/};
          next unless @sql;
          die get_string('ERR_REQUEST', $slf->{'-msg'})
            unless ($wrk = _request($slf, 0, '#PLSQL', $var, @sql));
          if ($ifh->open("<$wrk"))
          { while (<$ifh>)
            { s/[\n\r\s]+$//;
              debug('SQL> ', $_) if $trc;
              if ($_ =~ $CUT)
              { $flg = !$flg;
              }
              elsif ($flg)
              { if ($cat)
                { if (m/^\]\]\]$/)
                  { last if &$fct($slf, $arg, $buf);
                    $cat = 0;
                  }
                  else
                  { $buf .= $_;
                  }
                }
                elsif (m/^\[\[\[$/)
                { $buf = q{};
                  $cat = 1;
                }
                else
                { last if &$fct($slf, $arg, $_);
                }
              }
            }
            $ifh->close;
          }
          1 while unlink($wrk);
        }
        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*$/)
        { $var->{'LNG'} = $1;
        }
        elsif ($lin =~ m/^#\s*SLEEP\((\d+)\)\s*$/)
        { sleep($1);
        }
      }
    }
    else
    { die get_string('ERR_SQL', $slf->{'-die'}) if $tgt->get_access;
    }
    };

  # Detect and treat interrupts
  if ($err = $@)
  { unless ($err =~ $OUT)
    { ++$slf->{'-err'};
      die $err;
    }
    $slf->disconnect;
    _log_timeout($slf, $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;
}

=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_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);
  return (@tbl, q{?});
}

=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 connection problems.

=cut

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

  _get_meta($slf, $ctx) unless exists($slf->{'-nam'});
  return $slf->{'-nam'};
}

=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 connection problems.

=cut

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

  _get_meta($slf, $ctx) unless exists($slf->{'-ver'});
  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) = @_;

  return $slf->{'_dur'} = $slf->get_alarm($inc);
}

=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) = @_;

  return $slf->{'lim'} = _chk_alarm($val);
}

=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 ($cnt, $err, $flg, $tgt, $txt);

  # Test the database connection
  $tgt = $slf->{'-tgt'};
  $tgt->set_failures(0);
  delete($slf->{'-not'});

  # Execute the request
  $flg = 1;
  eval {
    local $SIG{'__WARN__'} = sub {};

    $flg = 0 if defined($slf->connect($ctx));
  };
  return $tgt->set_test(q{}) unless $@ || $flg;

  # Disable further access to the database in case of problems
  if ($err = $@)
  { $slf->disconnect;
    ++$slf->{'-err'};
    _log_timeout($slf, $ctx, $tgt, 'Test') if $err =~ $OUT;
  }
  $slf->{'-not'} = get_string('NoConnection');
  $tgt->set_failures(-1);
  return $tgt->set_test(get_string('NO_CONNECTION'));
}

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

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

=cut

sub use_alarm
{ return 0;
}

# --- Methods required for RDA::Object::Dbd compatibility ---------------------

sub get_date_fmt
{ return;
}

sub get_sources
{ return ();
}

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

# Check if alarm is implemented
sub _chk_alarm
{ my ($lim) = @_;

  return ($lim > 0) ? $lim : 0;
}

# Get the Java error
sub _get_error
{ my ($err) = @_;
  my ($buf, $ifh);

  return 'Request error'
    unless -s $err && ($ifh = IO::File->new)->open("<$err");
  $buf = join("\n ", <$ifh>);
  $ifh->close;
  return $buf;
}

# Determine the target information
sub _get_info
{ my ($slf, $tgt) = @_;
  my ($dba, $drv, $pwd, $sid, $suf, $txt, $typ, $url, $usr, @dsc, %dsc);

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

  # Determine the login information
  if (defined($usr))
  { $suf = $dba ? ' as SYSDBA' : q{};
    if ($usr =~ m/^([^@]*)\@(\S+)(.*)$/)
    { ($usr, $sid, $suf) = ($1, $2, $3);
    }
    elsif ($usr =~ m/^([^@]*)\@(.*)$/)
    { ($usr, $suf) = ($1, $2);
    }
    ($usr, $pwd) = ($1, $2) if $usr =~ m/^(.*?)\/(.*)$/;
  }
  else
  { $usr = $pwd = $suf = q{};
  }
  die get_string('NO_DRIVER_URL')
    unless $sid && $sid =~ m/^(\w+(\.\w+)+)\|(.+)$/;
  $drv = $1;
  $url = $3;
  $dba = 'sysdba'
    if $suf =~ m/AS\s+SYSDBA/i && $url =~ m/^jdbc\:oracle\:thin\:/;

  ($typ, $sid) = norm_credential('jdbc', $url, $usr);
  if ($typ eq 'sqlserver')
  { ($url, @dsc) = split(/;/, $url);
    foreach my $dsc (@dsc)
    { $dsc{uc($1)} = $2 if $dsc =~ m/^(\w+)=(.*)$/;
    }
    $usr = delete($dsc{'USER'})     if exists($dsc{'USER'});
    $pwd = delete($dsc{'PASSWORD'}) if exists($dsc{'PASSWORD'});
    $dsc{'INITIALIZATIONSTRING'} = 'SET CONCAT_NULL_YIELDS_NULL OFF';
    $url = join(q{;}, $url, map {$_.q{=}.$dsc{$_}} sort keys(%dsc));
  }

  # Store provided password
  if (defined($pwd))
  { $slf->{'-col'}->get_access->set_password('jdbc', $url, $usr, $pwd);
  }
  else
  { $txt = exists($tb_txt{$typ})
      ? get_string($tb_txt{$typ}, $usr, $sid)
      : get_string('AskPassword', $usr, $url);
  }
  return ['jdbc', $url, $usr, $txt, $drv, $dba, $tgt->get_detail('tns','tns')];
}

# Retrieve driver and database information
sub _get_meta
{ my ($slf, $ctx) = @_;
  my ($err, $ifh, $trc, $wrk);

  # Set default values
  $slf->{'-nam'} = $slf->{'-ver'} = q{};

  # Try to retrieve the data
  eval {
    local $SIG{'__WARN__'} = sub {};

    # Execute the meta request
    if ($slf->connect($ctx))
    { die get_string('ERR_REQUEST', $slf->{'-msg'})
        unless ($wrk = _request($slf, 0, '#META', {}));
      $ifh = IO::File->new;
      if ($ifh->open("<$wrk"))
      { while (<$ifh>)
        { debug('META> ', $_) if $trc;
          $slf->{$1} = $2 if $_ =~ /^(\-\w+)\='(.*)'/;
        }
        $ifh->close;
      }
      1 while unlink($wrk);
    }
  };

  # Detect and treat interrupts
  if ($err = $@)
  { unless ($err =~ $OUT)
    { ++$slf->{'-err'};
      die $err;
    }
    $slf->disconnect;
    _log_timeout($slf, $ctx, $slf->{'-tgt'}, 'META');
  }
  return;
}

# 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'};
}

# Submit a request
sub _request
{ my ($slf, $lim, $cmd, $var, @dat) = @_;
  my ($buf, $cnt, $err, $wrk);

  eval {
    local $SIG{'ALRM'} = 'IGNORE' if exists($SIG{'ALRM'});
    local $SIG{'PIPE'} = sub {die "Pipe broken\n"};

    # Prepare the request
    unless (ref($var))
    { $var = {};
      $var->{'LIM'} = $slf->{'lim'} if $slf->{'lim'};
    }
    $wrk = $slf->{'-col'}->get_work($WRK, 1);
    $var->{'WRK'} = RDA::Object::Rda->native($wrk);
    $wrk =~ s/\.tmp$/.txt/;
    1 while unlink($wrk);

    # Send the request
    $buf = join(qq{\n}, (map {$_.q{='}.$var->{$_}.q{'}} keys(%{$var})),
                        $cmd, @dat, qq{/\n});
    $slf->{'-dbh'}->syswrite($buf, length($buf));

    # Wait for the request completion
    $cnt = $lim;
    $err = $slf->{'-ief'};
    while (! -e $wrk)
    { die _get_error($err).qq{\n} if -s $err;
      die "Request timeout\n"     if $lim && --$cnt < 0;
      sleep(1);
    }
    die _get_error($err).qq{\n} if -s $err;
  };
  if ($buf = $@)
  { $buf =~ s/[\n\r\s]+$//;
    $slf->{'-die'} = $slf->{'-msg'} = $buf;
    $slf->{'-dbh'}->close;
    $slf->{'-dbh'} = undef;
    return;
  }
  $slf->{'-col'}->clean_work($WRK);
  return $wrk;
}

1;

__END__

=head1 SEE ALSO

L<RDA::Agent|RDA::Agent>,
L<RDA::Library::Dbi|RDA::Library::Dbi>,
L<RDA::Object::Access|RDA::Object::Access>,
L<RDA::Object::Collect|RDA::Object::Collect>,
L<RDA::Object::Inline|RDA::Object::Inline>,
L<RDA::Object::Java|RDA::Object::Java>,
L<RDA::Object::Rda|RDA::Object::Rda>,
L<RDA::Object::Target|RDA::Object::Target>,
L<RDA::SDCL::Block|RDA::SDCL::Block>,
L<RDA::Target::Dbi|RDA::Target::Dbi>,
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