package RDA::Object::Sqlplus;

# $Id: Sqlplus.pm,v 1.4 2009/06/15 12:38:28 mschenke Exp $
# ARCS: $Header: /u02/webapps/workbench/cvs/RDA_4/src/scripting/lib/RDA/Object/Sqlplus.pm,v 1.4 2009/06/15 12:38:28 mschenke Exp $
#
# Change History
# 20090615  MSC  Improve context handling.

=head1 NAME

RDA::Object::Sqlplus - Class Used for Database Requests using Sql*Plus

=head1 SYNOPSIS

require RDA::Object::Sqlplus;

=head1 DESCRIPTION

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

The following methods are available:

=cut

use strict;

BEGIN
{ use Exporter;
  use File::Spec;
  use IO::Handle;
}

# Define the global public variables
use vars qw($VERSION);
$VERSION = sprintf("%d.%02d", q$Revision: 1.4 $ =~ /(\d+)\.(\d+)/);

# Define the global private variables
my $ALR = "___Alarm___";
my $CLL = qr/^#\s*CALL\s+(\w+)\((\d+)\)\s*$/;
my $CLS = qr/^#\s*(EXIT|QUIT)\s*$/;
my $CUT = "___Cut___";
my $DSC = qr/^#\s*(DESC (.*))$/;
my $ECH = qr/^#\s*ECHO(.*)$/;
my $ERR = qr/^ERROR at line \d+:$/i;
my $EXT = qr/^[^:]+:\d+:{1,2}[^:]+$/;
my $LNG = qr/^#\s*LONG\((\d+)\)\s*$/;
my $LOG = qr/^((ORA|SP2)-\d{4,}):\s*(.*)/;
my $MAC = qr/^#\s*MACRO\s+(\w+)\((\d+)\)\s*$/;
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';
my $SID = qr/^([^:]+):(\d+):([^:]+)$/;
my $SLP = qr/^#\s*SLEEP\((\d+)\)\s*$/;
my $STM = qr/^#\s*((PL)?SQL(:\w+|\d*))\s*$/;
my $SVC = qr/^([^:]+):(\d+):([^:]*):([^:]+)$/;
my $SWT = qr/^#\s*CUT\s*$/;
my $TAG = qr/___Tag_(.+)___$/;
my $VER = q{SELECT version
 FROM product_component_version
 WHERE product LIKE 'Oracle%' OR product LIKE 'Personal Oracle%'};
my $WRN = qr/^ORA-280(02|11):/;

# Define the Sql*Plus interface
my $BEG = "

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 = "prompt $CUT
exit
";

# Report the module version number
sub Version
{ $VERSION;
}

=head2 S<$h = RDA::Object::Sqlplus-E<gt>new($agt[,$usr,$pwd,$sid,$dba])>

The object constructor. It takes the agent object reference and the login
information as arguments.

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

=over 12

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

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

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

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

=item S<    B<'max' > > Maximum number of SQL script failures

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

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

=item S<    B<'-cmd'> > SQL*Plus command

=item S<    B<'-dba'> > Indicates if the login should be treated as sysdba

=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<'-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<'-pre'> > Prelim connection option

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

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

=item S<    B<'-seq'> > Temporary file sequence

=item S<    B<'-sid'> > Database system identifier

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

=item S<    B<'-tmp'> > Temporary file radix

=item S<    B<'-trc'> > SQL output trace flag

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

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

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

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

=back

Internal keys are prefixed by an underscore.

=cut

