# Db.pm: Class Used for Database Macros

package RDA::Library::Db;

# $Id: Db.pm,v 1.28 2015/08/28 07:25:59 RDA Exp $
# ARCS: $Header: /home/cvs/cvs/RDA_8/src/scripting/lib/RDA/Library/Db.pm,v 1.28 2015/08/28 07:25:59 RDA Exp $
#
# Change History
# 20150828  MSC  Add the isSqlEnabled macro.

=head1 NAME

RDA::Library::Db - Class Used for Database Macros

=head1 SYNOPSIS

 require RDA::Library::Db;

=head1 DESCRIPTION

The objects of the C<RDA::Library::Db> class are used to interface with
database-related macros.

The following methods are available:

=cut

use strict;

BEGIN
{ use Exporter;
  use IO::File;
  use IO::Handle;
  use RDA::Text qw(debug get_string);
  use RDA::Alarm qw(check_alarm clear_alarm set_alarm);
  use RDA::Driver::Library qw(get_alarm);
  use RDA::Object;
  use RDA::Object::Access qw($RE_EXT $RE_EZC $RE_EZD $RE_SID $RE_SVC check_sid);
  use RDA::Object::Buffer;
  use RDA::Object::Rda;
  use RDA::Object::View;
  use RDA::Value::List;
  use RDA::Value::Scalar qw(:value new_number);
}

# Define the global public variables
use vars qw($STRINGS $SUSPEND $VERSION @ISA);
$SUSPEND = {
  _buf => sub {return {}},
  _dsc => sub {return {}},
  _hit => sub {return []},
  _inf => undef,
  _log => undef,
  _tgt => undef,
  };
$VERSION = sprintf('%d.%02d', q$Revision: 1.28 $ =~ /(\d+)\.(\d+)/);
@ISA     = qw(RDA::Driver::Library Exporter);

# Define the global private constants
my $ALR = q{___Alarm___};
my $BUF = qr/^___Capture(_Only)?_(\w+)___$/;
my $CLL = qr/(\!\!call|^#\s*CALL)\s+(caller:)?(\w+)\((\d+)\)\s*$/;
my $CUT = q{___Cut___};
my $EOC = q{___End_Capture___};
my $ERR = qr/^ERROR at line \d+:$/i;
my $LOG = qr/^((ORA|RDA|SP2)-\d{4,}):\s*(.*)/;
my $MAC = qr/^___Macro_(caller:)?(\w+)\((\d+)\)___$/;
my $MIS = qr/^('.*' is not recognized as an internal or external command)/;
## no critic (Interpolation,Numbered)
my $NET1 =
  '%s(DESCRIPTION = (ADDRESS = (PROTOCOL = TCP)(HOST = %s)(PORT = %s)) '
  .'(CONNECT_DATA = (SID = %s)))%s';
my $NET2 =
  '%s(DESCRIPTION = (ADDRESS = (PROTOCOL = TCP)(HOST = %s)(PORT = %s)) '
  .'(CONNECT_DATA = (SERVICE_NAME = %s)))%s';
my $NET3 =
  '%s(DESCRIPTION = (ADDRESS = (PROTOCOL = TCP)(HOST = %s)(PORT = %s)) '
  .'(CONNECT_DATA = (SERVICE_NAME = %s)'
  .'(INSTANCE_ROLE = ANY)(INSTANCE_NAME = %s)(SERVER = DEDICATED)))%s';
## use critic
my $RPT = qr/^RDA::Object::(Pipe|Report)$/i;
my $SEP = qr/^___Separator\((\w+)\)___$/;
my $SLP = qr/(\!\!sleep|^#\s*SLEEP)\((\d+)\)\s*$/;
my $VMS = q{___Set_VMS___};
my $WRK = 'db.txt';
my $WRN = qr/^ORA-280(02|11):/;

# Define the global private variables
my %tb_fct = (
  'checkSid'        => [\&_m_check_sid,     'T', 0],
  'clearLastSql'    => [\&_m_clear_last,    'N', 0],
  'clearSqlBuffer'  => [\&_m_clear_buffer,  'N', 0],
  'clearSqlColumns' => [\&_m_clear_columns, 'N', 0],
  'getSid'          => [\&_m_get_sid,       'T', 0],
  'getSqlBuffer'    => [\&_m_get_buffer,    'O', 0],
  'getSqlColumns'   => [\&_m_get_columns,   'L', 1],
  'getSqlDesc'      => [\&_m_get_desc,      'L', 0],
  'getSqlHits'      => [\&_m_get_hits,      'L', 0],
  'getSqlInfo'      => [\&_m_get_info,      'L', 0],
  'getSqlLines'     => [\&_m_get_lines,     'L', 0],
  'getSqlMessage'   => [\&_m_get_message,   'T', 0],
  'getSqlTarget'    => [\&_m_get_target,    'O', 0],
  'getSqlTimeout'   => [\&_m_get_timeout,   'N', 0],
  'grepLastSql'     => [\&_m_grep_last,     'L', 0],
  'grepSql'         => [\&_m_grep_sql,      'L', 1],
  'grepSqlBuffer'   => [\&_m_grep_buffer,   'L', 0],
  'isSqlEnabled'    => [\&_m_is_enabled,    'N', 1],
  'loadSql'         => [\&_m_load_sql,      'N', 1],
  'resetSqlTimeout' => [\&_m_reset_timeout, 'N', 0],
  'resolveSid'      => [\&_m_resolve_sid,   'T', 0],
  'setSqlColumns'   => [\&_m_set_columns,   'N', 0],
  'setSqlHeader'    => [\&_m_set_header,    'N', 0],
  'setSqlTarget'    => [\&_m_set_target,    'O', 0],
  'setSqlTimeout'   => [\&_m_set_timeout,   'N', 0],
  'setSqlType'      => [\&_m_set_type,      'N', 0],
  'testSql'         => [\&_m_test_sql,      'T', 1],
  'writeLastSql'    => [\&_m_write_last,    'N', 1],
  'writeSql'        => [\&_m_write_sql,     'N', 1],
  );
my %tb_jus = (
  FLOAT  => 'L',
  NUMBER => 'L',
  );
my %tb_typ = (
  CHAR      => '%s',
  DATE      => 'TO_CHAR(%s,\'DD-Mon-YYYY HH24:MI:SS\')',
  FLOAT     => '%s',
  NCHAR     => '%s',
  NUMBER    => '%s',
  NVARCHAR2 => '%s',
  TIMESTAMP => 'TO_CHAR(%s,\'DD-Mon-YYYY HH24:MI:SSxFF\')',
  VARCHAR2  => '%s',
  );

# Define the Sql*Plus interface
## no critic (Long,Newline)
my $BEG = qq{

set arraysize 4
set define off
set echo off
set feedback off
set heading off
set linesize 1024
set newpage none
set pagesize 20000
set pause off
set sqlprompt RDA>
set timing off
set verify off
prompt $CUT
};
my $DSC = qq{SET TAB OFF\nDESC :1};
my $END = qq{prompt $CUT
exit
};
my $SQL = q{SELECT data_type || '|' || column_name
 FROM all_tab_columns
 WHERE owner = ':1'
   AND table_name = ':2'
 ORDER BY column_id;};
## use critic

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

=head2 S<$h = RDA::Library::Db-E<gt>new($driver,$collector)>

The object constructor. It takes the library driver and collector references as
arguments.

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

=over 12

=item S<    B<'frk' > > Fork indicator

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

=item S<    B<'_buf'> > Buffer hash

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

=item S<    B<'_ctl'> > Reference to the target control object

=item S<    B<'_dsc'> > Table description hash

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

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

=item S<    B<'_fct'> > Function to execute a SQL request

=item S<    B<'_grp'> > Default credential group

=item S<    B<'_hit'> > Lines captured when executing SQL statements

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

=item S<    B<'_log'> > User name and password to connect

=item S<    B<'_msg'> > Last error message

=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<'_sql'> > Last SQL result

=item S<    B<'_tgt'> > Reference to the current query target object

=item S<    B<'_vms'> > VMS indicator

=item S<    B<'_wrk'> > Reference to the work file manager

=back

Internal keys are prefixed by an underscore.

=cut

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

  # Create the macro object
  $slf = bless {
    _buf => {},
    _dsc => {},
    _dur => 0,
    _err => 0,
    _hit => [],
    _not => q{},
    _out => 0,
    _req => 0,
    _skp => 0,
    _sql => [],
    _vms => RDA::Object::Rda->is_vms,
    }, ref($cls) || $cls;

  # Determine the defaut context
  $slf->{'_grp'} =
    check_sid($col->get_agent->get_env('ORACLE_SID', q{}));

  # Register the macros
  $drv->register($slf, [keys(%tb_fct)], qw(rda refresh reload suspend usage));

  # Return the object reference
  return refresh($slf, $col);
}

=head2 S<$h-E<gt>call($name,...)>

This method executes the macro code.

=cut

sub call
{ my ($slf, $nam, @arg) = @_;
  my ($rec);

  $rec = $tb_fct{$nam};
  return ($rec->[2] && exists($slf->{'_tgt'}))
    ? $slf->{'_ctl'}->switch_target($slf->{'_tgt'}, $rec->[0], $slf, @arg)
    : &{$rec->[0]}($slf, @arg);
}

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

This method resets the statistics and clears corresponding module settings.

=cut

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

  delete($slf->{'_inf'});
  delete($slf->{'_log'});
  delete($slf->{'_msg'});
  delete($slf->{'_tgt'});
  $slf->{'_buf'} = {};
  $slf->{'_dsc'} = {};
  $slf->{'_hit'} = [];
  $slf->{'_sql'} = [];
  $slf->{'_not'} = q{};
  $slf->{'_dur'} =
  $slf->{'_req'} = $slf->{'_err'} = $slf->{'_out'} = $slf->{'_skp'} = 0;
  return;
}

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

