File Coverage

blib/lib/Rose/DB/Oracle.pm

Criterion	Covered	Total	%
statement	69	298	23.1
branch	11	132	8.3
condition	3	47	6.3
subroutine	20	58	34.4
pod	5	37	13.5
total	108	572	18.8

package Rose::DB::Oracle;

use strict;

use Carp();
use SQL::ReservedWords::Oracle();

use Rose::DB;

our $Debug = 0;

our $VERSION  = '0.784';

use Rose::Class::MakeMethods::Generic
(
  inheritable_scalar =>
  [
    '_default_post_connect_sql',
    '_booleans_are_numeric',
  ]
);

__PACKAGE__->_default_post_connect_sql
(
  [
    q(ALTER SESSION SET NLS_DATE_FORMAT = ') .
      ($ENV{'NLS_DATE_FORMAT'} || 'YYYY-MM-DD HH24:MI:SS') . q('),
    q(ALTER SESSION SET NLS_TIMESTAMP_FORMAT = ') .
      ($ENV{'NLS_TIMESTAMP_FORMAT'} || 'YYYY-MM-DD HH24:MI:SS.FF') . q('),
    q(ALTER SESSION SET NLS_TIMESTAMP_TZ_FORMAT = ') .
      ($ENV{'NLS_TIMESTAMP_TZ_FORMAT'} || 'YYYY-MM-DD HH24:MI:SS.FF TZHTZM') . q('),
  ]
);

__PACKAGE__->booleans_are_numeric(0);

#
# Class methods
#

sub booleans_are_numeric
{
  my($class) = shift;

  if(@_)
  {
    my $arg = shift;

    $class->_booleans_are_numeric($arg);

    no warnings 'redefine';
    if($arg)
    {
      *format_boolean = \&format_boolean_numeric;
    }
    else
    {
      *format_boolean = \&format_boolean_char;
    }

    return $arg ? 1 : 0;
  }

  return $class->_booleans_are_numeric;
}

#
# Object methods
#

sub default_post_connect_sql
{
  my($class) = shift;

  if(@_)
  {
    if(@_ == 1 && ref $_[0] eq 'ARRAY')
    {
      $class->_default_post_connect_sql(@_);
    }
    else
    {
      $class->_default_post_connect_sql([ @_ ]);
    }
  }

  return $class->_default_post_connect_sql;
}

sub post_connect_sql
{
  my($self) = shift;

  unless(@_)
  {
    return wantarray ?
      ( @{ $self->default_post_connect_sql || [] }, @{$self->{'post_connect_sql'} || [] } ) :
      [ @{ $self->default_post_connect_sql || [] }, @{$self->{'post_connect_sql'} || [] } ];
  }

  if(@_ == 1 && ref $_[0] eq 'ARRAY')
  {
    $self->{'post_connect_sql'} = $_[0];
  }
  else
  {
    $self->{'post_connect_sql'} = [ @_ ];
  }

  return wantarray ?
    ( @{ $self->default_post_connect_sql || [] }, @{$self->{'post_connect_sql'} || [] } ) :
    [ @{ $self->default_post_connect_sql || [] }, @{$self->{'post_connect_sql'} || [] } ];
}

sub schema
{
  my($self) = shift;
  $self->{'schema'} = shift  if(@_);
  return $self->{'schema'} || $self->username;
}

sub use_auto_sequence_name { 1 }

sub auto_sequence_name
{
  my($self, %args) = @_;

  my($table) = $args{'table'};
  Carp::croak 'Missing table argument' unless(defined $table);

  my($column) = $args{'column'};
  Carp::croak 'Missing column argument' unless(defined $column);

  return uc "${table}_${column}_SEQ";
}

sub build_dsn
{
  my($self_or_class, %args) = @_;

  my $database = $args{'db'} || $args{'database'};

  if($args{'host'} || $args{'port'})
  {
    if ($args{'service'})
    {
      $args{'service_name'} = $args{'service'};

      return 'dbi:Oracle:' .
        join(';', map { "$_=$args{$_}" } grep { $args{$_} } qw(service_name host port));
    }
    else
    {
      $args{'sid'} = $database;

      return 'dbi:Oracle:' .
        join(';', map { "$_=$args{$_}" } grep { $args{$_} } qw(sid host port));
    }
  }

  return "dbi:Oracle:$database";
}

sub init_date_handler { Rose::DB::Oracle::DateHandler->new }

sub database_version
{
  my($self) = shift;

  return $self->{'database_version'} if (defined $self->{'database_version'});

  my($version) = $self->dbh->get_info(18); # SQL_DBMS_VER.

  # Convert to an integer, e.g., 10.02.0100 -> 100020100

  if($version =~ /^(\d+)\.(\d+)(?:\.(\d+))?/)
  {
    $version = sprintf('%d%03d%04d', $1, $2, $3);
  }

  return $self->{'database_version'} = $version;
}

sub dbi_driver { 'Oracle' }

sub likes_uppercase_table_names     { 1 }
sub likes_uppercase_schema_names    { 1 }
sub likes_uppercase_catalog_names   { 1 }
sub likes_uppercase_sequence_names  { 1 }

sub insertid_param { '' }

sub list_tables
{
  my($self, %args) = @_;

  my $types = $args{'include_views'} ? "'TABLE','VIEW'" : 'TABLE';

  my($error, @tables);

  TRY:
  {
    local $@;

    eval
    {
      my($dbh) = $self->dbh or die $self->error;

      local $dbh->{'RaiseError'} = 1;
      local $dbh->{'FetchHashKeyName'} = 'NAME';

      my $sth  = $dbh->table_info($self->catalog, uc $self->schema, '%', $types);
      my $info = $sth->fetchall_arrayref({}); # The {} are mandatory.

      for my $table (@$info)
      {
        push @tables, $$table{'TABLE_NAME'} if ($$table{'TABLE_NAME'} !~ /^BIN\$.+\$.+/);
      }
    };

    $error = $@;
  }

  if($error)
  {
    Carp::croak 'Could not list tables from ', $self->dsn, " - $error";
  }

  return wantarray ? @tables : \@tables;
}

sub next_value_in_sequence
{
  my($self, $sequence_name) = @_;

  my $dbh = $self->dbh or return undef;

  my($error, $value);

  TRY:
  {
    local $@;

    eval
    {
      local $dbh->{'PrintError'} = 0;
      local $dbh->{'RaiseError'} = 1;
      my $sth = $dbh->prepare("SELECT $sequence_name.NEXTVAL FROM DUAL");
      $sth->execute;
      $value = ${$sth->fetch}[0];
      $sth->finish;
    };

    $error = $@;
  }

  if($error)
  {
    $self->error("Could not get the next value in the sequence $sequence_name - $error");
    return undef;
  }

  return $value;
}

# Tried to execute a CURRVAL command on a sequence before the
# NEXTVAL command was executed at least once.
use constant ORA_08002 => 8002;

sub current_value_in_sequence
{
  my($self, $sequence_name) = @_;

  my $dbh = $self->dbh or return undef;

  my($error, $value);

  TRY:
  {
    local $@;

    eval
    {
      local $dbh->{'PrintError'} = 0;
      local $dbh->{'RaiseError'} = 1;
      my $sth = $dbh->prepare("SELECT $sequence_name.CURRVAL FROM DUAL");

      $sth->execute;

      $value = ${$sth->fetch}[0];

      $sth->finish;
    };

    $error = $@;
  }

  if($error)
  {
    if(DBI->err == ORA_08002)
    {
      if(defined $self->next_value_in_sequence($sequence_name))
      {
        return $self->current_value_in_sequence($sequence_name);
      }
    }

    $self->error("Could not get the current value in the sequence $sequence_name - $error");
    return undef;
  }

  return $value;
}

# Sequence does not exist, or the user does not have the required
# privilege to perform this operation.
use constant ORA_02289 => 2289;

sub sequence_exists
{
  my($self, $sequence_name) = @_;

  my $dbh = $self->dbh or return undef;

  my $error;

  TRY:
  {
    local $@;

    eval
    {
      local $dbh->{'PrintError'} = 0;
      local $dbh->{'RaiseError'} = 1;
      my $sth = $dbh->prepare("SELECT $sequence_name.CURRVAL FROM DUAL");
      $sth->execute;
      $sth->fetch;
      $sth->finish;
    };

    $error = $@;
  }

  if($error)
  {
    my $dbi_error = DBI->err;

    if($dbi_error == ORA_08002)
    {
      if(defined $self->next_value_in_sequence($sequence_name))
      {
        return $self->sequence_exists($sequence_name);
      }
    }
    elsif($dbi_error == ORA_02289)
    {
      return 0;
    }

    $self->error("Could not check if sequence $sequence_name exists - $error");
    return undef;
  }

  return 1;
}

sub parse_dbi_column_info_default
{
  my($self, $default, $col_info) = @_;

  # For some reason, given a default value like this:
  #
  #   MYCOLUMN VARCHAR(128) DEFAULT 'foo' NOT NULL
  #
  # DBD::Oracle hands back a COLUMN_DEF value of:
  #
  #   $col_info->{'COLUMN_DEF'} = "'foo' "; # WTF?
  #
  # I have no idea why.  Anyway, we just want the value between the quotes.

  return undef unless (defined $default);

  $default =~ s/^\s*'(.+)'\s*$/$1/;

  return $default;
}

*is_reserved_word = \&SQL::ReservedWords::Oracle::is_reserved;

sub quote_identifier_for_sequence
{
  my($self, $catalog, $schema, $table) = @_;
  return join('.', map { uc } grep { defined } ($schema, $table));
}

# sub auto_quote_column_name
# {
#   my($self, $name) = @_;
#
#   if($name =~ /[^\w#]/ || $self->is_reserved_word($name))
#   {
#     return $self->quote_column_name($name, @_);
#   }
#
#   return $name;
# }

sub supports_schema { 1 }

sub max_column_name_length { 30 }
sub max_column_alias_length { 30 }

sub quote_column_name
{
  my $name = uc $_[1];
  $name =~ s/"/""/g;
  return qq("$name");
}

sub quote_table_name
{
  my $name = uc $_[1];
  $name =~ s/"/""/g;
  return qq("$name");
}

sub quote_identifier {
  my($self) = shift;
  my $method = ref($self)->parent_class . '::quote_identifier';
  no strict 'refs';
  return uc $self->$method(@_);
}

sub primary_key_column_names
{
  my($self) = shift;

  my %args = @_ == 1 ? (table => @_) : @_;

  my $table   = $args{'table'} or Carp::croak "Missing table name parameter";
  my $schema  = $args{'schema'} || $self->schema;
  my $catalog = $args{'catalog'} || $self->catalog;

  no warnings 'uninitialized';
  $table   = uc $table;
  $schema  = uc $schema;
  $catalog = uc $catalog;

  my $table_unquoted = $self->unquote_table_name($table);

  my($error, $columns);

  TRY:
  {
    local $@;

    eval
    {
      $columns =
        $self->_get_primary_key_column_names($catalog, $schema, $table_unquoted);
    };

    $error = $@;
  }

  if($error || !$columns)
  {
    no warnings 'uninitialized'; # undef strings okay
    $error = 'no primary key columns found'  unless(defined $error);
    Carp::croak "Could not get primary key columns for catalog '" .
                $catalog . "' schema '" . $schema . "' table '" .
                $table_unquoted . "' - " . $error;
  }

  return wantarray ? @$columns : $columns;
}

sub format_limit_with_offset
{
  my($self, $limit, $offset, $args) = @_;

  delete $args->{'limit'};
  delete $args->{'offset'};

  if($offset)
  {
    # http://www.oracle.com/technology/oramag/oracle/06-sep/o56asktom.html
    # select *
    #   from ( select /*+ FIRST_ROWS(n) */
    #   a.*, ROWNUM rnum
    #       from ( your_query_goes_here,
    #       with order by ) a
    #       where ROWNUM <=
    #       :MAX_ROW_TO_FETCH )
    # where rnum  >= :MIN_ROW_TO_FETCH;

    my $size  = $limit;
    my $start = $offset + 1;
    my $end   = $start + $size - 1;
    my $n     = $offset + $limit;

    $args->{'limit_prefix'} =
      "SELECT * FROM (SELECT /*+ FIRST_ROWS($n) */\na.*, ROWNUM oracle_rownum FROM (";
      #"SELECT * FROM (SELECT a.*, ROWNUM oracle_rownum FROM (";

    $args->{'limit_suffix'} =
      ") a WHERE ROWNUM <= $end) WHERE oracle_rownum >= $start";
  }
  else
  {
    $args->{'limit_prefix'} = "SELECT /*+ FIRST_ROWS($limit) */ a.* FROM (";
    #$args->{'limit_prefix'} = "SELECT a.* FROM (";
    $args->{'limit_suffix'} = ") a WHERE ROWNUM <= $limit";
  }
}

sub format_select_lock
{
  my($self, $class, $lock, $tables) = @_;

  $lock = { type => $lock }  unless(ref $lock);

  $lock->{'type'} ||= 'for update'  if($lock->{'for_update'});

  unless($lock->{'type'} eq 'for update')
  {
    Carp::croak "Invalid lock type: $lock->{'type'}";
  }

  my $sql = 'FOR UPDATE';

  my @columns;

  if(my $on = $lock->{'on'})
  {
    @columns = map { $self->column_sql_from_lock_on_value($class, $_, $tables) } @$on;
  }
  elsif(my $columns = $lock->{'columns'})
  {
    my %map;

    if($tables)
    {
      my $tn = 1;

      foreach my $table (@$tables)
      {
        (my $table_key = $table) =~ s/^(["']?)[^.]+\1\.//;
        $map{$table_key} = 't' . $tn++;
      }
    }

    @columns = map
      {
        ref $_ eq 'SCALAR' ? $$_ :
        /^([^.]+)\.([^.]+)$/ ?
          $self->auto_quote_column_with_table($2, defined $map{$1} ? $map{$1} : $1) :
          $self->auto_quote_column_name($_)
      }
      @$columns;
  }

  if(@columns)
  {
    $sql .= ' OF ' . join(', ', @columns);
  }

  if($lock->{'nowait'})
  {
    $sql .= ' NOWAIT';
  }
  elsif(my $wait = $lock->{'wait'})
  {
    $sql .= " WAIT $wait";
  }

  if($lock->{'skip_locked'})
  {
    $sql .= ' SKIP LOCKED';
  }

  return $sql;
}

sub format_boolean_char    { $_[1] ? 't' : 'f' }
sub format_boolean_numeric { $_[1] ? 1 : 0 }

BEGIN { *format_boolean = \&format_boolean_char }

#
# Date/time keywords and inlining
#

sub validate_date_keyword
{
  no warnings;
  $_[1] =~ /^(?:CURRENT_|SYS|LOCAL)(?:TIMESTAMP|DATE)$/i ||
    ($_[0]->keyword_function_calls && $_[1] =~ /^\w+\(.*\)$/);
}

*validate_time_keyword      = \&validate_date_keyword;
*validate_timestamp_keyword = \&validate_date_keyword;
*validate_datetime_keyword  = \&validate_date_keyword;

sub should_inline_date_keyword      { 1 }
sub should_inline_datetime_keyword  { 1 }
sub should_inline_time_keyword      { 1 }
sub should_inline_timestamp_keyword { 1 }

package Rose::DB::Oracle::DateHandler;

use Rose::Object;
our @ISA = qw(Rose::Object);

use DateTime::Format::Oracle;

sub parse_date
{
  my($self, $value) = @_;

  local $DateTime::Format::Oracle::nls_date_format = $ENV{'NLS_DATE_FORMAT'} || 'YYYY-MM-DD HH24:MI:SS';

  # Add or extend the time to appease DateTime::Format::Oracle
  if($value =~ /\d\d:/)
  {
    $value =~ s/( \d\d:\d\d)([^:]|$)/$1:00$2/;
  }
  else
  {
    $value .= ' 00:00:00';
  }

  return DateTime::Format::Oracle->parse_date($value);
}

*parse_datetime = \&parse_date;

sub parse_timestamp
{
  my($self, $value) = @_;

  local $DateTime::Format::Oracle::nls_timestamp_format =
    $ENV{'NLS_TIMESTAMP_FORMAT'} || 'YYYY-MM-DD HH24:MI:SS.FF';

  # Add, extend, or truncate fractional seconds to appease DateTime::Format::Oracle
  for($value)
  {
    s/( \d\d:\d\d:\d\d)(?!\.)/$1.000000/ ||
    s/( \d\d:\d\d:\d\d\.)(\d{1,5})(\D|$)/ "$1$2" . ('0' x (6 - length($2))) . $3/e ||
    s/( \d\d:\d\d:\d\d\.\d{6})\d+/$1/;
  }

  return DateTime::Format::Oracle->parse_timestamp($value);
}

sub parse_timestamp_with_time_zone
{
  my($self, $value) = @_;

  local $DateTime::Format::Oracle::nls_timestamp_tz_format =
    $ENV{'NLS_TIMESTAMP_TZ_FORMAT'} || 'YYYY-MM-DD HH24:MI:SS.FF TZHTZM';

  # Add, extend, or truncate fractional seconds to appease DateTime::Format::Oracle
  for($value)
  {
    s/( \d\d:\d\d:\d\d)(?!\.)/$1.000000/ ||
    s/( \d\d:\d\d:\d\d\.)(\d{1,5})(\D|$)/ "$1$2" . ('0' x (6 - length($2))) . $3/e ||
    s/( \d\d:\d\d:\d\d\.\d{6})\d+/$1/;
  }

  return DateTime::Format::Oracle->parse_timestamp_with_time_zone($value);
}

sub format_date
{
  my($self) = shift;

  local $DateTime::Format::Oracle::nls_date_format =
    $ENV{'NLS_DATE_FORMAT'} || 'YYYY-MM-DD HH24:MI:SS';

  return DateTime::Format::Oracle->format_date(@_);
}

*format_datetime = \&format_date;

sub format_timestamp
{
  my($self) = shift;

  local $DateTime::Format::Oracle::nls_timestamp_format =
    $ENV{'NLS_TIMESTAMP_FORMAT'} || 'YYYY-MM-DD HH24:MI:SS.FF';

  return DateTime::Format::Oracle->format_timestamp(@_);
}

sub format_timestamp_with_time_zone
{
  my($self) = shift;

  local $DateTime::Format::Oracle::nls_timestamp_tz_format =
    $ENV{'NLS_TIMESTAMP_TZ_FORMAT'} || 'YYYY-MM-DD HH24:MI:SS.FF TZHTZM';

  return DateTime::Format::Oracle->format_timestamp_with_time_zone(@_);
}

1;

__END__

=head1 NAME

Rose::DB::Oracle - Oracle driver class for Rose::DB.

=head1 SYNOPSIS

  use Rose::DB;

  Rose::DB->register_db
  (
    domain   => 'development',
    type     => 'main',
    driver   => 'Oracle',
    database => 'dev_db',
    host     => 'localhost',
    username => 'devuser',
    password => 'mysecret',
  );

  Rose::DB->register_db
  (
    domain   => 'production',
    type     => 'main',
    driver   => 'Oracle',
    service  => 'my_pdb',
    host     => 'db.example.com',
    username => 'produser',
    password => 'prodsecret',
  );

  Rose::DB->default_domain('development');
  Rose::DB->default_type('main');
  ...

  $db = Rose::DB->new; # $db is really a Rose::DB::Oracle-derived object
  ...

=head1 DESCRIPTION

L<Rose::DB> blesses objects into a class derived from L<Rose::DB::Oracle> when the L<driver|Rose::DB/driver> is "oracle".  This mapping of driver names to class names is configurable.  See the documentation for L<Rose::DB>'s L<new()|Rose::DB/new> and L<driver_class()|Rose::DB/driver_class> methods for more information.

This class cannot be used directly.  You must use L<Rose::DB> and let its L<new()|Rose::DB/new> method return an object blessed into the appropriate class for you, according to its L<driver_class()|Rose::DB/driver_class> mappings.

Only the methods that are new or have different behaviors than those in L<Rose::DB> are documented here.  See the L<Rose::DB> documentation for the full list of methods.

B<Oracle 9 or later is required.>

If you want to connect to a service rather than a database, use the C<service> parameter instead of C<database> when registering the data source, as shown in the L<SYNOPSIS|/SYNOPSIS> above. This will allow you to connect to PDBs (Pluggable Databases).

B<Note:> This class is a work in progress.  Support for Oracle databases is not yet complete.  If you would like to help, please contact John Siracusa at [e-mail] or post to the L<mailing list|Rose::DB/SUPPORT>.

=head1 CLASS METHODS

=over 4

=item B<default_post_connect_sql [STATEMENTS]>

Get or set the default list of SQL statements that will be run immediately after connecting to the database.  STATEMENTS should be a list or reference to an array of SQL statements.  Returns a reference to the array of SQL statements in scalar context, or a list of SQL statements in list context.

The L<default_post_connect_sql|/default_post_connect_sql> statements will be run before any statements set using the L<post_connect_sql|/post_connect_sql> method.  The default list contains the following:

    ALTER SESSION SET NLS_DATE_FORMAT = 'YYYY-MM-DD HH24:MI:SS'
    ALTER SESSION SET NLS_TIMESTAMP_FORMAT = 'YYYY-MM-DD HH24:MI:SS.FF'
    ALTER SESSION SET NLS_TIMESTAMP_TZ_FORMAT = 'YYYY-MM-DD HH24:MI:SS.FF TZHTZM'

If one or more C<NLS_*_FORMAT> environment variables are set, the format strings above are replaced by the values that these environment variables have I<at the time this module is loaded>.

=item B<booleans_are_numeric [BOOL]>

Get or set a boolean value that indicates whether or not boolean columns are numeric. Oracle does not have a dedicated boolean column type. Two common stand-in column types are CHAR(1) and NUMBER(1). If C<booleans_are_numeric> is true, then boolean columns are treated as NUMBER(1) columns containing either 1 or 0. If false, they are treated as CHAR(1) columns containing either 't' or 'f'. The default is false.

=back

=head1 OBJECT METHODS

=over 4

=item B<post_connect_sql [STATEMENTS]>

Get or set the SQL statements that will be run immediately after connecting to the database.  STATEMENTS should be a list or reference to an array of SQL statements.  Returns a reference to an array (in scalar) or a list of the L<default_post_connect_sql|/default_post_connect_sql> statements and the L<post_connect_sql|/post_connect_sql> statements.  Example:

    $db->post_connect_sql('UPDATE mytable SET num = num + 1');

    print join("\n", $db->post_connect_sql);

    ALTER SESSION SET NLS_DATE_FORMAT='YYYY-MM-DD HH24:MI:SS'
    ALTER SESSION SET NLS_TIMESTAMP_FORMAT='YYYY-MM-DD HH24:MI:SSxFF'
    UPDATE mytable SET num = num + 1

=item B<schema [SCHEMA]>

Get or set the database schema name.  In Oracle, every user has a corresponding schema.  The schema is comprised of all objects that user owns, and has the same name as that user.  Therefore, this attribute defaults to the L<username|Rose::DB/username> if it is not set explicitly.

=back

=head2 Value Parsing and Formatting

=over 4

=item B<validate_date_keyword STRING>

Returns true if STRING is a valid keyword for the PostgreSQL "date" data type.  Valid (case-insensitive) date keywords are:

    current_date
    current_timestamp
    localtimestamp
    months_between
    sysdate
    systimestamp

The keywords are case sensitive.  Any string that looks like a function call (matches C</^\w+\(.*\)$/>) is also considered a valid date keyword if L<keyword_function_calls|Rose::DB/keyword_function_calls> is true.

=item B<validate_timestamp_keyword STRING>

Returns true if STRING is a valid keyword for the Oracle "timestamp" data type, false otherwise.  Valid timestamp keywords are:

    current_date
    current_timestamp
    localtimestamp
    months_between
    sysdate
    systimestamp

The keywords are case sensitive.  Any string that looks like a function call (matches C</^\w+\(.*\)$/>) is also considered a valid timestamp keyword if L<keyword_function_calls|Rose::DB/keyword_function_calls> is true.

=back

=head1 AUTHORS

John C. Siracusa ([e-mail]), Ron Savage ([e-mail])

=head1 LICENSE

Copyright (c) 2008 by John Siracusa and Ron Savage.  All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.