package RDA::Object::Dbd;

# $Id: Dbd.pm,v 1.5 2009/08/05 12:34:23 mschenke Exp $
# ARCS: $Header: /u02/webapps/workbench/cvs/RDA_4/src/scripting/lib/RDA/Object/Dbd.pm,v 1.5 2009/08/05 12:34:23 mschenke Exp $
#
# Change History
# 20090618  LDE  Improve multiline treatment and error handling.

=head1 NAME

RDA::Object::Dbd - Class Used for Database Requests using DBD

=head1 SYNOPSIS

require RDA::Object::Dbd;

=head1 DESCRIPTION

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

The timeout mechanism is only effective on UNIX systems.

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.5 $ =~ /(\d+)\.(\d+)/);

# Define the global private variables
my $ALR = "___Alarm___";
my $CUT = "___Cut___";
my $EXT = qr/^[^:]+:\d+:{1,2}[^:]+$/;
my $LOG = qr/^((ORA|SP2)-\d{4,}):\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 $SVC = qr/^([^:]+):(\d+):([^:]*):([^:]+)$/;

my %tb_typ = (
  Oracle => {dsc => 'ora_types',
             log => \&ora_login,
             pwd => 0,
             typ => {1   => 'VARCHAR2',
                     2   => 'NUMBER',
                     8   => 'LONG',
                     12  => 'DATE',
                     23  => 'RAW',
                     24  => 'LONG RAW',
                     69  => 'ROWID',
                     96  => 'CHAR',
                     100 => 'BINARY_FLOAT',
                     101 => 'BINARY_DOUBLE',
                     108 => 'User-defined',
                     111 => 'REF',
                     112 => 'CLOB',
                     113 => 'BLOB',
                     114 => 'BFILE',
                     180 => 'TIMESTAMP',
                     181 => 'TIMESTAMP WITH TIME ZONE',
                     182 => 'INTERVAL YEAR TO MONTH',
                     183 => 'INTERVAL DAY TO SECOND',
                     208 => 'UROWID',
                     231 => 'TIMESTAMP WITH LOCAL TIME ZONE',
                    },
            },
  '?'    => {dsc => 'TYPES',
             log => \&dft_login,
             pwd => 1,
             typ => {},
            },
  );


my $ERR = qr/^ERROR at line \d+:$/i;
my $WRN = qr/^ORA-280(02|11):/;

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

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

C<RDA::Object::Dbd> 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<'-con'> > Connection attributes

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

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

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

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

=item S<    B<'-grp'> > Password group

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

=item S<    B<'-nam'> > Database name

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

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

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

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

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

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

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

=item S<    B<'-txt'> > Password request test

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

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

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

=back

Internal keys are prefixed by an underscore.

=cut

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

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

  # Setup some parameters by default
  $slf->{'-agt'} = $agt;
  $slf->{'-def'} = $tb_typ{exists($tb_typ{$typ}) ? $typ : '?'};
  $slf->{'-dft'} = $agt->get_setting('NO_DIALOG', 0) ? '?' : undef;
  $slf->{'-req'} = $slf->{'-err'} = $slf->{'-out'} = $slf->{'-skp'} = 0;
  $slf->{'-trc'} = $agt->get_setting('SQL_TRACE', 0);
  $slf->{'-typ'} = $typ;

  $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('DBI_TIMEOUT', 30));
  $slf->{'max'} = $agt->get_setting('SQL_ATTEMPTS', 3);
  $slf->{'try'} = 0;

  # Set the common attributes
  $slf->{'-con'} = {
    AutoCommit  => 0,
    LongReadLen => 1024,
    LongTruncOk => 1,
    RaiseError  => 0,
    TraceLevel  => $slf->{'-trc'},
    };

  # Determine the login information
  &{$slf->{'-def'}->{'log'}}($slf, $usr, $pwd, $sid, $dba);

  # Return the object reference
  $slf;
}

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

This method deletes the object.

=cut

sub delete
{ disconnect($_[0]);
  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) = @_;

}

=head1 OBJECT METHODS

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

This method connects from the database.

=cut

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

  # Abort when the number of tries have been reached
  ++$slf->{'-req'};
  unless ($slf->{'try'} < $slf->{'max'})
  { $slf->{'-msg'} = 'RDA-00510: SQL execution disabled';
    ++$slf->{'-skp'};
    return undef;
  }

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

    # Get the password
    $agt = $slf->{'-agt'};
    $flg = $slf->{'-def'}->{'pwd'};
    $usr = $slf->{'-usr'};
    unless (defined($pwd = $slf->{'-pwd'}) || $flg < 0)
    { $grp = $slf->{'-grp'};
      $typ = lc($slf->{'-typ'});
      if ($agt->has_password($typ, $grp, $usr))
      { $pwd = $agt->get_password($typ, $grp, $usr);
      }
      else
      { $pwd = $agt->get_password($typ, $grp, $usr, $slf->{'-txt'},
          $slf->{'-dft'});
        die "RDA-00508: Null password given; logon denied\n"
          unless (defined($pwd) && length($pwd)) || $flg;
      }
    }

    # Connect to the database
    unless (defined($slf->{'-dbh'} =
      DBI->connect('dbi:'.$slf->{'-typ'}.':'.$slf->{'-sid'}, $usr, $pwd,
        $slf->{'-con'})))
    { ($slf->{'-msg'} = $DBI::errstr) =~ $LOG;
      ++$slf->{'-err'};
      die "RDA-00507: SQL Error: $3 ($1)\n" if $slf->{'acc'};
      return undef;
    }
  }

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

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

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