This method deletes the library control object.

=cut

sub delete_object
{ RDA::Object::dump_caller($_[0], 'Library') if $RDA::Object::DELETE;
  undef %{$_[0]};
  undef $_[0];
  return;
}

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

This method reports the library statistics in the specified module.

=cut

sub get_stats
{ my ($slf) = @_;
  my ($use);

  if ($slf->{'_req'})
  { # Get the statistics record
    $use = $slf->{'_col'}->get_usage;
    $use->{'DB'} = {err => 0, not => q{}, out => 0, req => 0, skp => 0}
      unless exists($use->{'DB'});
    $use = $use->{'DB'};

    # Indicate the current timeout when there is no other note
    $slf->{'_not'} = 'SQL execution limited to '.$slf->{'lim'}.'s'
      unless $use->{'not'} || $slf->{'_not'}  ## no critic (Unless)
          || $slf->{'lim'} <= 0;

    # Generate the module statistics
    $use->{'err'} += $slf->{'_err'};
    $use->{'out'} += $slf->{'_out'};
    $use->{'req'} += $slf->{'_req'};
    $use->{'skp'} += $slf->{'_skp'};
    $use->{'not'} = $slf->{'_not'} if $slf->{'_not'};

    # Reset the statistics
    clr_stats($slf);
  }
  return;
}

=head2 S<$h-E<gt>refresh($col)>

This method updates the library control object for a new collector.

=cut

sub refresh
{ my ($slf, $col) = @_;
  my ($dft);

  $dft = $col->get_info('dft');
  $slf->{'frk'}  = _chk_fork($dft->get_first('B_SQL_FORK', 1));
  $slf->{'lim'}  = check_alarm($dft->get_first('N_SQL_TIMEOUT', 30));
  $slf->{'_col'} = $col;
  $slf->{'_ctl'} = $col->get_target;

  # Determine the request method
  if ($slf->{'frk'})
  { $slf->{'_fct'} = \&_run_sql_fork;
    delete($slf->{'_wrk'});
  }
  else
  { $slf->{'_fct'} = \&_run_sql_tmp;
    $slf->{'_wrk'} = $col;
  }

  return($slf);
}

=head2 S<$h-E<gt>run($name,$arg,$ctx)>

This method executes the macro with the specified argument list in a given
context.

=cut

sub run
{ my ($slf, $nam, $arg, $ctx) = @_;
  my ($rec);

  $rec = $tb_fct{$nam};
  return ($rec->[2] && exists($slf->{'_tgt'}))
    ? $slf->{'_ctl'}->switch_target($slf->{'_tgt'},
        \&_run, $slf, $rec->[0], $rec->[1], $arg, $ctx)
    : _run($slf, $rec->[0], $rec->[1], $arg, $ctx);
}

sub _run
{ my ($slf, $fct, $typ, $arg, $ctx) = @_;
  my ($ret);

  return ($typ eq 'L')
    ? RDA::Value::List::new_from_data(&$fct($slf, $ctx, $arg->eval_as_array)) :
  defined($ret = &$fct($slf, $ctx, $arg->eval_as_array))
    ? RDA::Value::Scalar->new($typ, $ret) :
  $VAL_UNDEF;
}

=head1 DATABASE MACROS

=head2 S<checkSid($sid[,$dft[,$flg]])>

This macro checks the system identifier and returns a normalized string for
password management. When the flag is set, it preserves the system identifier
capitalization.

=cut

sub _m_check_sid
{ my ($slf, $ctx, $sid, $dft, $flg) = @_;

  return check_sid($sid, $dft, $flg);
}

=head2 S<clearLastSql()>

This macro clears the last SQL result.

=cut

sub _m_clear_last
{ return shift->{'_sql'} = [];
}

=head2 S<clearSqlBuffer([$nam,...])>

This macro deletes the specified capture buffers. The capture buffer names are
not case sensitive. It deletes all capture buffers when called without
arguments.

=cut

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

  if (@arg)
  { foreach my $nam (@arg)
    { delete($slf->{'_buf'}->{lc($nam)}) if defined($nam);
    }
  }
  else
  { $slf->{'_buf'} = {};
  }
  return 0;
}

=head2 S<clearSqlColumns($tid)>

This macro clears all information associated with the specified table
identifier.

=cut

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

  delete($slf->{'_dsc'}->{$tid}) if $tid;
  return 0;
}

=head2 S<getSid($sid[,$dbn])>

This macro extracts the Oracle system identifier from the connection string.

=cut

sub _m_get_sid
{ my ($slf, $ctx, $sid, $dbn) = @_;
  my (@tbl);

  return $dbn unless defined($sid);
  return $sid unless $sid =~ m/[:\.\/]/;
  return $dbn if defined($dbn);
  @tbl = split(/:/, check_sid($sid, q{}, 1));
  @tbl = split(/\./, $tbl[-1]);
  return $tbl[0];
}

