# Sqlplus.pm: Class Used for Database Requests Using SQL*Plus

package RDA::Driver::Sqlplus;

# $Id: Sqlplus.pm,v 1.17 2015/05/27 17:01:10 RDA Exp $
# ARCS: $Header: /home/cvs/cvs/RDA_8/src/scripting/lib/RDA/Driver/Sqlplus.pm,v 1.17 2015/05/27 17:01:10 RDA Exp $
#
# Change History
# 20150527  MSC  Introduce the use_alarm method.

=head1 NAME

RDA::Driver::Sqlplus - Class Used for Database Requests Using SQL*Plus

=head1 SYNOPSIS

 require RDA::Driver::Sqlplus;

=head1 DESCRIPTION

The objects of the C<RDA::Driver::Sqlplus> class are used to interface a
database using SQL*Plus.

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::Object::Access qw($RE_EXT $RE_EZC $RE_EZD $RE_SID $RE_SVC check_sid);
  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.17 $ =~ /(\d+)\.(\d+)/);
@ISA     = qw(Exporter);

# Define the global private constants
my $ALR = q{___Alarm___};
my $BUF = qr/^#\s*CAPTURE(\s+ONLY)?\s+(\w+)\s*$/;
my $CLL = qr/^#\s*CALL\s+(caller:)?(\w+)\((\d+)\)\s*$/;
my $CLS = qr/^#\s*(EXIT|QUIT)\s*$/;
my $CUT = q{___Cut___};
my $DSC = qr/^#\s*(DESC\s+(.*))$/;
my $ECH = qr/^#\s*ECHO(.*)$/;
my $EOC = qr/^#\s*END\s*$/;
my $ERR = qr/^ERROR at line \d+:$/i;
my $LNG = qr/^#\s*LONG\((\d+)\)\s*$/;
my $LOG = qr/^((ORA|RDA|SP2)-\d{4,}):\s*(.*)/;
my $MAC = qr/^#\s*MACRO\s+((caller:)?\w+)\((\d+)\)\s*$/;
my $MIS = qr/^('.*' is not recognized as an internal or external command)/;
## no critic (Interpolation,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
my $SET = qr/^#\s*SET\s+(\w+)\s*$/;
my $SLP = qr/^#\s*SLEEP\((\d+)\)\s*$/;
my $STM = qr/^#\s*((PL)?SQL(:\w+|\d*))\s*$/;
my $SWT = qr/^#\s*CUT\s*$/;
my $TAG = qr/___Tag_(.+)___$/;
my $VMS = q{___Set_VMS___};
my $WRK = q{dbi.txt};
my $WRN = qr/^ORA-280(02|11):/;

# 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 long 1024
set newpage none
set pagesize 20000
set pause off
set sqlprompt RDA>
set tab off
set timing off
set verify off
set serveroutput on size 1000000
prompt $CUT
};
my $END = qq{prompt $CUT
exit
};
my $VER = q{SELECT version
 FROM product_component_version
 WHERE product LIKE 'Oracle%' OR product LIKE 'Personal Oracle%'};
## use critic

# Define the global private variables

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

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

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

C<RDA::Driver::Sqlplus> 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<'-dft'> > Default password

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

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

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

=item S<    B<'-grp'> > Default credential group

=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<'-tgt'> > Reference to the target control object

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

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

=item S<    B<'-vms'> > VMS indicator

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

=back

Internal keys are prefixed by a dash.

=cut

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

  # Create the object
  $slf = bless {
    dur  => 0,
    lim  => check_alarm($col->get_first('DEFAULT.N_SQL_TIMEOUT', 30)),
    try  => 0,
    -col => $col,
    -err => 0,
    -dft => $col->is_isolated ? q{?} : undef,
    -frk => $col->get_config->can_fork > 0,
    -out => 0,
    -req => 0,
    -skp => 0,
    -tgt => $tgt,
    -typ => 'oracle',
    -vms => RDA::Object::Rda->is_vms,
    }, ref($cls) || $cls;

  # Analyze the target
  $slf->{'-grp'} =
    check_sid($col->get_agent->get_env('ORACLE_SID', q{}));
  $slf->{'-inf'} = _get_info($slf,$tgt);

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

  # Return the object reference
  return $slf;
}

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

This method deletes the object.

=cut

sub delete_object
{ 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>describe($ctx,$obj)>

This method returns a hash describing the specified object.

=cut

sub describe
{ my ($slf, $ctx, $obj) = @_;
  my ($dsc);

  $dsc = {row => [], typ => {}};
  &{$slf->{'-fct'}}($slf, $ctx, "#DESC $obj", 1, \&_describe, $dsc);
  return $dsc;
}

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

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

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

  # Continue the search
  return 0;
}

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

