# ====================================================================
# Gossamer Threads Module Library - http://gossamer-threads.com/
#
#   GT::SQL::Driver::sth
#   Author: Jason Rhinelander
#   CVS Info : 087,071,086,086,085      
#   $Id: sth.pm,v 2.4 2007/03/21 21:28:47 brewt Exp $
#
# Copyright (c) 2004 Gossamer Threads Inc.  All Rights Reserved.
# ====================================================================
#
# Description:
#   Generic statement handle wrapper
#

package GT::SQL::Driver::sth;
use strict;
use GT::Base;
use GT::AutoLoader(NEXT => '_AUTOLOAD');
require GT::SQL::Driver;
use GT::SQL::Driver::debug;
use vars qw(@ISA $AUTOLOAD $DEBUG $ERROR_MESSAGE);

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

# Get rid of a 'used only once' warnings
$DBI::errstr if 0;

sub new {
# --------------------------------------------------------
# Create a new driver sth.
#
    my $this = shift;
    my $class = ref $this || $this;
    my $opts = {};
    my $self = bless {}, $class;

    if (@_ == 1 and ref $_[0]) { $opts = shift }
    elsif (@_ and @_ % 2 == 0) { $opts = {@_} }
    else { return $self->fatal(BADARGS => "$class->new(HASH_REF or HASH)") }

    $self->{_debug}   = $opts->{_debug}   || $DEBUG;
    $self->{_err_pkg} = $opts->{_err_pkg} || 'GT::SQL';

    # Drivers can set this to handle name case changing for fetchrow_hashref
    $self->{hints} = $opts->{hints} || {};

    for (qw/dbh do query sth schema name _limit _lim_rows _lim_offset/) {
        $self->{$_} = $opts->{$_} if exists $opts->{$_};
    }
    $self->debug("OBJECT CREATED") if ($self->{_debug} > 2);
    return $self;
}

$COMPILE{execute} = __LINE__ . <<'END_OF_SUB';
sub execute {
# --------------------------------------------------------
# Execute the query.
#
    my $self = shift;
    my $do   = $self->{do};
    my $rc;

# Debugging, stack trace is printed if debug >= 2.
    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 (my $meth = $GT::SQL::Driver::QUERY_MAP{$do}) {
        $meth = "_execute_$meth";
        $rc = $self->$meth(@_) or return;
    }
    else {
        $rc = $self->{sth}->execute(@_) or return $self->warn(CANTEXECUTE => $self->{query}, $DBI::errstr);
    }

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

    $rc;
}
END_OF_SUB

# Define one generic execute, and alias all the specific _execute_* functions to it
sub _generic_execute {
    my $self = shift;
    $self->{sth}->execute(@_) or return $self->warn(CANTEXECUTE => $self->{query}, $DBI::errstr);
}
for (*_execute_create, *_execute_insert, *_execute_alter, *_execute_select, *_execute_update, *_execute_drop, *_execute_delete, *_execute_describe, *_execute_show_tables, *_execute_show_index) {
    $_ = \&_generic_execute;
}

sub rows {
    my $self = shift;
    return $self->{_rows} if exists $self->{_rows};
    return $self->{rows} if exists $self->{rows};
    $self->{sth}->rows;
}

sub fetchrow_arrayref {
# -----------------------------------------------------------------------------
    my $self = shift;
    $self->{_results} or return $self->{sth}->fetchrow_arrayref;
    return shift @{$self->{_results}};
}

sub fetchrow_array {
# -----------------------------------------------------------------------------
# When called in scalar context, returns either the first or last row, as per
# DBI, so avoid using in scalar context when fetching more than one row.
#
    my $self = shift;
    $self->{_results} or return $self->{sth}->fetchrow_array;
    my $arr = shift @{$self->{_results}};
    return $arr ? wantarray ? @$arr : $arr->[0] : ();
}

# -----------------------------------------------------------------------------
# Alias for fetchrow_array (DBI code comments this as an "old" alias, and DBI's
# documentation no longer mentions it at all).
*fetchrow = \&fetchrow_array; *fetchrow if 0;

sub fetchrow_hashref {
# -----------------------------------------------------------------------------
    my $self = shift;
    return $self->_fetchrow_hashref() if $self->{hints}->{case_map} or $self->{_results};
    $self->{sth}->fetchrow_hashref;
}

$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) {
            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

sub fetchall_arrayref {
# ---------------------------------------------------------------
    my $self = shift;
    return $self->{sth}->fetchall_arrayref(@_) unless $self->{_results};

    my $opt = shift;
    if ($opt and ref $opt eq 'HASH') {
        my @ret;
        while (my $row = $self->fetchrow_hashref) {
            for (keys %$row) {
                delete $row->{$_} unless exists $opt->{$_};
            }
            push @ret, $row;
        }
        return \@ret;
    }

    my $results = $self->{_results};
    $self->{_results} = [];
    return $results;
}

sub fetchall_list { map @$_, @{shift->fetchall_arrayref} }

sub fetchall_hashref {
# -----------------------------------------------------------------------------
# This is very different from DBI's fetchall_hashref - this is actually
# equivelant to DBI's ->fetchall_arrayref({})
#
    my $self = shift;
    my @results;
    while (my $hash = $self->fetchrow_hashref) {
        push @results, $hash;
    }
    return \@results;
}

sub row_names {
    my $self = shift;
    $self->{_names} || $self->{sth}->{NAME};
}

$COMPILE{insert_id} = __LINE__ . <<'END_OF_SUB';
sub insert_id {
# -------------------------------------------------------------------
# Returns the value of the last record inserted.
#
    return $_[0]->{sth}->{insertid};
}
END_OF_SUB

sub DESTROY {
# -------------------------------------------------------------------
# Calls finish on the row when it is destroyed.
#
    my $self = shift;
    $self->debug("OBJECT DESTROYED") if $self->{_debug} > 2;
    $self->{sth}->finish if ref $self->{sth} and $self->{sth}->can("finish");
}

sub _AUTOLOAD {
# -------------------------------------------------------------------
# Autoloads any unknown methods to the DBI::st object.
#
    my ($self, @param) = @_;
    my ($attrib) = $AUTOLOAD =~ /::([^:]+)$/;

    if (exists $DBI::st::{$attrib}) {
        local *code = $DBI::st::{$attrib};
        if (*code{CODE}) {
            $self->debug("Calling DBI::st::$attrib") if $self->{_debug} > 1;
            return code($self->{sth}, @param);
        }
    }

    $GT::SQL::Driver::debug::AUTOLOAD = $AUTOLOAD;
    goto &GT::SQL::Driver::debug::AUTOLOAD;
}

sub debug {
# -------------------------------------------------------------------
# DBI::st has a debug that autoload is catching.
#
    my $self = shift;
    my $i = 1;
    my ($package, $file, $line, $sub);
    while (($package, $file, $line) = caller($i++)) {
        last if index($package, 'GT::SQL') != 0;
    }
    while ($sub = (caller($i++))[3]) {
        last if index($sub, 'GT::SQL') != 0;
    }
    my $msg = $_[0];
    $msg .= " from $sub" if $sub;
    $msg .= " at $file" if $file;
    $msg .= " line $line" if $line;
    $msg .= "\n";
    return $self->SUPER::debug($msg);
}

1;