=head2 S<getSqlBuffer([$nam[,$flg]])>

This macro returns the specified capture buffer or the hit buffer when the name
is undefined. The capture buffer names are not case sensitive. Unless the flag
is set, it assumes Wiki data.

=cut

sub _m_get_buffer
{ my ($slf, $ctx, $nam, $flg) = @_;

  return RDA::Object::Buffer->new($flg ? 'L' : 'l',
    defined($nam) ? $slf->{'_buf'}->{lc($nam)} : $slf->{'_hit'});
}

=head2 S<getSqlColumns($tid,$own,$tbl[,@col])>

This macro determines if the specified columns are present in the table and
generates the header string and the select list accordingly. You can provide
specific headers or select contributions through the C<setSqlColumns> and
C<setSqlHeader> macros. RDA supports predefined data types only unless an
explicit select contribution or an extra conversion format is specified. You
can manage the data types list with the C<setSqlType> macro.

When no columns are specified, all table columns are considered.

This macro returns a list containing the corresponding header and select
list. If the table is not found or if the query identifier is missing, then the
header and select list are undefined.

=cut

sub _m_get_columns  ## no critic (Complex)
{ my ($slf, $ctx, $tid, $own, $tbl, @arg) = @_;
  my ($col, $dsc, $hdr, $jus, $row, $sql, $typ, @hdr, @sel, @tbl);

  # Get the query entry
  return () unless $tid;
  $slf->{'_dsc'}->{$tid} = {} unless exists($slf->{'_dsc'}->{$tid});
  $dsc = $slf->{'_dsc'}->{$tid};

  # Get the table description and reject unknown table
  unless (exists($dsc->{'typ'}))
  { $dsc->{'row'} = [];
    $dsc->{'typ'} = {};
    $tbl = uc($tbl);
    if ($own)
    { $own = uc($own);
      $sql = $SQL;
      $sql =~ s/:1/$own/;
      $sql =~ s/:2/$tbl/;
      &{$slf->{'_fct'}}($slf, $ctx, $sql, 1, undef, \&_desc_sql, [$dsc]);
    }
    else
    { $sql = $DSC;
      $sql =~ s/:1/$tbl/;
      &{$slf->{'_fct'}}($slf, $ctx, $sql, 1, undef, \&_desc_desc, [$dsc]);
    }
  }
  return () unless (@{$row = $dsc->{'row'}});

  # Generate the row
  $row = \@arg if @arg;
  foreach my $nam (@{$row})
  { $col = lc($nam);

    # Reject unknown column
    next unless exists($dsc->{'typ'}->{$col})
      && defined($typ = $dsc->{'typ'}->{$col});

    # Determine how to justify the column
    $jus = exists($dsc->{'jus'}->{$col}) ? $dsc->{'jus'}->{$col} :
      exists($tb_jus{$typ}) ? $tb_jus{$typ} :
      'R';

    # Identify the header contribution
    if (exists($dsc->{'hdr'}->{$col}))
    { $hdr = $dsc->{'hdr'}->{$col};
    }
    else
    { $hdr = qq{*$col*};
      $hdr =~ s{_}{ }g;
      $hdr =~ s{\b([a-z])}{\U$1}g;
      $hdr = qq{ $hdr} if $jus =~ m/L/;
      $hdr = qq{$hdr } if $jus =~ m/R/;
    }

    # Identify the select contribution
    $col = exists($dsc->{'col'}->{$col})
      ? $dsc->{'col'}->{$col}
      : _desc_typ($dsc, $col, $typ);
    next unless $col;
    $col = qq{' ||\n       $col || '};
    $col = qq{ $col} if $jus =~ m/L/;
    $col = qq{$col } if $jus =~ m/R/;
    push(@sel, $col);
    push(@hdr, $hdr);
  }

  # Return the header and select strings
  return (scalar @sel)
    ? (q{|}.join(q{|}, @hdr).q{|}, q{'|}.join(q{|},@sel).q{|'})
    : ();
}

sub _desc_desc
{ my ($slf, $rec, $lin) = @_;
  my ($col, $dsc, $typ);

  # Interrupt when a SQL error is encountered
  die get_string('ERR_SQL')
    if $lin =~ $ERR && $slf->{'_ctl'}->get_current->is_fatal;

  # Store the lines
  $dsc = $rec->[0];
  if (exists($dsc->{'off'}) && $lin =~ m/\w/)
  { $col = lc(substr($lin, $dsc->{'off'}->[0], $dsc->{'off'}->[1]));
    $typ = substr($lin, $dsc->{'off'}->[2]);
    $col =~ s/\s+$//;
    $typ =~ s/(\(\d+\))?\s*$//;
    push(@{$dsc->{'row'}}, $col);
    $dsc->{'typ'}->{$col} = $typ;
  }
  elsif ($lin =~ m/^\s*Name\s+Null\?\s+Type\s*$/)
  { $col = index($lin,'Name');
    $dsc->{'off'} = [$col, index($lin,'Null?') - $col, index($lin,'Type')];
  }

  # Continue the search
  return 0;
}

sub _desc_sql
{ my ($slf, $rec, $lin) = @_;
  my ($col, $dsc, $typ);

  # Interrupt when a SQL error is encountered
  die get_string('ERR_SQL')
    if $lin =~ $ERR && $slf->{'_ctl'}->get_current->is_fatal;

  # Store the lines
  $dsc = $rec->[0];
  ($typ, $col) = split(/\|/, $lin, 2);
  if (defined($col))
  { $col = lc($col);
    push(@{$dsc->{'row'}}, $col);
    $dsc->{'typ'}->{$col} = $typ;
  }

  # Continue the search
  return 0;
}

sub _desc_typ
{ my ($dsc, $col, $typ) = @_;

  return exists($dsc->{'fmt'}->{$typ}) ? sprintf($dsc->{'fmt'}->{$typ}, $col) :
         exists($tb_typ{$typ})         ? sprintf($tb_typ{$typ}, $col) :
                                         q{};
}

=head2 S<getSqlDesc($tid,$col[,$flg])>

This macro returns the description of the column as a list containing the
column position and its type. Column positions start from 1. Unless the flag is
set, only eligible columns are considered.

The list is empty when the column is not found.

=cut

sub _m_get_desc
{ my ($slf, $ctx, $tid, $col, $flg) = @_;
  my ($cnt, $dsc, $val);

  # Get the query entry
  return () unless $col && $tid && exists($slf->{'_dsc'}->{$tid});
  $dsc = $slf->{'_dsc'}->{$tid};

  # Validate the column
  $col = lc($col);
  return ()
    unless exists($dsc->{'typ'}->{$col}) && defined($dsc->{'typ'}->{$col});

  # Search for the column
  $cnt = 0;
  foreach my $nam (@{$dsc->{'row'}})
  { # Identify the select contribution
    unless ($flg)
    { $val = exists($dsc->{'col'}->{$nam})
        ? $dsc->{'col'}->{$nam}
        : _desc_typ($dsc, $nam, $dsc->{'typ'}->{$nam});
      next unless $val;
    }

    # Check the column
    ++$cnt;
    return ($cnt, $dsc->{'typ'}->{$col}) if $col eq $nam;
  }

  # Indicate that the column has not been found
  return ();
}