=cut

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

  ++$slf->{'-req'};
  $dsc = {row => [], typ => {}};
  $lim = $slf->get_alarm;
  eval {
    local $SIG{'__WARN__'} = sub {};
    local $SIG{'ALRM'}     = sub { die "$ALR\n" } if $lim;

    alarm($lim) if $lim;
    if (($dbh = $slf->connect)
      && ($sth = $dbh->prepare("select * from $obj")))
    { $nam = $sth->{'NAME'};
      $typ = $sth->{$slf->{'-def'}->{'dsc'}};
      $tbl = $slf->{'-def'}->{'typ'};
      $off = $sth->{'NUM_OF_FIELDS'};
      while ($off > 0)
      { $cur = lc($nam->[--$off]);
        unshift(@{$dsc->{'row'}}, $cur);
        $dsc->{'typ'}->{$cur} = $tbl->{$typ->[$off]} || $typ->[$off];
      }
      $sth->finish;
    }
    alarm(0) if $lim;
    };

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

  # Return the object description
  $dsc;
}

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

This method disconnects from the database.

=cut

sub disconnect
{ my ($dbh);

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

=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) = @_;
  my ($dbh, $err, $flg, $lim, $lin, $lng, $row, $sth, $tag, $trc, @job);

  # Abort when job is missing or when the number of tries have been reached
  ++$slf->{'-req'};
  unless ($job)
  { $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'});

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

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

          $tag = $1;
          push(@sql, $lin) while defined($lin = shift(@job)) && $lin ne '/';
          next unless @sql;
          unless ($sth = $dbh->prepare(join("\n", @sql)))
          { $row = $DBI::errstr;
            if ($flg)
            { last if &$fct($slf, $arg, $row);
              next;
            }
            die "RDA-00507: SQL Error: $row\n" if $slf->{'acc'};
            $slf->{'-msg'} = $row;
            last;
          }
          $sth->execute;
          while (@row = $sth->fetchrow_array)
          { $row = join('|', @row);
            print "SQL> $row\n" if $trc;
            if ($row =~ $CUT)
            { $flg = !$flg;
            }
            elsif ($flg)
            { if ($row =~ m/^\[\[\[\012(.*)\012\]\]\]$/s)
              { $row = $1;
                $row =~ s/[\n\r]//gs;
              }
              last if &$fct($slf, $arg, $row);
            }
          }
          $sth->finish;
        }
        elsif ($lin =~ m/^#\s*(PLSQL\d*)\s*$/)
        { my ($buf, $cat, @sql);

          $tag = $1;
          push(@sql, $lin) while defined($lin = shift(@job)) && $lin ne '/';
          next unless @sql;
          unless ($sth = $dbh->prepare(join("\n", @sql)))
          { $row = $DBI::errstr;
            if ($flg)
            { 
              last if &$fct($slf, $arg, $DBI::errstr);
              next;
            }
            die "RDA-00507: SQL Error: $row\n" if $slf->{'acc'};
            $slf->{'-msg'} = $row;
            last;
          }
          $dbh->func(1000000, 'dbms_output_enable');
          $sth->execute;
          $cat = 0;
          foreach $row ($dbh->func('dbms_output_get'))
          { print "SQL> $row\n" if $trc;
            if ($row =~ $CUT)
            { $flg = !$flg;
            }
            elsif ($flg)
            { if ($cat)
              { if ($row =~ m/^\]\]\]$/)
                { last if &$fct($slf, $arg, $buf);
                  $cat = 0;
                }
                else
                { $buf .= $row;
                }
              }
              elsif ($row =~ m/^\[\[\[$/)
              { $buf = '';
                $cat = 1;
              }
              elsif ($row =~ m/^\[\[\[\012(.*)\012\]\]\]$/s)
              { $buf = $1;
                $buf =~ s/[\n\r]//gs;
                last if &$fct($slf, $arg, $buf);
              }
              else
              { last if &$fct($slf, $arg, $row);
              }
            }
          }
          $sth->finish;
        }
        elsif ($lin =~ m/^#\s*MACRO\s+(\w+)\((\d+)\)\s*$/)
        { &$fct($slf, $arg, "___Macro_$1($2)___") if $flg;
        }
        elsif ($lin =~ m/^#\s*CUT\s*$/)
        { $flg = !$flg;
        }
        elsif ($lin =~ m/^#\s*CALL\s+(\w+)\((\d+)\)\s*$/)
        { 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 =~ m/^#\s*ECHO(\s+(.*))?$/)
        { &$fct($slf, $arg, $2) if $flg && defined($1);
        }
        elsif ($lin =~ m/^#\s*(EXIT|QUIT)\s*$/)
        { $slf->disconnect;
          last;
        }
        elsif ($lin =~ m/^#\s*LONG\((\d+)\)\s*$/)
        { $dbh->{'LongReadLen'} = $1;
          $lng = 1;
        }
        elsif ($lin =~ m/^#\s*SLEEP\((\d+)\)\s*$/)
        { sleep($1);
        }
      }
    }
    else
    { $row = $DBI::errstr;
      die "RDA-00507: SQL Error: $row\n" if $slf->{'acc'};
      $slf->{'-msg'} = $row;
    }
    alarm(0) if $lim;
    };
  alarm(0) if $lim;
  $dbh->{'LongReadLen'} = 1024 if $lng;

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

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

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

This method returns the alarm duration.

=cut

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

  return $slf->{'lim'} unless defined($val);
  return 0 unless $slf->{'lim'} > 0 && $val > 0;
  $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($ctx)>

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

=cut

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

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

    # Execute the request
    ++$slf->{'-req'};
    $lim = $slf->get_alarm;
    eval {
      local $SIG{'__WARN__'} = sub {};
      local $SIG{'ALRM'}     = sub { die "$ALR\n" } if $lim;

      alarm($lim) if $lim;
      $slf->{'-nam'} = $dbh->get_info(17)
        if ($dbh = $slf->connect);
      alarm(0) if $lim;
      };

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

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

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

    # Execute the request
    ++$slf->{'-req'};
    $lim = $slf->get_alarm;
    eval {
      local $SIG{'__WARN__'} = sub {};
      local $SIG{'ALRM'}     = sub { die "$ALR\n" } if $lim;

      alarm($lim) if $lim;
      $slf->{'-ver'} = $dbh->get_info(18)
        if ($dbh = $slf->connect);
      alarm(0) if $lim;
      };

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

=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_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 ($dbh, $flg, $lim);

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

  # Execute the request
  ++$slf->{'-req'};
  $lim = $slf->get_alarm;
  $flg = 1;
  eval {
    local $SIG{'__WARN__'} = sub {};
    local $SIG{'ALRM'}     = sub { die "$ALR\n" } if $lim;

    alarm($lim) if $lim;
    if ($dbh = $slf->connect)
    { if ($dbh->ping)
      { $flg = 0;
      }
      else
      { $dbh->disconnect;
      }
    }
    alarm(0) if $lim;
    };
  return '' unless $@ || $flg;

  # Detect and treat interrupts

  # Disable further access to the database in case of problems
  $slf->_log_timeout($ctx, 'Test') if $@ =~ m/^$ALR\n/;
  ++$slf->{'-err'};
  $slf->{'-not'} = 'No database access in the last run';
  $slf->{'try'} = $slf->{'max'};
  return 'RDA-00501: Database access disabled due to a connection problem';
}

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

sub get_prelim
{ undef;
}

sub set_prelim
{ undef;
}

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

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

  if (defined($usr))
  { $slf->{'-pwd'} = $pwd;
    $slf->{'-sid'} = $sid;
    $slf->{'-usr'} = $usr;
  }
  else
  { $agt = $slf->{'-agt'};
    $slf->{'-sid'} = $agt->get_setting('ORACLE_SID', '');
    $slf->{'-usr'} = $agt->get_setting('SQL_LOGIN', 'SYSTEM');
  }
}

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

sub ora_login
{ my ($slf, $usr, $pwd, $sid, $dba) = @_;
  my ($agt, $loc, $str, $suf);
 
  # Determine the login information
  $agt = $slf->{'-agt'};
  $str = $suf = '';
  if (defined($usr))
  { $loc = _chk_sid($agt->get_setting('ORACLE_SID'), '');
    $sid = _chk_sid($sid, '');
    $suf = ' as SYSDBA' if $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 = length($sid) ? "\@$sid$suf" : $suf;
  $slf->{'-usr'} = $usr;
  $slf->{'-sid'} = ($sid =~ $SID) ? sprintf($NET1, $1, $2, $3, '') :
                   ($sid !~ $SVC) ? $sid :
                   length($3)     ? sprintf($NET3, $1, $2, $4, $3, '') :
                                    sprintf($NET2, $1, $2, $4, '');
  $slf->{'-con'}->{'ora_charset'}      = 'AL32UTF8';
  $slf->{'-con'}->{'ora_envhp'}        = 0;
  $slf->{'-con'}->{'ora_session_mode'} = 2 if $suf =~ m/AS\s+SYSDBA/i;

  # Prepare password request
  if (defined($pwd))
  { $slf->{'-pwd'} = $pwd;
  }
  else
  { $slf->{'-grp'} = ($sid eq '') ? $loc : $sid;
    $slf->{'-txt'} = "Enter the password for '$usr$str': ";
  }
}

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

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

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