# ==================================================================
# Gossamer Threads Module Library - http://gossamer-threads.com/
#
#   GT::SQL::Driver::ORACLE
#   CVS Info : 087,071,086,086,085      
#   $Id: ORACLE.pm,v 2.2 2008/03/13 23:12:16 bao Exp $
#
# Copyright (c) 2004 Gossamer Threads Inc.  All Rights Reserved.
# ==================================================================
#
# Description: Oracle 8+ driver for GT::SQL
#

package GT::SQL::Driver::ORACLE;
# ====================================================================
use strict;
use vars qw/@ISA $ERROR_MESSAGE $ERRORS %BINDS/;

use DBD::Oracle qw/:ora_types/;
use GT::SQL::Driver;
use GT::AutoLoader;

$ERROR_MESSAGE = 'GT::SQL';
@ISA = qw/GT::SQL::Driver/;

sub protocol_version { 2 }

sub connect {
# ------------------------------------------------------------------
# Need to set some session preferences.
#
    my $self = shift;

# ORACLE_HOME must be set for the DBD::Oracle driver to function properly.
    return $self->warn('NOORACLEHOME') unless exists $ENV{ORACLE_HOME};

    my $dbh = $self->SUPER::connect(@_) or return;

# Set the date format to same format as other drivers use.
    $dbh->do("ALTER SESSION SET NLS_DATE_FORMAT = 'YYYY-MM-DD HH24:MI:SS'")
        or return $self->fatal(NONLSDATE => $DBI::errstr);

# Set max read properties for DBI.
    $dbh->{LongReadLen} = 1_048_576;
    return $dbh;
}

sub dsn {
# -------------------------------------------------------------------
# Oracle DSN looks like:
#       DBI:Oracle:host=HOST;port=POST;sid=SID
#
    my ($self, $connect) = @_;

    $connect->{driver} ||= 'Oracle';
    $connect->{host} ||= 'localhost';
    $self->{driver} = $connect->{driver};

    my $dsn  = "DBI:$connect->{driver}:";
    $dsn .= "host=$connect->{host}";
    $dsn .= ";port=$connect->{port}" if $connect->{port};
    $dsn .= ";sid=$connect->{database}";

    return $dsn;
}

sub hints {
    case_map => 1,
    prefix_indexes => 1,
    bind => [
        \%BINDS,
        'TEXT' => ORA_CLOB,
        'BLOB' => ORA_BLOB
    ],
    now => 'SYSDATE',
    ai => sub {
        my ($table, $column) = @_;
        my $seq = "${table}_seq";
        my @q;
        push @q, \"DROP SEQUENCE $seq";
        push @q, "CREATE SEQUENCE $seq INCREMENT BY 1 START WITH 1 NOCYCLE";
        \@q;
    }
}