This method executes a database job.

=cut

sub execute
{ my ($slf, $ctx, $job, $inc, $fct, $arg) = @_;

  return &{$slf->{'-fct'}}($slf, $ctx, $job, $inc, $fct, $arg);
}

=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_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>

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

=cut

sub get_dialects
{ return ('oracle');
}

=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>

This method returns the name of the database provider.

=cut

sub get_provider
{ return 'Oracle';
}

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

  &{$slf->{'-fct'}}($slf, $ctx, "#SQL\n$VER\n/", 1, \&_version, $slf)
    unless exists($slf->{'-ver'});
  return $slf->{'-ver'};
}

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

  return $slf->{'-ver'} = $lin;
}

=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'} = check_alarm($val);
}

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

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

=cut

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

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

  # Test the database connection
  $sql = "#SQL\nSELECT 'X' FROM sys.dual\n/";
  delete($slf->{'-msg'});
  return $tgt->set_test(q{}) if &{$slf->{'-fct'}}($slf, $ctx, $sql, 1,
    \&_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,
      \&_test_sql, [$ctx, \@buf]) && (scalar @buf) && $buf[0] eq 'X';
    $tgt->clear_initial;
  }

  ++$slf->{'-err'};
  $slf->{'-not'} = get_string('NoConnection');

  # 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<$h-E<gt>use_alarm($val)>

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

=cut

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

sub connect  ## no critic (Builtin)
{ return;
}

sub disconnect
{ return;
}

sub get_date_fmt
{ return;
}

