297 lines
9.0 KiB
Perl
297 lines
9.0 KiB
Perl
# ====================================================================
|
|
# 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/ / /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 >::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;
|