sub prepare {
# -----------------------------------------------------------------------------
# Clear our limit counters.  Oracle does not have built-in limit support, so it
# is handled here by fetching all the results that were asked for into _results
# and our own fetchrow methods work off that.
#
    my ($self, $query) = @_;

# Oracle uses "SUBSTR" instead of "SUBSTRING"
    $query =~ s/\bSUBSTRING\(/SUBSTR(/gi;

    $self->SUPER::prepare($query);
}

sub _prepare_select {
# -----------------------------------------------------------------------------
# Need to store what the requested result set; no built in LIMIT support like
# mysql.
#
    my ($self, $query) = @_;

    my ($limit, $offset);

    # Handle either PG or MySQL limits
    $query =~ s/\bLIMIT\s+(\d+)\s+OFFSET\s+(\d+)/($limit, $offset) = ($1, $2); ''/ie
        or $query =~ s/\bOFFSET\s+(\d+)\s+LIMIT\s+(\d+)/($limit, $offset) = ($2, $1); ''/ie
        or $query =~ s/\bLIMIT\s+(\d+)\s*(?:,\s*(\d+))?/($limit, $offset) = ($2 || $1, $2 ? $1 : 0); ''/ie;
    if ($limit) {
        $self->{_limit} = 1;
	# using ROWNUM to limit rows instead.
	my $max_rows = $offset + $limit;
	$query = "SELECT * from (SELECT a.*, rownum rnum from ($query) a WHERE rownum <= $max_rows) where rnum > $offset";
    }

# LEFT OUTER JOIN is not supported, instead:
# ... FROM Table1, Table2 WHERE col1 = col2(+) ...
    $query =~ s{FROM\s+(\w+)\s+LEFT OUTER JOIN\s+(\w+)\s+ON\s+([\w.]+)\s*=\s*([\w.]+)(\s+WHERE\s+)?}{
        my ($table1, $table2, $col1, $col2, $where) = ($1, $2, $3, $4, $5);
        my $from_where = "FROM $table1, $table2 WHERE ";
        $from_where .= index($col1, "$table1.") == 0
            ? "$col1 = $col2(+)"
            : "$col2 = $col1(+)";
        $from_where .= " AND " if $where;
        $from_where;
    }ie;

    $query;
}

sub _prepare_describe {
# ------------------------------------------------------------------
# Oracle supports USER_TAB_COLUMNS to get information
# about a table.
#
    my ($self, $query) = @_;
    if ($query =~ /DESCRIBE\s+(\w+)/i) {
        return <<"        QUERY";
            SELECT COLUMN_NAME, DATA_TYPE, DATA_LENGTH, DATA_PRECISION, DATA_SCALE, NULLABLE, DATA_DEFAULT
            FROM USER_TAB_COLUMNS
            WHERE TABLE_NAME = '\U$1\E'
            ORDER BY COLUMN_ID
        QUERY
    }
    else {
        return $self->warn(CANTPREPARE => $query, "Cannot get properties from db_tab_columns");
    }
}

sub column_exists {
    my ($self, $table, $column) = @_;
    my $sth = $self->{dbh}->prepare(<<EXISTS);
SELECT COUNT(*)
FROM USER_TAB_COLUMNS
WHERE TABLE_NAME = ? AND COLUMN_NAME = ?
EXISTS
    $sth->execute(uc $table, uc $column);

    return scalar $sth->fetchrow;
}

sub _prepare_show_tables {
# -----------------------------------------------------------------------------
# Oracle's equivelant to SHOW TABLES
#
    my $self = shift;
    $self->{do} = 'SELECT';
    'SELECT table_name FROM USER_TABLES ORDER BY table_name';
}

sub _prepare_show_index {
# -----------------------------------------------------------------------------
# Get an index list; see 'Driver-specific notes' comment in GT::SQL::Driver
    my ($self, $query) = @_;
    if ($query =~ /^\s*SHOW\s+INDEX\s+FROM\s+(\w+)\s*$/i) {
# The below isn't quite perfect - Oracle 8 doesn't support CASE (9 does), so
# the 'index_unique' still has to be mapped to a 1/0 value in execute().  Also
# worth noting is that primary keys in Oracle don't always get their own index
# - in particular, when adding a primary key to a table using a column that is
# already indexed, the primary key will simply use the existing index instead
# of creating a new one.
        return <<QUERY;
SELECT
    ic.index_name AS "index_name",
    ic.column_name AS "index_column",
    (
        SELECT COUNT(*) FROM user_constraints c, user_cons_columns cc
        WHERE c.index_name = i.index_name AND c.constraint_name = cc.constraint_name
            AND c.constraint_type = 'P' AND cc.column_name = ic.column_name
    ) "index_primary",
    uniqueness AS "index_unique"
FROM
    user_ind_columns ic,
    user_indexes i
WHERE
    ic.index_name = i.index_name AND
    LOWER(ic.table_name) = '\L$1\E'
ORDER BY
    ic.index_name,
    ic.column_position
QUERY
    }
    else {
        return $self->warn(CANTPREPARE => $query, "Invalid/unsupported SHOW INDEX query: $query");
    }
}

sub drop_table {
# -------------------------------------------------------------------
# Drops a table, including a sequence if necessary
#
    my ($self, $table) = @_;

    my $seq = uc "${table}_seq";
    my $sth = $self->{dbh}->prepare("SELECT SEQUENCE_NAME FROM USER_SEQUENCES WHERE SEQUENCE_NAME = '$seq'");
    $sth->execute();
    if (my $seq_name = $sth->fetchrow) {
        my $sth = $self->{dbh}->prepare("DROP SEQUENCE $seq");
        $sth->execute or $self->warn(CANTEXECUTE => "DROP SEQUENCE $seq", $GT::SQL::error);
    }
    return $self->SUPER::drop_table($table);
}

sub ai_insert {
    my ($self, $ai) = @_;
    return $ai, "$self->{name}_seq.NEXTVAL";
}

sub alter_column {
# -------------------------------------------------------------------
# Changes a column.  Takes table name, column name, and new column definition.
#
    my ($self, $table, $column, $new_def, $old_col) = @_;

# make a copy so the original reference doesn't get clobbered
    my %col = %{$self->{schema}->{cols}->{$column}};

# If the default value was removed, then make sure that the default constraint
# from the previous instance is deactivated.
    if (not exists $col{default} and defined $old_col->{default} and length $old_col->{default}) {
        $col{default} = \'NULL';
    }

# Oracle doesn't like being told to make an already NOT NULL column NOT NULL:
    if ($col{not_null} and $old_col->{not_null}) {
        delete $col{not_null};
    }

    $new_def = $self->column_sql(\%col);

# But it needs an explicit NULL to drop the field's NOT NULL
    if (not $col{not_null} and $old_col->{not_null}) {
        $new_def .= ' NULL';
    }

# Oracle doesn't need the data type, and won't accept it on CLOB/BLOB columns
    $new_def =~ s/^[BC]LOB ?//;
    $new_def or return 1; # If the def is empty now, there really isn't anything to be done.

    $self->do("ALTER TABLE $table MODIFY $column $new_def");
}

sub drop_column {
# -------------------------------------------------------------------
# Drops a column
#
    my ($self, $table, $column) = @_;
    $self->do("ALTER TABLE $table DROP COLUMN $column");
}

sub create_pk {
# -------------------------------------------------------------------
# Adds a primary key to a table.
#
    my ($self, $table, @cols) = @_;
    $self->create_index($table, "${table}_pkey", @cols);
    $self->do("ALTER TABLE $table ADD CONSTRAINT ${table}_pkey PRIMARY KEY (" . join(",", @cols) . ")");
}

package GT::SQL::Driver::ORACLE::sth;
# ====================================================================
use strict;
use vars qw/@ISA $ERROR_MESSAGE $DEBUG/;
use GT::SQL::Driver::sth;
use GT::AutoLoader;

$ERROR_MESSAGE = 'GT::SQL';
$DEBUG         = 0;
@ISA = qw/GT::SQL::Driver::sth/;

sub insert_id {
# -------------------------------------------------------------------
# Retrieves the current sequence.
#
    my $self = shift;
    return $self->{_insert_id} if $self->{_insert_id};

    my ($table) = $self->{query} =~ /\s*insert\s*into\s*(\w+)/i;
    $table  ||= $self->{name};
    my $seq   = $table . "_seq.CURRVAL";
    my $query = "SELECT $seq FROM $table";
    my $sth   = $self->{dbh}->prepare($query) or return $self->fatal(CANTPREPARE => $query, $DBI::errstr);
    $sth->execute or return $self->fatal(CANTEXECUTE => $query, $DBI::errstr);
    my ($id) = $sth->fetchrow_array;
    $self->{_insert_id} = $id;

    return $id;
}

sub execute {
# -------------------------------------------------------------------
# Fetch off only desired rows.
#
    my $self = shift;
    my $time;
    if ($self->{_debug}) {
        $self->last_query($self->{query}, @_);
        my $stack = '';
        if ($self->{_debug} > 1) {
            $stack = GT::Base->stack_trace(1,1);
            $stack =~ s/<br>/\n    /g;
            $stack =~ s/&nbsp;/  /g;
            $stack = "\n    $stack\n"
        }
        my $query = GT::SQL::Driver::debug->replace_placeholders($self->{query}, @_);
        $self->debug("Executing query: $query$stack");
        $time = Time::HiRes::time() if exists $INC{"Time/HiRes.pm"};
    }
    if ($GT::SQL::Driver::ORACLE::BINDS{$self->{query}}) {
        for my $bind (@{$GT::SQL::Driver::ORACLE::BINDS{$self->{query}}}) {
            my ($index, $col, $type) = @$bind;
            $self->{sth}->bind_param($index, $_[$index - 1], { ora_type => $type, ora_field => $col });
        }
    }
    my $rc = $self->{sth}->execute(@_) or return $self->warn(CANTEXECUTE => $self->{query}, $DBI::errstr);
    $self->{_results}   = [];
    $self->{_insert_id} = '';
    $self->{_names}     = $self->{sth}->{NAME};
    if ($self->{do} eq 'SELECT') {
        $self->{_lim_cnt} = 0;
        if ($self->{_limit}) {
            while (my $rec = $self->{sth}->fetchrow_arrayref) {
	    	my @tmp = @$rec;
		pop @tmp; # get rid of the RNUM extra column
                push @{$self->{_results}}, [@tmp];  # Must copy as ref is reused in DBI.
            }
        }
        else {
            $self->{_results} = $self->{sth}->fetchall_arrayref;
        }
        $self->{rows} = @{$self->{_results}};
    }
    elsif ($self->{do} eq 'SHOW INDEX') {
        $self->{_names} = $self->{sth}->{NAME_lc};
        $self->{_results} = $self->{sth}->fetchall_arrayref;
        my $i = 0;
        for (@{$self->{_names}}) { last if $_ eq 'index_unique'; $i++ }
        for (@{$self->{_results}}) {
            $_->[$i] = uc($_->[$i]) eq 'UNIQUE' ? 1 : 0;
        }
        $self->{rows} = @{$self->{_results}};
    }
    elsif ($self->{do} eq 'DESCRIBE') {
        $rc = $self->_fixup_describe();
    }
    else {
        $self->{rows} = $self->{sth}->rows;
    }

    if ($self->{_debug} and exists $INC{"Time/HiRes.pm"}) {
        my $elapsed = Time::HiRes::time() - $time;
        $self->debug(sprintf("Query execution took: %.6fs", $elapsed));
    }

    return $rc;
}

sub _fixup_describe {
# ---------------------------------------------------------------
# Converts output of 'sp_columns tablename' into similiar results
# of mysql's describe tablename.
#
    my $self = shift;
    my @results;

# Mysql Cols are: Field, Type, Null, Key, Default, Extra
    my $table = uc $self->{name};
    while (my $col = $self->{sth}->fetchrow_hashref) {
        my ($table, $field, $type, $size, $prec, $scale) = @$col{qw/TABLE_NAME COLUMN_NAME DATA_TYPE DATA_LENGTH DATA_PRECISION DATA_SCALE/};
        my $null = $col->{NULLABLE} eq 'Y';
        my $default = (not defined $col->{DATA_DEFAULT} or $col->{DATA_DEFAULT} =~ /^''\s*/) ? '' : $col->{DATA_DEFAULT};

        $size = length $default if length $default > $size;

        if ($type =~ /VARCHAR2|CHAR/) {
            $type = "varchar($size)";
        }
        elsif ($type =~ /NUMBER/ and !$scale) {
            if ($prec) {
                $type =
                    $prec >= 11 ? 'bigint' :
                    $prec >= 9 ? 'int' :
                    $prec >= 6 ? 'mediumint' :
                    $prec >= 4 ? 'smallint' :
                    'tinyint';
            }
            else {
                $type = 'bigint';
            }
        }
        elsif ($type =~ /NUMBER/ and length $prec and length $scale) {
            $type = "decimal($prec, $scale)";
        }
        elsif ($type =~ /FLOAT/) {
            $type = (!$prec or $prec > 23) ? 'double' : 'real';
        }
        elsif ($type =~ /LONG|CLOB|NCLOB/) {
            $type = 'text';
        }
        elsif ($type =~ /DATE/) {
            $type = 'datetime';
        }

        $type = lc $type;
        $default =~ s,^NULL\s*,,;
        $default =~ s,^\(?'(.*)'\)?\s*$,$1,;
        $null = $null ? 'YES' : '';
        push @results, [$field, $type, $null, '', $default, ''];
    }
    ( $#results < 0 ) and return;

# Fetch the Primary key
    my $que_pk = <<"    QUERY";
        SELECT COL.COLUMN_NAME 
        FROM USER_CONS_COLUMNS COL, USER_CONSTRAINTS CON 
        WHERE COL.TABLE_NAME = '\U$table\E' 
            AND COL.TABLE_NAME = CON.TABLE_NAME 
            AND COL.CONSTRAINT_NAME = CON.CONSTRAINT_NAME 
            AND CON.CONSTRAINT_TYPE='P'
    QUERY
    my $sth_pk = $self->{dbh}->prepare($que_pk);
    $sth_pk->execute;
    my $indexes = {};
    while ( my $col = $sth_pk->fetchrow_array ) {
        $indexes->{$col} = "PRI";
    }
    $sth_pk->finish;

# Fetch the index information.
     my $que_idx = <<"    QUERY";
        SELECT *
        FROM USER_INDEXES IND, USER_IND_COLUMNS COL
        WHERE IND.TABLE_NAME = '\U$table\E'
            AND IND.TABLE_NAME = COL.TABLE_NAME
            AND IND.INDEX_NAME = COL.INDEX_NAME
    QUERY

    my $sth_idx = $self->{dbh}->prepare($que_idx);
    $sth_idx->execute;
    while ( my $col = $sth_idx->fetchrow_hashref ) {
        my $key = $col->{UNIQUENESS} =~ /UNIQUE/ ? 'UNIQUE' : 'MUL';
        exists $indexes->{$col->{COLUMN_NAME}} or $indexes->{$col->{COLUMN_NAME}} = $key;
    }

    for my $result (@results) {
        if (defined $indexes->{$result->[0]}) {
            $result->[3] = $indexes->{$result->[0]};
            if ($result->[1] =~ /int/) { # Set extra
                my $sth = $self->{dbh}->prepare("SELECT SEQUENCE_NAME FROM USER_SEQUENCES WHERE SEQUENCE_NAME = '\U$table\E_SEQ'");
                $sth->execute;
                $result->[5] = 'auto_increment' if $sth->fetchrow;
                $sth->finish;
            }
        }
    }
    $sth_idx->finish;
    $self->{_results} = \@results;
    $self->{_names}   = [qw/Field Type Null Key Default Extra/];
    $self->{rows}     = @{$self->{_results}};

    return 1;
}

sub finish {
# -----------------------------------------------------------------------------
    my $self = shift;
    delete $GT::SQL::Driver::ORACLE::BINDS{$self->{query}};
    $self->SUPER::finish;
}

$COMPILE{_fetchrow_hashref} = __LINE__ . <<'END_OF_SUB';
sub _fetchrow_hashref {
# -----------------------------------------------------------------------------
# Handles row fetching for driver that can't use the default ->fetchrow_hashref
# due to needing column case mapping ($sth->{hints}->{case_map}), or special
# result handling (e.g. PG's DESCRIBE handling, Oracle & ODBC's limit
# handling).
#
    my $self = shift;

    my %case_map; # returnedname => ReturnedName, but only for columns that use upper case
    if ($self->{hints}->{case_map}) {
        if (exists $self->{schema}->{cols}) {
            my $cols  = $self->{schema}->{cols};
            %case_map = map { lc $_ => $_ } keys %$cols;
        }
        else {
            for my $table (keys %{$self->{schema}}) {
                for my $col (keys %{$self->{schema}->{$table}->{schema}->{cols}}) {
                    $case_map{lc $col} = $col;
                }
            }
        }
    }

    if ($self->{_results}) {
        my $arr = shift @{$self->{_results}} or return;

        my $i;
        my %selected = map { lc $_ => $i++ } @{$self->{_names}};
        my %hash;

        for my $lc_col (keys %selected) {
	    next if $lc_col eq 'rnum';
            if (exists $case_map{$lc_col}) {
                $hash{$case_map{$lc_col}} = $arr->[$selected{$lc_col}];
            }
            else {
                $hash{$self->{_names}->[$selected{$lc_col}]} = $arr->[$selected{$lc_col}];
            }
        }
        return \%hash;
    }
    else {
        my $h = $self->{sth}->fetchrow_hashref or return;
        for (keys %$h) {
            $h->{$case_map{lc $_}} = delete $h->{lc $_} if exists $case_map{lc $_};
        }
        return $h;
    }
}
END_OF_SUB

# -----------------------------------------------------------------------------
# DATA TYPE MAPPINGS
# -----------------------------------------------------------------------------

package GT::SQL::Driver::ORACLE::Types;

use strict;
use GT::SQL::Driver::Types;
use Carp qw/croak/;
use vars qw/@ISA/;
@ISA = 'GT::SQL::Driver::Types';

# Quoting table and/or column names gives case-sensitivity to the table and
# column names in Oracle - however, because this needs to be compatible with
# older versions of this driver that didn't properly handle table/column case,
# we can't use that to our advantage, as all the old unquoted tables/columns
# would be upper-case - TABLE or COLUMN will be the name in the database, and
# "Table" or "column" would not exist.  It would, however, still be nice to
# support this at some point:
# sub base {
#     my ($class, $args, $name, $attribs) = @_;
#     $class->SUPER::base($args, qq{"$name"}, $attribs);
# }

sub TINYINT   { $_[0]->base($_[1], 'NUMBER(3)') }
sub SMALLINT  { $_[0]->base($_[1], 'NUMBER(5)') }
sub MEDIUMINT { $_[0]->base($_[1], 'NUMBER(8)') }
sub INT       { $_[0]->base($_[1], 'NUMBER(10)') }
sub BIGINT    { $_[0]->base($_[1], 'NUMBER(19)') }
sub REAL      { $_[0]->base($_[1], 'FLOAT(23)') }
sub DOUBLE    { $_[0]->base($_[1], 'FLOAT(52)') }

sub DATETIME  { $_[0]->base($_[1], 'DATE') }
sub TIMESTAMP { $_[0]->base($_[1], 'DATE') }
sub TIME      { croak "Oracle does not support 'TIME' columns\n" }
sub YEAR      { croak "Oracle does not support 'YEAR' columns\n" }

sub CHAR    { $_[0]->SUPER::CHAR($_[1], 'VARCHAR2') }
sub VARCHAR { $_[0]->SUPER::CHAR($_[1], 'VARCHAR2') }
sub TEXT    { $_[0]->base($_[1], 'CLOB') }
sub BLOB    { delete $_[1]->{default}; $_[0]->base($_[1], 'BLOB') }

1;