sub new
{ my ($cls, $agt, $usr, $pwd, $sid, $dba) = @_;
  my ($slf);

  # Create the object
  $slf = bless {}, ref($cls) || $cls;

  # Setup some parameters by default
  $slf->{'-agt'} = $agt;
  $slf->{'-cmd'} = $agt->get_setting('SQL_COMMAND', 'sqlplus');
  $slf->{'-frk'} = $agt->can_fork > 0;
  $slf->{'-dft'} = $agt->get_setting('NO_DIALOG', 0) ? '?' : undef;
  $slf->{'-pre'} = $agt->get_setting('SQL_PRELIM') ? '-prelim' : '';
  $slf->{'-req'} = $slf->{'-err'} = $slf->{'-out'} = $slf->{'-skp'} = 0;
  $slf->{'-trc'} = $agt->get_setting('SQL_TRACE', 0);
  $slf->{'-typ'} = 'oracle';
  $slf->{'-vms'} = $agt->is_vms;

  if (defined($usr))
  { $slf->{'-dba'} = $dba;
    $slf->{'-pwd'} = $pwd;
    $slf->{'-sid'} = $sid;
    $slf->{'-usr'} = $usr;
  }

  $slf->{'acc'} = $agt->get_setting('SQL_ACCESS', 0);
  $slf->{'dur'} = 0;
  $slf->{'err'} = $agt->get_setting('SQL_ERROR', 0);
  $slf->{'lim'} = _chk_alarm($agt->get_setting('SQL_TIMEOUT', 30));
  $slf->{'max'} = $agt->get_setting('SQL_ATTEMPTS', 3);
  $slf->{'try'} = 0;

  # Determine the request method
  if ($slf->{'-frk'})
  { $slf->{'-fct'} = \&_run_sql_fork;
  }
  else
  { my ($fil, $grp, $rpt);

    $rpt = $agt->get_setting('RPT_DIRECTORY', File::Spec->curdir);
    $grp = $agt->get_setting('RPT_GROUP');
    $slf->{'-fct'} = \&_run_sql_tmp;
    $slf->{'-seq'} = 1;
    $slf->{'-tmp'} = File::Spec->catfile($rpt, "tmp_$grp\_$$\_");

    # Delete previous temporary files
    if (opendir(DIR, $rpt))
    { while (defined($fil = readdir(DIR)))
      { next unless $fil =~ m/^tmp_$grp\_\d+_\d+.txt$/i;
        $fil = File::Spec->catfile($rpt, $fil);
        1 while unlink($fil);
      }
      closedir(DIR);
    } 
  }

  # Return the object reference
  $slf;
}

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

This method deletes the object.

=cut

sub delete
{ undef %{$_[0]};
  undef $_[0];
}

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

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

=cut

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

  unless ($slf->{'-frk'})
  { my $agt = $slf->{'-agt'};

    $slf->{'-seq'} = 1;
    $slf->{'-tmp'} = File::Spec->catfile(
      $agt->get_setting('RPT_DIRECTORY', File::Spec->curdir),
      'tmp_'.$agt->get_setting('RPT_GROUP')."_$$\_"
      );
  }
}

=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);
  $dsc;
}

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

  # Interrupt when a SQL error is encountered
  die "RDA-00507: SQL error\n" if $lin =~ $ERR && $slf->{'err'};

  # Store the lines
  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
  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) = @_;

  &{$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;
  $val *= $slf->{'lim'};
  ($val > 1) ? int($val) : 1;
}

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

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

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

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

=cut

sub get_name
{ 'Oracle';
}

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

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

=cut

sub get_prelim
{ shift->{'-pre'} ? 1 : 0;
}

=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
{ 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
  $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'});
  $slf->{'-ver'};
}

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

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

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

This method indicates whether a SQL statement will be executed.

=cut

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

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

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

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

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

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

It returns the previous value of the flag.

=cut

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

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

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

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

It returns the previous value of the flag.

=cut

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

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

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

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

It returns the previous value of the counter.

=cut

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

  $cnt = 0 unless defined($cnt);
  $cnt = $slf->{'max'} if $cnt < 0;

  ($slf->{'try'}, $cnt) = ($cnt, $slf->{'try'});
  $cnt;
}

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

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

It returns the previous status.

=cut

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

  $flg = $flg ? '-prelim' : '';
  ($slf->{'-pre'}, $flg) = ($flg, $slf->{'-pre'});
  $flg ? 1 : 0;
}

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

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

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

This method manages the SQL trace flag. When the flag is set, it prints all SQL
lines to the screen. It remains unchanged if the flag value is undefined.

It returns the previous value of the flag.

=cut

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

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

=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 ($sql, @buf);

  # Test the database connection
  $slf->{'try'} = 0;
  delete($slf->{'-not'});
  $sql = "# SQL\nSELECT 'X' FROM sys.dual\n/";
  return ''
    if &{$slf->{'-fct'}}($slf, $ctx, $sql, 1, \&_test_sql, [$ctx, \@buf])
    && scalar(@buf) && $buf[0] eq 'X';
  ++$slf->{'-err'};
  $slf->{'-not'} = 'No database access in the last run';

  # Disable further access to the database
  $slf->{'try'} = $slf->{'max'};
  return 'RDA-00501: Database access disabled due to a connection problem';
}

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
  0;
}

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

sub connect
{ undef;
}

sub disconnect
{ undef;
}