sub get_sources
{ return ();
}

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

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

  # Get the target information
  $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 (!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);
    $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, $2, $3,  uc($4), $suf) :
         ($sid =~ $RE_EZD) ? sprintf($NET2, $2, 1521, uc($3), $suf) :
         ($sid =~ $RE_SID) ? sprintf($NET1, $1, $2, uc($3), $suf) :
         ($sid =~ $RE_SVC) ? (length($3)
                               ? sprintf($NET3, $1, $2, uc($4), $3, $suf)
                               : sprintf($NET2, $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))
  { $env = defined($env)
      ? get_string('PasswordAt', $usr.$str, $env)
      : get_string('Password', $usr.$str);
  }

  # Return the target information
  return $slf->{'-inf'} = ['oracle', $grp, $usr, $env, $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) = @{$slf->{'-inf'}};

  # Get the user password
  die get_string('NO_PASSWORD') unless defined($pwd =
    $slf->{'-col'}->get_access->get_password($typ, $grp, $usr, $txt,
                                             $slf->{'-dft'}));

  # 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, $fct, $rec) = @_;
  ## no critic (Numbered)
  my ($buf, $end, $err, $lim, $pid1, $pid2, $tag, $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->{'-tgt'};
  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 = $slf->get_alarm($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)
    { my ($flg);

      close(IN1);
      $buf = $slf->{'-log'}.$BEG;
      syswrite(OUT1, $buf, length($buf));
      foreach my $lin (split(/\n/, $sql))
      { if ($flg)
        { $flg = 0 if $lin eq q{/};
          $buf = qq{$lin\n};
          syswrite(OUT1, $buf, length($buf));
        }
        elsif ($lin =~ $BUF)
        { $buf = $1
            ? qq{PROMPT ___Capture_Only_$2___\n}
            : qq{PROMPT ___Capture_$2___\n};
          syswrite(OUT1, $buf, length($buf));
        }
        elsif ($lin =~ $CLL)
        { 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 =~ $CLS)
        { $buf = qq{$1\n};
          syswrite(OUT1, $buf, length($buf));
        }
        elsif ($lin =~ $DSC)
        { $buf = qq{PROMPT ___Tag_DESC $2___\nDESC $2\n};
          syswrite(OUT1, $buf, length($buf));
        }
        elsif ($lin =~ $ECH)
        { $buf = qq{PROMPT$1\n};
          syswrite(OUT1, $buf, length($buf));
        }
        elsif ($lin =~ $EOC)
        { $buf = qq{PROMPT ___End_Capture___\n};
          syswrite(OUT1, $buf, length($buf));
        }
        elsif ($lin =~ $LNG)
        { $buf = qq{SET long $1\n};
          syswrite(OUT1, $buf, length($buf));
        }
        elsif ($lin =~ $MAC)
        { $buf = qq{PROMPT ___Macro_$1($3)___\n};
          syswrite(OUT1, $buf, length($buf));
        }
        elsif ($lin =~ $SET)
        { $buf = qq{PROMPT ___Set_$1___\n};
          syswrite(OUT1, $buf, length($buf));
        }
        elsif ($lin =~ $SLP)
        { sleep($1);
        }
        elsif ($lin =~ $STM)
        { $flg = 1;
          $buf = qq{PROMPT ___Tag_$1___\n};
          syswrite(OUT1, $buf, length($buf));
        }
        elsif ($lin =~ $SWT)
        { $buf = qq{PROMPT $CUT\n};
          syswrite(OUT1, $buf, length($buf));
        }
      }
      if ($flg)
      { $buf = qq{/\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, $lin, $skp);

    $skp = $cat = $end = $flg = $vms = 0;
    while (<IN2>)
    { s/[\s\r\n]+$//;
      debug('SQL> ', $_) if $trc;
      if (m/^$CUT$/)
      { $flg = !$flg;
      }
      elsif (m/^$TAG$/)
      { $tag = $1;
      }
      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;
      }
    }

    # 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;
    }
    _log_timeout($slf, $ctx, $tgt, $tag);
    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, $fct, $rec) = @_;
  my ($alm, $bkp, $buf, $cmd, $env, $err, $ifh, $lim, $pid, $tag, $tgt, $tmp,
      $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->{'-tgt'};
  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 = $slf->get_alarm($inc);
  $tmp = $slf->{'-wrk'}->get_work($WRK, 1);
  $vms = $slf->{'-vms'};
  if ($trc = $tgt->get_level)
  { for (split(/\n/, $sql))
    { debug('SQL: ', $_);
    }
  }
  eval {
    my ($flg);
    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 ($flg)
      { $flg = 0 if $lin eq q{/};
        $buf = qq{$lin\n};
        syswrite(OUT, $buf, length($buf));
      }
      elsif ($lin =~ $BUF)
      { $buf = $1
          ? qq{PROMPT ___Capture_Only_$2___\n}
          : qq{PROMPT ___Capture_$2___\n};
        syswrite(OUT, $buf, length($buf));
      }
      elsif ($lin =~ $EOC)
      { $buf = qq{PROMPT ___End_Capture___\n};
        syswrite(OUT, $buf, length($buf));
      }
      elsif ($lin =~ $CLL)
      { 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 =~ $CLS)
      { $buf = qq{$1\n};
        syswrite(OUT, $buf, length($buf));
      }
      elsif ($lin =~ $DSC)
      { $buf = qq{PROMPT ___Tag_DESC $2___\nDESC $2\n};
        syswrite(OUT, $buf, length($buf));
      }
      elsif ($lin =~ $ECH)
      { $buf = qq{PROMPT$1\n};
        syswrite(OUT, $buf, length($buf));
      }
      elsif ($lin =~ $LNG)
      { $buf = qq{SET long $1\n};
        syswrite(OUT, $buf, length($buf));
      }
      elsif ($lin =~ $MAC)
      { $buf = qq{PROMPT ___Macro_$1($3)___\n};
        syswrite(OUT, $buf, length($buf));
      }
      elsif ($lin =~ $SET)
      { $buf = qq{PROMPT ___Set_$1___\n};
        syswrite(OUT, $buf, length($buf));
      }
      elsif ($lin =~ $SLP)
      { sleep($1);
      }
      elsif ($lin =~ $STM)
      { $flg = 1;
        $buf = qq{PROMPT ___Tag_$1___\n};
        syswrite(OUT, $buf, length($buf));
      }
      elsif ($lin =~ $SWT)
      { $buf = qq{PROMPT $CUT\n};
        syswrite(OUT, $buf, length($buf));
      }
    }
    if ($flg)
    { $buf = qq{/\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, $lin, $skp, $val);

      $cat = $flg = 0;
      $skp = $vms;
      while (<$ifh>)
      { s/[\s\r\n]+$//;
        debug('SQL> ', $_) if $trc;
        if (m/^$CUT$/)
        { $flg = !$flg;
        }
        elsif (m/^$TAG$/)
        { $tag = $1;
        }
        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;
        }
      }
    };
    $err = $@ if $@;
    $ifh->close;
    $slf->{'-wrk'}->clean_work($WRK);
  }

  # Detect and treat interrupts
  if ($err)
  { unless ($alm)
    { ++$slf->{'-err'};
      die $err;
    }
    _log_timeout($slf, $ctx, $tgt, $tag);
    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::Library::Dbi|RDA::Library::Dbi>,
L<RDA::Object::Access|RDA::Object::Access>,
L<RDA::Object::Collect|RDA::Object::Collect>,
L<RDA::Object::Rda|RDA::Object::Rda>,
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