=head2 S<getSqlHits()>

This macro returns the list of lines captured during the last C<writeSql>.

=cut

sub _m_get_hits
{ return @{shift->{'_hit'}};
}

=head2 S<getSqlInfo()>

This macro 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 _m_get_info
{ my ($slf) = @_;

  return @{_get_info($slf)};
}

=head2 S<getSqlLines([$min[,$max]])>

This macro returns a range of the lines of the last SQL result. It assumes the
first and last line as the default for the range definition. You can use
negative line numbers to specify lines from the buffer end.

=cut

sub _m_get_lines
{ my ($slf, $ctx, $min, $max) = @_;
  my $buf;

  # Validate the range
  $buf = $slf->{'_sql'};
  $min = (!defined($min) || ($#$buf + $min) < -1) ? 0 :
         ($min < 0) ? $#$buf + $min + 1 :
         $min;
  $max = (!defined($max)) ? $#$buf :
         (($#$buf + $max) < -1) ? 0 :
         ($max < 0) ? $#$buf + $max + 1 :
         ($max > $#$buf) ? $#$buf :
         $max;

  # Return the line range
  return @{$buf}[$min..$max];
}

=head2 S<getSqlMessage()>

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

=cut

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

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

=head2 S<getSqlTarget()>

This macro returns a reference to the current query target or an undefined
value when no target is currently set.

=cut

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

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

=head2 S<getSqlTimeout()>

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

=cut

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

=head2 S<grepLastSql($re,$opt)>

This macro returns the lines of the last SQL result that match the regular
expression. It supports the same options as C<grepSql>.

=cut

sub _m_grep_last
{ my ($slf, $ctx, $re, $opt) = @_;

  return _grep_buffer($slf->{'_sql'}, $re, $opt);
}

=head2 S<grepSql($sql,$re,$opt)>

This macro returns the lines that match the regular expression. The following
options are supported:

=over 9

=item B<    'f' > Stops scanning on the first match.

=item B<    'i' > Ignores case distinctions in both the pattern and the results.

=item B<    'v' > Inverts the sense of matching to select non-matching lines.

=item B<    (n) > Returns the (n)th capture buffer instead of the line.

=back

=cut

sub _m_grep_sql
{ my ($slf, $ctx, $sql, $pat, $opt) = @_;
  my ($flg, $inv, $one, $pos, @tbl);

  # Determine the options
  $opt = q{} unless defined($opt);
  $one = index($opt, 'f') >= 0;
  $pat = RDA::Object::View->is_match($pat, index($opt, 'i') < 0);
  $inv = index($opt, 'v') >= 0;
  $pos = ($opt =~ m/(\d+)/) ? $1 : 0;

  # Check the SQL output
  &{$slf->{'_fct'}}($slf, $ctx, $sql, 1, undef, \&_grep_sql,
    [$pat, \@tbl, $inv, $one, $pos]) if $pat;
  return @tbl;
}

sub _grep_sql
{ my ($slf, $rec, $lin) = @_;

  # Interrupt when a SQL error is encountered
  die get_string('ERR_SQL')
    if $lin =~ $ERR && $slf->{'_ctl'}->get_current->is_fatal;

  # Check if the line matches the pattern
  if ($rec->[2] xor $lin =~ $rec->[0])
  { $lin = eval "\$$rec->[4]" if $rec->[4];  ## no critic (Eval)
    push(@{$rec->[1]}, $lin);
    return $rec->[3];
  }

  # Continue the search
  return 0;
}

=head2 S<grepSqlBuffer($name,$re,$opt)>

This macro returns the lines of the specified capture buffer that match the
regular expression. It supports the same options as C<grepSql>.

=cut

sub _m_grep_buffer
{ my ($slf, $ctx, $nam, $pat, $opt) = @_;

  return () unless defined($nam) && exists($slf->{'_buf'}->{$nam = lc($nam)});
  return _grep_buffer($slf->{'_buf'}->{$nam}, $pat, $opt);
}

sub _grep_buffer
{ my ($buf, $pat, $opt) = @_;
  my ($inv, $one, $pos, @tbl);

  if ($pat)
  { # Determine the options
    $opt = q{} unless defined($opt);
    $one = index($opt, 'f') >= 0;
    $pat = RDA::Object::View->is_match($pat, index($opt, 'i') < 0);
    $inv = index($opt, 'v') >= 0;
    $pos = ($opt =~ m/(\d+)/) ? $1 : 0;

    # Check the last SQL result
    foreach my $lin (@{$buf})
    { if ($inv xor $lin =~ $pat)
      { $lin = eval "\$$pos" if $pos;  ## no critic (Eval)
        push(@tbl, $lin);
        last if $one;
      }
    }
  }
  return @tbl;
}

=head2 S<isSqlEnabled()>

This macro indicates whether the database connections are enabled.

=cut

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

  return $slf->{'_ctl'}->get_current->is_enabled ? 1 : 0;
}

=head2 S<loadSql($sql,$flg[,$inc])>

This macro loads the output of the SQL statement as the last SQL result. It
clears the previous result unless the flag is set. It returns 1 for a
successful completion. If the execution time exceeds the limit or if the
maximum number of attempts has been reached, then it returns 0.

It is possible to increase the execution limit by specifying an increasing
factor as an argument. A negative value disables any timeout.

Only lines between C<___Cut___> lines are inserted in the last SQL result.

=cut

sub _m_load_sql
{ my ($slf, $ctx, $sql, $flg, $inc) = @_;

  $slf->{'_sql'} = [] unless $flg;
  return &{$slf->{'_fct'}}($slf, $ctx, $sql, $inc, undef, \&_load_sql,
    [$ctx, $slf->{'_sql'}]);
}

sub _load_sql
{ my ($slf, $rec, $lin) = @_;

  # Interrupt when a SQL error is encountered
  die get_string('ERR_SQL')
    if $lin =~ $ERR && $slf->{'_ctl'}->get_current->is_fatal;

  # Save the line in the last SQL result
  push(@{$rec->[1]}, $lin);

  # Continue the result processing
  return 0;
}

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

This macro 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 _m_reset_timeout
{ my ($slf, $ctx, $inc) = @_;

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

=head2 S<resolveSid($sid)>

This macro transforms the system identifier in a connect string.

=cut

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

  ## no critic (Numbered)
  return ($sid =~ $RE_EZC) ? sprintf($NET2, q{@}, $2, $3,  uc($4), q{}) :
         ($sid =~ $RE_EZD) ? sprintf($NET2, q{@}, $2, 1521, uc($3), q{}) :
         ($sid =~ $RE_SID) ? sprintf($NET1, q{}, $1, $2, $3, q{}) :
         ($sid !~ $RE_SVC) ? $sid :
         length($3)        ? sprintf($NET3, q{}, $1, $2, $4, $3, q{}) :
                             sprintf($NET2, q{}, $1, $2, $4, q{});
}

=head2 S<setSqlColumns($tid[,$col1,$val1...])>

This macro specifies the select list contribution for one or more columns. An
undefined value deletes an existing contribution. When no columns are specified,
all previous declarations are deleted.

=cut

sub _m_set_columns
{ my ($slf, $ctx, $tid, @arg) = @_;
  my ($dsc, $key, $val);

  # Get the query entry
  return 0 unless $tid;
  $slf->{'_dsc'}->{$tid} = {} unless exists($slf->{'_dsc'}->{$tid});
  $dsc = $slf->{'_dsc'}->{$tid};

  # Manage select list contributions
  if (@arg)
  { while (($key, $val) = splice(@arg, 0, 2))
    { if (defined($val))
      { $dsc->{'col'}->{lc($key)} = $val;
      }
      else
      { delete($dsc->{'col'}->{lc($key)});
      }
    }
  }
  else
  { delete($dsc->{'col'});
  }
  return 1;
}

=head2 S<setSqlHeader($tid[,$col1,$val1...])>

This macro specifies the header contribution for one or more columns. The
justification is deduced from the presence of leading and/or trailing spaces. An
undefined value deletes an existing contribution. When no columns are
specified, all previous declarations are removed.

=cut

sub _m_set_header
{ my ($slf, $ctx, $tid, @arg) = @_;
  my ($dsc, $key, $val);

  # Get the query entry
  return 0 unless $tid;
  $slf->{'_dsc'}->{$tid} = {} unless exists($slf->{'_dsc'}->{$tid});
  $dsc = $slf->{'_dsc'}->{$tid};

  # Manage header contributions
  if (@arg)
  { while (($key, $val) = splice(@arg, 0, 2))
    { $key = lc($key);
      if (defined($val))
      { $dsc->{'hdr'}->{$key} = $val;
        $dsc->{'jus'}->{$key} = ($val =~ m/^\s+\*/ ? 'L' : q{})
          .($val =~ m/\*\s+$/ ? 'R' : q{});
      }
      else
      { delete($dsc->{'hdr'}->{$key});
        delete($dsc->{'jus'}->{$key});
      }
    }
  }
  else
  { delete($dsc->{'hdr'});
    delete($dsc->{'jus'});
  }
  return 1;
}

=head2 S<setSqlTarget([$tgt])>

This macro switches the database context to the specified target. It returns a
reference to the previous target.

=cut

sub _m_set_target
{ my ($slf, $ctx, $tgt) = @_;
  my ($cls, $old, $ref);

  # Reset the context
  delete($slf->{'_inf'});
  delete($slf->{'_log'});
  $old = delete($slf->{'_tgt'});

  # Assign the new target and store any provided password
  $ref = ref($tgt);
  if ($ref eq 'RDA::Target::Db')
  { _get_info($slf, $slf->{'_tgt'} = $tgt);
  }
  elsif ($ref eq 'RDA::Object::Item')
  { $cls = $tgt->get_first('W_CLASS', q{});
    die get_string('BAD_ITEM', $cls) unless $cls eq 'SQ';
    _get_info($slf, $slf->{'_tgt'} =
      _set_target($slf, $tgt));
  }
  elsif ($ref eq 'RDA::Value::Assoc')
  { _get_info($slf, $slf->{'_tgt'} =
      _set_target($slf, 'SQ_TMP$$',  ## no critic (Interpolation)
                        $tgt->eval_as_data(1)));
  }
  elsif ($ref eq 'HASH')
  { _get_info($slf, $slf->{'_tgt'} =
      _set_target($slf, 'SQ_TMP$$',  ## no critic (Interpolation)
                        $tgt));
  }
  elsif (defined($tgt))
  { die get_string('BAD_TARGET', $tgt);
  }
  else
  { _get_info($slf, $slf->{'_ctl'}->get_current);
  }

  # Return a reference to the previous target
  return $old;
}

sub _set_target
{ my ($slf, @def) = @_;
  my ($tgt);

  eval {$tgt = $slf->{'_ctl'}->add_target(@def)};
  return $@
    ? $slf->{'_ctl'}->add_bad('SQ', $slf->{'_msg'} = $@)
    : $tgt;
}

=head2 S<setSqlTimeout($sec)>

This macro 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 _m_set_timeout
{ my ($slf, $ctx, $val) = @_;

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

=head2 S<setSqlType($tid[,$typ1,$fmt1...])>

This macro specifies how to format data types. You can use an empty string to
reject a predefined data type. An undefined value deletes an existing
declaration. When no types are specified, all previous declarations are deleted.

=cut

sub _m_set_type
{ my ($slf, $ctx, $tid, @arg) = @_;
  my ($dsc, $key, $val);

  # Get the query entry
  return 0 unless $tid;
  $slf->{'_dsc'}->{$tid} = {} unless exists($slf->{'_dsc'}->{$tid});
  $dsc = $slf->{'_dsc'}->{$tid};

  # Manage select list contributions
  if (@arg)
  { while (($key, $val) = splice(@arg, 0, 2))
    { if (defined($val))
      { $dsc->{'fmt'}->{uc($key)} = $val;
      }
      else
      { delete($dsc->{'fmt'}->{uc($key)});
      }
    }
  }
  else
  { delete($dsc->{'fmt'});
  }
  return 1;
}

=head2 S<testSql([$flag])>

This macro tests the database connection. Unless the flag is set, it performs
the test once. In case of problems, it disables further access.

=cut

sub _m_test_sql
{ my ($slf, $ctx, $flg) = @_;
  my ($sql, $tgt, $val, @buf);

  # Abort when the test cannot be done
  $tgt = $slf->{'_ctl'}->get_current;
  return $val if defined($val = $tgt->is_tested($flg));

  # Test the database connection
  $tgt->set_failures(0);
  $slf->{'_not'} = q{};
  $sql = q{SELECT 'X' FROM sys.dual;};
  delete($slf->{'_msg'});
  return $tgt->set_test(q{}) if &{$slf->{'_fct'}}($slf, $ctx, $sql, 1, undef,
    \&_test_sql, [$ctx, \@buf]) && (scalar @buf) && $buf[0] eq 'X';

  if ($tgt->test_initial)
  { @buf = ();
    delete($slf->{'_msg'});
    return $tgt->set_test(q{}) if &{$slf->{'_fct'}}($slf, $ctx, $sql, 1, undef,
      \&_test_sql, [$ctx, \@buf]) && (scalar @buf) && $buf[0] eq 'X';
    $tgt->clear_initial;
  }

  ++$slf->{'_err'};
  $slf->{'_not'} = 'No database access in the last run';

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

sub _test_sql
{ my ($slf, $rec, $lin) = @_;

  # Interrupt when a SQL error is encountered
  if ($lin =~ $LOG)
  { $slf->{'_msg'} = $lin;
    return 1;
  }

  # Save the line in the last SQL result
  push(@{$rec->[1]}, $lin);

  # Continue the result processing
  return 0;
}

=head2 S<writeLastSql([$rpt,][$min[,$max]])>

This macro writes a line range from the last SQL result to the report file.
It assumes the first and last line respectively as the default for the range
definition. You can use negative line numbers to specify lines from the
buffer end. It returns 1 for a successful completion. Otherwise, it returns 0.

=cut

sub _m_write_last
{ my ($slf, $ctx, $arg, @arg) = @_;
  my ($rpt);

  return
    (ref($arg) =~ $RPT)       ? _s_write_last($slf, $ctx, $arg, @arg) :
    ($rpt = $ctx->get_report) ? _s_write_last($slf, $ctx, $rpt, $arg, @arg) :
                                0;
}

sub _s_write_last
{ my ($slf, $ctx, $rpt, $min, $max) = @_;
  my ($buf, $rec);

  # Validate the range
  $buf = $slf->{'_sql'};
  $min = (!defined($min) || ($#$buf + $min) < -1) ? 0 :
         ($min < 0) ? $#$buf + $min + 1 :
         $min;
  $max = (!defined($max)) ? $#$buf :
         (($#$buf + $max) < -1) ? 0 :
         ($max < 0) ? $#$buf + $max + 1 :
         $max;

  $rec = [$ctx, $rpt, undef, 0];
  foreach my $lin (@{$buf}[$min..$max])
  { return 0 if _write_sql($slf, $rec, $lin);
  }
  return 1;
}

=head2 S<writeSql([$rpt,]$sql[,$inc[,$re...]])>

This macro writes the output of the SQL statements in the report file. It
returns 1 for a successful completion. If the execution time exceeds the limit
or if the maximum number of attempts has been reached, it returns 0.

Only lines between C<___Cut___> lines are inserted in the report file.

Some special lines are identified:

=over 4

=item *

Lines like C<___Separator(E<lt>nameE<gt>)___> are replaced by the lines
contained in the corresponding array variable C<@E<lt>nameE<gt>>.

=item *

Lines like C<___Macro_E<lt>nameE<gt>(E<lt>numE<gt>)___> are replaced by the
execution of the specified macro with C<E<lt>numE<gt>> as an argument. A
positive return value resets the alarm.

=item *

Lines like C<___Capture_E<lt>nameE<gt>___> indicate that the following lines
are copied to the named capture buffer. They clear the capture buffer unless
their name is in lower case.

=item *

Lines like C<___Capture_Only_E<lt>nameE<gt>___> indicate that the following
lines are removed from the result flow and added to the named capture
buffer. They clear the capture buffer unless their name is in lower case.

=item *

Lines like C<___End_Capture___> disable any previous line capture.

=back

You can insert input pauses with lines like C<!!sleep(E<lt>nE<gt>)>.

It is possible to increase the execution limit by specifying an increasing
factor as an argument. A negative value disables timeout.

=cut

sub _m_write_sql
{ my ($slf, $ctx, $arg, @arg) = @_;
  my ($rpt);

  return
    (ref($arg) =~ $RPT)       ? _s_write_sql($slf, $ctx, $arg, @arg) :
    ($rpt = $ctx->get_report) ? _s_write_sql($slf, $ctx, $rpt, $arg, @arg) :
                                0;
}

sub _s_write_sql
{ my ($slf, $ctx, $rpt, $sql, $inc, @arg) = @_;
  my ($tbl);

  # Get the regular expressions
  $slf->{'_hit'} = [];
  foreach my $str (@arg)
  { next unless defined($str);
    $tbl = [] unless ref($tbl);
    push(@{$tbl}, RDA::Object::View->is_pattern($str));
  }

  # Execute the SQL statement
  return &{$slf->{'_fct'}}($slf, $ctx, $sql, $inc, $tbl, \&_write_sql,
    [$ctx, $rpt, undef, $slf->{'frk'} ? get_alarm($slf, $inc) : 0, $tbl]);
}

sub _write_sql  ## no critic (Complex)
{ my ($slf, $rec, $lin) = @_;

  if ($lin =~ $MAC)
  { my ($blk, $val);

    # Suspend alarm
    $slf->{'_dur'} = $rec->[3] ? clear_alarm() + 1 : 0;

    # Execute a macro
    $blk = $1 ? $rec->[0]->get_current : $rec->[0];
    $val = new_number($3);
    $val = RDA::Value::List->new($val);
    $val = $blk->define_operator([$2, '.macro.'], $blk, $2, $val);
    eval {
      $val = $val->eval_as_number;
      _m_reset_timeout($slf, undef, $val) if $rec->[3] && $val > 0;
      };

    # Must clear it, to execute a prefix block on next write
    $rec->[2] = undef;

    # Restart the alarm when suspended
    alarm($slf->{'_dur'}) if $slf->{'_dur'};
  }
  elsif ($lin =~ $ERR && $slf->{'_ctl'}->get_current->is_fatal)
  { # Generate a SQL error
    die get_string('ERR_SQL');
  }
  elsif ($lin =~ $BUF)
  { $rec->[5] = lc($2);
    $rec->[6] = $1;
    $slf->{'_buf'}->{$rec->[5]} = [] unless $2 eq $rec->[5];
  }
  elsif ($lin eq $EOC)
  { $rec->[5] = $rec->[6] = undef;
  }
  elsif ($rec->[6])
  { push(@{$slf->{'_buf'}->{$rec->[5]}}, $lin);
  }
  else
  { my ($lim, $val);

    # Get the report file handle, with the alarm suspended
    unless ($rec->[2])
    { $lim = $rec->[3] ? clear_alarm() + 1 : 0;
      $rec->[2] = $rec->[1]->get_handle;
      set_alarm($lim) if $lim;
    }

    # Write the line to the report file
    if ($lin =~ $SEP)
    { $val = $rec->[0]->get_context->get_value("\@$1");
      foreach my $txt ($val->eval_as_array)
      { $rec->[1]->write("$txt\n") if defined($txt);
      }
    }
    else
    { $rec->[1]->write("$lin\n");
      if ($rec->[4])
      { foreach my $pat (@{$rec->[4]})
        { if ($lin =~ $pat)
          { push(@{$slf->{'_hit'}}, $lin);
            last;
          }
        }
      }
      push(@{$slf->{'_buf'}->{$rec->[5]}}, $lin) if $rec->[5];
    }
  }

  # Continue the result processing
  return 0;
}

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

# Check if fork is allowed and implemented
sub _chk_fork
{ my ($flg) = @_;

  if ($flg && !RDA::Object::Rda->is_windows && !RDA::Object::Rda->is_vms)
  { eval {
      my $pid;

      die "No fork\n" unless defined($pid = fork());
      exit(0) unless $pid;
      waitpid($pid, 0);
    };
    return 1 unless $@;
  }
  return 0;
}

# Convert a job directive
sub _conv_job
{ my ($lin) = @_;

  return
    ($lin =~ qr/^(EXIT|QUIT)\s*$/)     ? "$1\n" :
    ($lin =~ qr/^CAPTURE\s+ONLY\s+(\w+)\s*$/)
                                       ? "PROMPT ___Capture_Only_$1___\n" :
    ($lin =~ qr/^CAPTURE\s+(\w+)\s*$/) ? "PROMPT ___Capture_$1___\n" :
    ($lin =~ qr/^CUT\s*$/)             ? "PROMPT ___Cut___\n" :
    ($lin =~ qr/^DESC (.*)$/)          ? "PROMPT ___Tag_DESC $1___\nDESC $1\n" :
    ($lin =~ qr/^ECHO(.*)$/)           ? "PROMPT$1\n" :
    ($lin =~ qr/^END\s*$/)             ? "PROMPT ___End_Capture___\n" :
    ($lin =~ qr/^LONG\((\d+)\)\s*$/)   ? "SET long $1\n" :
    ($lin =~ qr/^MACRO\s+(\w+)\((\d+)\)\s*$/) ? "PROMPT ___Macro_$1($2)___\n" :
    ($lin =~ qr/^SET\s(\w+)\s*$/)      ? "PROMPT ___Set_$1___\n" :
                                         q{};
}

# Get the target information
sub _get_info  ## no critic (Complex)
{ my ($slf, $tgt) = @_;
  my ($dba, $env, $grp, $loc, $pwd, $sid, $str, $suf, $txt, $usr);

  return $slf->{'_inf'} if exists($slf->{'_inf'});

  # Get the target information
  $tgt = exists($slf->{'_tgt'})
    ? $slf->{'_tgt'}
    : $slf->{'_ctl'}->get_current
    unless defined($tgt);
  $grp = $slf->{'_grp'};
  $dba = $tgt->get_info('dba');
  $loc = $tgt->get_info('loc');
  $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);
    $dba = ($suf =~ s/\s+as\s+sysdba$//i)             ? 1 :
           ($suf =~ s/\s+as\s+sysoper$/ as sysoper/i) ? 0 :
                                                        $dba;
    if ($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);
    $dba = ($suf =~ s/\s+as\s+sysdba$//i)             ? 1 :
           ($suf =~ s/\s+as\s+sysoper$/ as sysoper/i) ? 0 :
                                                        $dba;
    $str = $suf;
  }
  ## no critic (Numbered)
  $suf = !defined($sid)    ? $suf :
         ($sid =~ $RE_EZC) ? sprintf($NET2, q{@}, $2, $3,  uc($4), $suf) :
         ($sid =~ $RE_EZD) ? sprintf($NET2, q{@}, $2, 1521, uc($3), $suf) :
         ($sid =~ $RE_SID) ? sprintf($NET1, q{@}, $1, $2, uc($3), $suf) :
         ($sid =~ $RE_SVC) ? (length($3)
                               ? sprintf($NET3, q{@}, $1, $2, uc($4), $3, $suf)
                               : sprintf($NET2, q{@}, $1, $2, uc($4), $suf)) :
         ($loc)            ? $suf :
                             q{@}.uc($sid).$suf;
  ## use critic

  $pwd = $1 if $usr =~ s/\/(.*?)[\n\r]*$// && length($1);
  $usr = uc($usr);
  if ($dba)
  { $str .= ' as SYSDBA';
    $suf .= ' as sysdba';
  }

  # 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 $slf->{'_inf'} = ['oracle', $grp, $usr, $txt, $suf];
}

# Get the login information
sub _get_login
{ my ($slf, $tgt) = @_;
  my ($grp, $pwd, $suf, $txt, $typ, $usr);

  # Get the target information
  ($typ, $grp, $usr, $txt, $suf) = @{_get_info($slf, $tgt)};

  # Get the user password
  $pwd = $slf->{'_col'}->get_access->get_password($typ, $grp, $usr, $txt,
    $slf->{'_col'}->is_isolated ? q{?} : undef);
  die get_string('NO_PASSWORD')
    unless defined($pwd);

  # Create the login string
  return $slf->{'_log'} = "$usr/$pwd$suf";
}

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

# Execute SQL code (fork method)
sub _run_sql_fork  ## no critic (Complex)
{ my ($slf, $ctx, $sql, $inc, $tbl, $fct, $rec) = @_;
  ## no critic (Numbered)
  my ($buf, $end, $err, $lim, $pid1, $pid2, $tgt, $trc, $vms);

  # Abort when SQL is missing or when the number of tries have been reached
  ++$slf->{'_req'};
  unless ($sql)
  { $slf->{'_msg'} = get_string('NO_SQL');
    ++$slf->{'_err'};
    return 0;
  }
  $tgt = $slf->{'_ctl'}->get_current;
  unless ($tgt->is_enabled)
  { $slf->{'_msg'} = get_string('DISABLED');
    ++$slf->{'_skp'};
    return 0;
  }

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

  # Get the login information
  _get_login($slf, $tgt) unless exists($slf->{'_log'});

  # Run the SQL code in a limited execution time
  $lim = get_alarm($slf, $inc);
  if ($trc = $tgt->get_level)
  { for (split(/\n/, $sql))
    { debug('SQL: ', $_);
    }
  }
  eval {
    local $SIG{'__WARN__'} = sub {};
    local $SIG{'ALRM'}     = sub { die "$ALR\n" } if $lim;
    local $SIG{'PIPE'}     = sub { exit(0); };

    # Prepare the requester pipe
    pipe(IN1, OUT1) or die get_string('ERR_PIPE', $!);

    # Launch the requester process
    die get_string('ERR_FORK', $!) unless defined($pid1 = fork());
    unless ($pid1)
    { close(IN1);
      $buf = $slf->{'_log'}.$BEG;
      syswrite(OUT1, $buf, length($buf));
      foreach my $lin (split(/\n/, $sql))
      { if ($lin =~ $SLP)
        { sleep($2);
        }
        elsif ($lin =~ $CLL)
        { my ($blk, $val);

          $blk = $2 ? $ctx->get_current : $ctx;
          $val = new_number($4);
          $val = RDA::Value::List->new($val);
          $val = $blk->define_operator([$3, '.macro.'], $blk, $3, $val);
          $val->eval_value;
        }
        elsif ($lin =~ s/^#\s*//)
        { my ($lgt);

          $buf = _conv_job($lin);
          syswrite(OUT1, $buf, $lgt) if ($lgt = length($buf));
        }
        else
        { $buf = qq{$lin\n};
          syswrite(OUT1, $buf, length($buf));
        }
      }
      syswrite(OUT1, $END, length($END));
      exit(0);
    }
    close(OUT1);

    # Prepare the SQL*Plus pipe
    pipe(IN2, OUT2) or die get_string('ERR_PIPE', $!);

    # Launch SQL*Plus
    die get_string('ERR_FORK', $!) unless defined($pid2 = fork());
    unless ($pid2)
    { my ($cmd, $val, @opt);
      local $SIG{'__WARN__'} = sub {print @_};

      ($cmd) = $tgt->set_sqlplus;
      @opt = ('-s');
      push(@opt, '-prelim') if $tgt->get_prelim;
      close(IN2);
      open(STDIN,  '<&IN1') or die;   ## no critic (Open)
      open(STDOUT, '>&OUT2') or die;  ## no critic (Open)
      open(STDERR, '>&OUT2') or die;  ## no critic (Open)
      exec($cmd, @opt);
      warn get_string('ERR_LAUNCH', $!);
      exit(1);
    }

    # Parent process that treats the SQL*Plus output
    close(IN1);
    close(OUT2);

    # Limit its execution to prevent RDA hangs
    set_alarm($lim) if $lim;

    # Treat the SQL*Plus output
    my ($cat, $flg, $hit, $lin, $skp);
    $skp = $cat = $end = $flg = $vms = 0;
    $hit = $slf->{'_hit'};
    while (<IN2>)
    { s/[\s\r\n]+$//;
      debug('SQL> ', $_) if $trc;
      if (m/^$CUT$/)
      { $flg = !$flg;
      }
      elsif ($flg)
      { if ($cat)
        { if (m/^\]\]\]$/)
          { last if &$fct($slf, $rec, $lin);
            $cat = 0;
            $skp = 1;
          }
          else
          { $lin .= $_;
          }
        }
        elsif (m/^\[\[\[$/)
        { $lin = q{};
          $cat = 1;
        }
        elsif ($skp && $_ eq q{})
        { $skp = $vms;
        }
        elsif ($_ eq $VMS)
        { $skp = $vms = 1;
        }
        else
        { $skp = $vms;
          last if ($end = &$fct($slf, $rec, $_));
        }
      }
      elsif ($_ =~ $WRN)
      { next;
      }
      elsif ($_ =~ $LOG)
      { die get_string('ERR_LOGIN', $3, $1) if $tgt->get_access;
        $slf->{'_msg'} = $_;
        $end = 1;
        last;
      }
      elsif ($tbl)
      { foreach my $re (@{$tbl})
        { if ($_ =~ $re)
          { push(@{$hit}, $_);
            last;
          }
        }
      }
    }

    # Disable alarms
    clear_alarm() if $lim;
  };
  if (($err = $@) || $end)
  { RDA::Object::Rda->kill_child($pid2) if $pid2;
    RDA::Object::Rda->kill_child($pid1) if $pid1;
  }
  close(IN2);
  waitpid($pid1, 0) if $pid1;
  waitpid($pid2, 0) if $pid2;

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

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

# Execute SQL code (using a temporary file)
sub _run_sql_tmp  ## no critic (Complex)
{ my ($slf, $ctx, $sql, $inc, $tbl, $fct, $rec) = @_;
  my ($alm, $bkp, $buf, $cmd, $env, $err, $ifh, $lim, $pid, $tmp, $tgt, $trc,
      $vms);

  # Abort when SQL is missing or when the number of tries have been reached
  ++$slf->{'_req'};
  unless ($sql)
  { $slf->{'_msg'} = get_string('NO_SQL');
    ++$slf->{'_err'};
    return 0;
  }
  $tgt = $slf->{'_ctl'}->get_current;
  unless ($tgt->is_enabled)
  { $slf->{'_msg'} = get_string('DISABLED');
    ++$slf->{'_skp'};
    return 0;
  }

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

  # Get the login information
  _get_login($slf, $tgt) unless exists($slf->{'_log'});

  # Run the SQL code in a limited execution time
  $lim = get_alarm($slf, $inc);
  $tmp = $slf->{'_wrk'}->get_work($WRK, 1);
  $vms = $slf->{'_vms'};
  if ($trc = $tgt->get_level)
  { for (split(/\n/, $sql))
    { debug('SQL: ', $_);
    }
  }
  eval {
    local $SIG{'__WARN__'} = sub {};
    local $SIG{'ALRM'}     = sub { die "$ALR\n" } if $lim;
    local $SIG{'PIPE'}     = sub { die "$ALR\n" } if $lim;

    # Limit its execution to prevent RDA hangs
    set_alarm($lim) if $lim;

    # Execute SQL*Plus
    ($cmd, $bkp) = $tgt->set_sqlplus;
    $cmd = RDA::Object::Rda->quote($cmd) unless $vms;
    $pid = open(OUT, q{| }.$cmd.' -s '  ## no critic (Handle,Open)
      .($tgt->get_prelim ? '-prelim' : q{})
      .' >'.RDA::Object::Rda->quote($tmp)
      .' 2>&1') or die get_string('ERR_LAUNCH', $!);
    $buf = $slf->{'_log'}.$BEG;
    syswrite(OUT, $buf, length($buf));
    foreach my $lin (split(/\n/, $sql))
    { if ($lin =~ $SLP)
      { sleep($2);
      }
      elsif ($lin =~ $CLL)
      { my ($blk, $val);

        $blk = $2 ? $ctx->get_current : $ctx;
        $val = new_number($4);
        $val = RDA::Value::List->new($val);
        $val = $blk->define_operator([$3, '.macro.'], $blk, $3, $val);
        $val->eval_value;
      }
      elsif ($lin =~ s/^#\s*//)
      { my ($lgt);

        $buf = _conv_job($lin);
        syswrite(OUT, $buf, $lgt) if ($lgt = length($buf));
      }
      else
      { $buf = qq{$lin\n};
        syswrite(OUT, $buf, length($buf));
      }
    }
    syswrite(OUT, $END, length($END));
    waitpid($pid,0);

    # Disable alarms
    clear_alarm() if $lim;
  };
  if ($err = $@)
  { $alm = 1 if $err =~ m/^$ALR\n/;
    RDA::Object::Rda->kill_child($pid) if $pid;
  }
  close(OUT);

  # Restore the environment
  $tgt->reset_sqlplus($bkp);

  # Treat the SQL*Plus output
  $ifh = IO::File->new;
  if ($ifh->open("<$tmp"))
  { eval {
      my ($cat, $flg, $hit, $lin, $skp, $val);
      $cat = $flg = 0;
      $hit = $slf->{'_hit'};
      $skp = $vms;
      while (<$ifh>)
      { s/[\s\r\n]+$//;
        debug('SQL> ', $_) if $trc;
        if (m/^$CUT$/)
        { $flg = !$flg;
        }
        elsif ($flg)
        { if ($cat)
          { if (m/^\]\]\]$/)
            { last if &$fct($slf, $rec, $lin);
              $cat = 0;
              $skp = 1;
            }
            else
            { $lin .= $_;
            }
          }
          elsif (m/^\[\[\[$/)
          { $lin = q{};
            $cat = 1;
          }
          elsif ($skp && $_ eq q{})
          { $skp = $vms;
          }
          elsif ($_ eq $VMS)
          { $skp = $vms = 1;
          }
          elsif (! m/^RDA\>$/)
          { $skp = $vms;
            last if &$fct($slf, $rec, $_);
          }
        }
        elsif ($_ =~ $WRN)
        { next;
        }
        elsif ($_ =~ $LOG)
        { die get_string('ERR_LOGIN', $3, $1) if $tgt->get_access;
          $slf->{'_msg'} = $_;
          last;
        }
        elsif ($_ =~ $MIS)
        { $val = get_string('ERR_LAUNCH', $1);
          die $val if $tgt->get_access;
          $val =~ s/\n$//;
          $slf->{'_msg'} = $val;
          last;
        }
        elsif ($tbl)
        { foreach my $re (@{$tbl})
          { if ($_ =~ $re)
            { push(@{$hit}, $_);
              last;
            }
          }
        }
      }
    };
    $err = $@ if $@;
    $ifh->close;
    $slf->{'_wrk'}->clean_work($WRK);
  }

  # Detect and treat interrupts
  if ($err)
  { unless ($alm)
    { ++$slf->{'_err'};
      die $err;
    }
    $slf->_log_timeout($ctx, $tgt);
    return 0;
  }

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

1;

__END__

=head1 SEE ALSO

L<RDA::Agent|RDA::Agent>,
L<RDA::Alarm|RDA::Alarm>,
L<RDA::Driver::Library|RDA::Driver::Library>,
L<RDA::Object|RDA::Object>,
L<RDA::Object::Access|RDA::Object::Access>,
L<RDA::Object::Buffer|RDA::Object::Buffer>,
L<RDA::Object::Collect|RDA::Object::Collect>,
L<RDA::Object::Output|RDA::Object::Output>,
L<RDA::Object::Pipe|RDA::Object::Pipe>,
L<RDA::Object::Rda|RDA::Object::Rda>,
L<RDA::Object::Report|RDA::Object::Report>,
L<RDA::Object::Target|RDA::Object::Target>,
L<RDA::Object::View|RDA::Object::View>,
L<RDA::SDCL::Block|RDA::SDCL::Block>,
L<RDA::Text|RDA::Text>,
L<RDA::Target::Db|RDA::Target::Db>,
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