# --- Internal functions ------------------------------------------------------

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

  return 0 unless $lim > 0;
  eval {alarm(0);};
  $@ ? 0 : $lim;
}

# Check the SID
sub _chk_sid
{ my ($sid, $dft) = @_;

  return $dft unless $sid;
  ($sid =~ $SID) ? join(':', $1, $2, uc($3)) :
  ($sid =~ $SVC) ? join(':', $1, $2, $3, uc($4)) :
                   uc($sid);
}

# Get the login information
sub _get_login
{ my ($slf) = @_;
  my ($agt, $grp, $loc, $pwd, $sid, $str, $suf, $typ, $usr);

  # Determine the user
  $agt = $slf->{'-agt'};
  $typ = $slf->{'-typ'};
  $str = $suf = '';
  if (exists($slf->{'-usr'}))
  { $usr = $slf->{'-usr'};
    $pwd = $slf->{'-pwd'};
    $sid = _chk_sid($slf->{'-sid'}, '');
    $loc = _chk_sid($agt->get_setting('ORACLE_SID'), '');
    $suf = ' as SYSDBA' if $slf->{'-dba'};
    if ($usr =~ m/^(.*)\@(\S+)(.*)$/)
    { ($usr, $sid, $suf) = ($1, _chk_sid($2), $3);
    }
    elsif ($usr =~ m/^(.*)\@(.*)$/)
    { ($usr, $suf) = ($1, $2);
    }
  }
  else
  { $usr = $agt->get_setting('SQL_LOGIN', 'SYSTEM');
    $loc = _chk_sid($agt->get_setting('ORACLE_SID'), '');
    $sid = ($agt->get_setting('DATABASE_LOCAL',1) && $loc !~ $EXT) ? '' : $loc;
    $suf = ' as SYSDBA' if $agt->get_setting('SQL_SYSDBA');

    $sid = _chk_sid($1) if $usr =~ s/\@(\S+)?.*$// && $1;
  }
  if ($usr =~ m/^(.*?)\/(.*)$/)
  { ($usr, $pwd) = (uc($1), $2);
  }
  else
  { $usr = uc($usr);
  }
  $str = (defined($sid) && length($sid)) ? "\@$sid$suf" : $suf;
  $suf = ($sid =~ $SID) ? sprintf($NET1, $1, $2, $3, $suf) :
         ($sid !~ $SVC) ? $str :
         length($3)     ? sprintf($NET3, $1, $2, $4, $3, $suf) :
                          sprintf($NET2, $1, $2, $4, $suf);

  # Get the password
  unless (defined($pwd))
  { $sid = $loc if $sid eq '';
    if ($agt->has_password($typ, $sid, $usr))
    { $pwd = $agt->get_password($typ, $sid, $usr);
    }
    else
    { $pwd = $agt->get_password($typ, $sid, $usr,
        "Enter the password for '$usr$str': ", $slf->{'-dft'});
      die "RDA-00508: Null password given; logon denied\n"
        unless defined($pwd) && length($pwd);
    }
  }

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

# Log a timeout event
sub _log_timeout
{ my $slf = shift;
  my $ctx = shift;

  ++$slf->{'try'};
  $slf->{'-agt'}->log_timeout($ctx, 'SQL', @_);
  $slf->{'-msg'} = 'RDA-00502: Database connection timeout';
  ++$slf->{'-out'};
}

# Execute SQL code (fork method)
sub _run_sql_fork
{ my ($slf, $ctx, $sql, $inc, $fct, $rec) = @_;
  my ($buf, $blk, $end, $err, $lim, $lin, $pid1, $pid2, $tag, $trc);

  # Abort when SQL is missing or when the number of tries have been reached
  ++$slf->{'-req'};
  unless ($sql)
  { $slf->{'-msg'} = 'RDA-00509: Missing SQL code';
    ++$slf->{'-err'};
    return 0;
  }
  unless ($slf->{'try'} < $slf->{'max'})
  { $slf->{'-msg'} = 'RDA-00510: SQL execution disabled';
    ++$slf->{'-skp'};
    return 0;
  }

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

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

  # Run the SQL code in a limited execution time
  $lim = $slf->get_alarm($inc);
  if ($trc = $slf->{'-trc'})
  { for (split(/\n/, $sql))
    { print "SQL: $_\n";
    }
  }
  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) || die "RDA-00503: Cannot create the pipe $!\n";

    # Launch the requester process
    die "RDA-00504: Cannot fork $!" unless defined($pid1 = fork());
    unless ($pid1)
    { my ($flg);

      close(IN1);
      $lin = $slf->{'-log'}.$BEG;
      syswrite(OUT1, $lin, length($lin));
      foreach $lin (split(/\n/, $sql))
      { if ($flg)
        { $flg = 0 if $lin eq '/';
          $lin .= "\n";
          syswrite(OUT1, $lin, length($lin));
        }
        elsif ($lin =~ $CLL)
        { my $val;

          $val = RDA::Value->new('N', $2);
          $val = RDA::Value->new('L', [$val]);
          $val = RDA::Value->new('M', $ctx, $1, $val);
          $val->eval_value;
        }
        elsif ($lin =~ $CLS)
        { $lin = "$1\n";
          syswrite(OUT1, $lin, length($lin));
        }
        elsif ($lin =~ $DSC)
        { $lin = "PROMPT ___Tag_DESC $2___\nDESC $2\n";
          syswrite(OUT1, $lin, length($lin));
        }
        elsif ($lin =~ $ECH)
        { $lin = "PROMPT$1\n";
          syswrite(OUT1, $lin, length($lin));
        }
        elsif ($lin =~ $LNG)
        { $lin = "SET long $1\n";
          syswrite(OUT1, $lin, length($lin));
        }
        elsif ($lin =~ $MAC)
        { $lin = "PROMPT ___Macro_$1($2)___\n";
          syswrite(OUT1, $lin, length($lin));
        }
        elsif ($lin =~ $SLP)
        { sleep($1);
        }
        elsif ($lin =~ $STM)
        { $flg = 1;
          $lin = "PROMPT ___Tag_$1___\n";
          syswrite(OUT1, $lin, length($lin));
        }
        elsif ($lin =~ $SWT)
        { $lin = "PROMPT $CUT\n";
          syswrite(OUT1, $lin, length($lin));
        }
      }
      if ($flg)
      { $lin = "/\n";
        syswrite(OUT1, $lin, length($lin));
      }
      syswrite(OUT1, $END, length($END));
      exit(0);
    }
    close(OUT1);

    # Prepare the SQL*Plus pipe
    pipe(IN2, OUT2) || die "RDA-00503: Cannot create the pipe:\n $!\n";

    # Launch SQL*Plus
    die "RDA-00504: Cannot fork:\n $!" unless defined($pid2 = fork());
    unless ($pid2)
    { my @opt = ('-s');
      push(@opt, $slf->{'-pre'}) if $slf->{'-pre'};
      close(IN2);
      open(STDIN,  "<&IN1") or die;
      open(STDOUT, ">&OUT2") or die;
      open(STDERR, ">&OUT2") or die;
      exec($slf->{'-cmd'}, @opt)
        || die "RDA-00505: Cannot launch SQL*Plus!:\n $!\n";
    }

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

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

    # Treat the SQL*Plus output
    my ($cat, $flg, $lin, $skp);

    $skp = $cat = $end = $flg = 0;
    while (<IN2>)
    { s/[\s\r\n]+$//;
      print "SQL> $_\n" 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 = '';
          $cat = 1;
        }
        elsif ($skp && m/^$/)
        { $skp = 0;
        }
        else
        { $skp = 0;
          last if ($end = &$fct($slf, $rec, $_));
        }
      }
      elsif ($_ =~ $WRN)
      { next;
      }
      elsif ($_ =~ $LOG)
      { die "RDA-00507: SQL Error: $3 ($1)\n" if $slf->{'acc'};
        $slf->{'-msg'} = $_;
        $end = 1;
        last;
      }
    }

    # Disable alarms
    alarm(0) if $lim;
  };
  if (($err = $@) || $end)
  { kill(9, $pid2) if $pid2;
    kill(9, $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, $tag);
    return 0;
  }

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

# Execute SQL code (using a temporary file)
sub _run_sql_tmp
{ my ($slf, $ctx, $sql, $inc, $fct, $rec) = @_;
  my ($err, $lim, $lin, $pid, $tag, $tmp, $trc);

  # Abort when SQL is missing or when the number of tries have been reached
  ++$slf->{'-req'};
  unless ($sql)
  { $slf->{'-msg'} = 'RDA-00509: Missing SQL code';
    ++$slf->{'-err'};
    return 0;
  }
  unless ($slf->{'try'} < $slf->{'max'})
  { $slf->{'-msg'} = 'RDA-00510: SQL execution disabled';
    ++$slf->{'-skp'};
    return 0;
  }

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

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

  # Run the SQL code in a limited execution time
  $lim = $slf->get_alarm($inc);
  $tmp = sprintf('%s%d.txt', $slf->{'-tmp'}, $slf->{'-seq'});
  if ($trc = $slf->{'-trc'})
  { for (split(/\n/, $sql))
    { print "SQL: $_\n";
    }
  }
  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
    alarm($lim) if $lim;

    # Execute SQL*Plus
    ($pid = open(OUT, '| '.$slf->{'-cmd'}.' -s '.$slf->{'-pre'}
      .' >'.$slf->{'-agt'}->quote($tmp)
      .' 2>&1')) || die "RDA-00505: Cannot launch SQL*Plus:\n $!\n";
    $lin = $slf->{'-log'}.$BEG;
    syswrite(OUT, $lin, length($lin));
    foreach $lin (split(/\n/, $sql))
    { if ($flg)
      { $flg = 0 if $lin eq '/';
        $lin .= "\n";
        syswrite(OUT, $lin, length($lin));
      }
      elsif ($lin =~ $CLL)
      { my $val;

        $val = RDA::Value->new('N', $2);
        $val = RDA::Value->new('L', [$val]);
        $val = RDA::Value->new('M', $ctx, $1, $val);
        $val->eval_value;
      }
      elsif ($lin =~ $CLS)
      { $lin = "$1\n";
        syswrite(OUT, $lin, length($lin));
      }
      elsif ($lin =~ $DSC)
      { $lin = "PROMPT ___Tag_DESC $1___\nDESC $1\n";
        syswrite(OUT, $lin, length($lin));
      }
      elsif ($lin =~ $ECH)
      { $lin = "PROMPT$1\n";
        syswrite(OUT, $lin, length($lin));
      }
      elsif ($lin =~ $LNG)
      { $lin = "SET long $1\n";
        syswrite(OUT, $lin, length($lin));
      }
      elsif ($lin =~ $MAC)
      { $lin = "PROMPT ___Macro_$1($2)___\n";
        syswrite(OUT, $lin, length($lin));
      }
      elsif ($lin =~ $SLP)
      { sleep($1);
      }
      elsif ($lin =~ $STM)
      { $flg = 1;
        $lin = "PROMPT ___Tag_$1___\n";
        syswrite(OUT, $lin, length($lin));
      }
      elsif ($lin =~ $SWT)
      { $lin = "PROMPT $CUT\n";
        syswrite(OUT, $lin, length($lin));
      }
    }
    if ($flg)
    { $lin = "/\n";
      syswrite(OUT, $lin, length($lin));
    }
    syswrite(OUT, $END, length($END));
    waitpid($pid,0);

    # Disable alarms
    alarm(0) if $lim;
  };
  kill(9, $pid) if ($err = $@) && $pid;
  close(OUT);

  # Treat the SQL*Plus output
  if (open(IN, "<$tmp"))
  { eval {
      my ($cat, $flg, $lin, $skp, $vms);
      $cat = $flg = 0;
      $skp = $vms = $slf->{'-vms'};
      while (<IN>)
      { s/[\s\r\n]+$//;
        print "SQL> $_\n" 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 = '';
            $cat = 1;
          }
          elsif ($skp && m/^$/)
          { $skp = $vms;
          }
          elsif (! m/^RDA\>$/)
          { $skp = $vms;
            last if &$fct($slf, $rec, $_);
          }
        }
        elsif ($_ =~ $WRN)
        { next;
        }
        elsif ($_ =~ $LOG)
        { die "RDA-00507: SQL Error: $3 ($1)\n" if $slf->{'acc'};
          $slf->{'-msg'} = $_;
          last;
        }
      }
    };
    $err = $@ if $@;
    close(IN);
    1 while unlink($tmp);
    ++($slf->{'-seq'}) if -e $tmp;
  }

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

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

1;

__END__

=head1 SEE ALSO

L<RDA::Agent|RDA::Agent>, L<RDA::Block|RDA::Block>,
L<RDA::Render|RDA::Render>, L<RDA::Value|RDA::Value>

=head1 COPYRIGHT NOTICE

Copyright (c) 2002-2009, Oracle. All rights reserved.

=head1 TRADEMARK NOTICE

Oracle, JD Edwards, PeopleSoft, and Siebel are registered trademarks of Oracle
Corporation and/or its affiliates. Other names may be trademarks of their
respective owners.

=cut