sqlrelay.pm.in

适合于Unix/Linux下的一个持久数据库连接池

package DBD::SQLRelay;

use strict;
use vars qw($err $errstr $sqlstate $drh);
$DBD::SQLRelay::VERSION='@SQLR_VERSION@';
use SQLRelay::Connection;
use SQLRelay::Cursor;

use DBI qw(:sql_types);

$err=0;			# holds error code for DBI::err
$errstr='';		# holds error string for DBI::err
$sqlstate='';		# holds SQL state for DBI::state

$drh=undef;		# holds driver handle

sub driver {

	# return the driver handle if it's already 
	# defined to prevent multiple driver instances
	return $drh if $drh;	

	# get parameters
	my ($class,$attr)=@_;

	# append ::dr to the class name
	$class .='::dr';

	# create the driver handle
	$drh=DBI::_new_drh($class, {
		'Name'		=>	'SQLRelay',
		'Version'	=>	0,
		'Err'		=>	\$DBD::SQLRelay::err,
		'Errstr'	=>	\$DBD::SQLRelay::errstr,
		'State'		=>	\$DBD::SQLRelay::state,
		'Attribution'	=>	'DBD::SQLRelay by Dmitry Ovsyanko',
	});
	return $drh
}


# driver class
package DBD::SQLRelay::dr;

$DBD::SQLRelay::dr::imp_data_size=0;

sub connect {

	# get parameters
	my ($drh, $dbname, $user, $password, $attr)=@_;

	local $ENV{DBI_AUTOPROXY} = "" if $ENV{DBI_AUTOPROXY} && $ENV{DBI_AUTOPROXY} =~ /^dbi:SQLRelay/i;

	# create a blank database handle
	my $dbh=DBI::_new_dbh($drh, {
		'Name'		=>	$dbname,
		'USER'		=>	$user,
		'CURRENT_USER'	=>	$user,
	});

	# set some defaults
	my %dsn;
	$dsn{'host'}='localhost';
	$dsn{'port'}=9000;
	$dsn{'socket'}='';
	$dsn{'retrytime'}=0;
	$dsn{'tries'}=1;
	$dsn{'debug'}=0;

	# split the dsn
	my $var;
	my $val;
	foreach $var (split(/;/,$dbname)) {
		if ($var=~/(.*?)=(.*)/) {
			$var=$1;
			$val=$2;
			$dsn{$var}=$val;
			# FIXME: lowercase attributes will be ignored by STORE
			$dbh->STORE($var,$val);
		}
	}
	
	# create an Connection
	my $connection=SQLRelay::Connection->new($dsn{'host'},
							$dsn{'port'},
							$dsn{'socket'},
							$user,
							$password,
							$dsn{'retrytime'},
							$dsn{'tries'});

	# turn on debugging if debugging was specified in the dsn
	$connection->debugOn() if $dsn{'debug'};

	# store some references in the database handle
	$dbh->STORE('driver_database_handle',$drh);
	$dbh->STORE('driver_connection',$connection);

	# store a 1 for this database handle in the 'database handles' hash 
	# in the driver handle, indicating that this database handle exists
	# and can be disconnected
	$drh->{'dbhs'}->{$dbh}=1;

	return $dbh;
}

sub disconnect_all {

	# get parameters
	my ($drh)=@_;

	# run through the hash of database handles, disconnecting each
	foreach (keys %{$drh->{'dbhs'}}) {
		my $dbh=$drh->{'dbhs'}->{$_};
		next unless ref $dbh;
		$dbh->disconnect();
	}

	return 1;
}


# database class
package DBD::SQLRelay::db;

$DBD::SQLRelay::db::imp_data_size=0;

sub prepare {

	# get parameters
	my ($dbh, $statement, @attribs)=@_;

	# Convert format of bind vars from std DBI
	my $count = 0;
	$statement =~ s/\?/":" . ++$count/eg;

	# create a blank statement handle
	my $sth=DBI::_new_sth($dbh,{'Statement'=>$statement});
	
	# create an Cursor
	my $cursor=SQLRelay::Cursor->new($dbh->FETCH('driver_connection'));

	# set result set buffer size
	# FIXME: set from DBI RowCacheSize attribute
	$cursor->setResultSetBufferSize(100);

	# store statement-specific data in the statement handle
	#$sth->STORE('driver_params',[]);
	$sth->STORE('driver_database_handle',$dbh);
	$sth->STORE('NUM_OF_PARAMS', $count);
	$sth->STORE('driver_is_select',($statement=~/^\s*select/i));
	$sth->STORE('driver_cursor',$cursor);

 
 	for (grep /^ext_SQLR/, keys %$dbh) {
 		$sth->STORE($_, $dbh->FETCH($_));
 	}
 
 	$cursor->getNullsAsUndefined();
	$cursor->prepareQuery($statement);

	$sth->STORE('NUM_OF_PARAMS',$cursor->countBindVariables());

	return $sth;
}

sub disconnect {

	# get parameters
	my ($dbh)=@_;

	# end the session
	$dbh->FETCH('driver_connection')->endSession();

	# remove references to this database handle from the driver handle
	delete $dbh->FETCH('driver_database_handle')->{$dbh};
	delete $dbh->FETCH('driver_database_handle')->{'dbhs'}->{$dbh};
}

sub commit {

	# get parameters
	my ($dbh)=@_;

	# handle autocommit
	if ($dbh->FETCH('driver_AutoCommit')) {
		if ($dbh->FETCH('Warn')) {
			warn('Commit ineffective while AutoCommit is on');
		}
	}
	
	# execute a commit
	return $dbh->FETCH('driver_connection')->commit();
}

sub rollback {

	# get parameters
	my ($dbh)=@_;

	# handle autocommit
	if ($dbh->FETCH('driver_AutoCommit')) {
		if ($dbh->FETCH('Warn')) {
			warn('Commit ineffective while AutoCommit is on');
		}
	}
	
	# execute a rollback
	return $dbh->FETCH('driver_connection')->rollback();
}

sub STORE {

	# get parameters
	my ($dbh,$attr,$val)=@_;

	# special case for AutoCommit
	if ($attr eq 'AutoCommit') {
		$dbh->{'driver_AutoCommit'}=$val;
		if ($val) {
			$dbh->FETCH('driver_connection')->autoCommitOn();
		} else {
			$dbh->FETCH('driver_connection')->autoCommitOff();
		}
		return 1;
	}

	# handle all other cases
	if ($attr =~ /^(?:driver|ext_SQLR)_/) {
		$dbh->{$attr}=$val;
		return 1;
	}

	# if the attribute didn't start with 'driver_' 
	# then pass it up to the DBI class
	$dbh->SUPER::STORE($attr,$val);
}

sub FETCH {

	# get parameters
	my ($dbh,$attr)=@_;

	# special case for AutoCommit
	if ($attr eq 'AutoCommit') {
		return $dbh->{'driver_AutoCommit'};
	}

	# handle all other cases
	if ($attr =~ /^(?:driver|ext_SQLR)_/) {
		return $dbh->{$attr};
	}

	# if the attribute didn't start with 'driver_' 
	# then pass it up to the DBI class
	$dbh->SUPER::FETCH($attr);
}

sub ping {

	# get parameters
	my ($dbh,$attr)=@_;

	# execute a ping
	return $dbh->FETCH('driver_connection')->ping();
}


# statement class
package DBD::SQLRelay::st;

$DBD::SQLRelay::st::imp_data_size=0;

sub bind_param {
	# get parameters
	my ($sth,$param,$val,$attr)=@_;

	# bind any variables/values that were passed in
	my $cursor=$sth->FETCH('driver_cursor');
	my $dbh = $sth->{'Database'};

	if ($attr) {
	
		if (!ref($attr)) {

			if ($attr eq 'DBD::SQLRelay::SQL_CLOB') { 
				$cursor->inputBindClob($param, $val, length($val)); 
				return 1; 
			}
			elsif ($attr eq 'DBD::SQLRelay::SQL_BLOB') { 
				$cursor->inputBindBlob($param, $val, length($val)); 
				return 1; 
			}
			return $dbh->DBI::set_err(1,'bind_param: type '.$attr." is not supported.\n");

		} elsif (ref $attr eq 'HASH' && ($attr->{type} || $attr->{Type} || $attr->{TYPE}))  {
			my $length = $attr->{length} || length $val;
			if ($attr->{type} eq 'DBD::SQLRelay::SQL_CLOB') {

				$cursor->inputBindClob($param, $val, $length);	
			} elsif ($attr->{type} eq 'DBD::SQLRelay::SQL_BLOB') {

				$cursor->inputBindBlob($param, $val, $length);	
			} else {

		        	return $dbh->DBI::set_err(1, 'bind_param: type ' . $attr->{type} .
							     " is not supported.\n");
			}	
						
		} else {

		        return $dbh->DBI::set_err(1,'when specifying binding attributes, you must specify at least \'type\'');	

		}
	} else {

		# bind any variables/values that were passed in
		$cursor->inputBind($param, $val, 0, 6);

	}

	return 1;
}

sub bind_param_inout {

	# get parameters
	my ($sth,$param,$variable,$attr)=@_;

	# bind any variables that were passed in
	my $cursor=$sth->FETCH('driver_cursor');
	# FIXME: support integer/double/blob/clob's
	$cursor->defineOutputBindString($param,$attr);

	# store the parameter name in the list of inout parameters
	my $param_inout_list=$sth->FETCH('driver_param_inout_list');
	$param_inout_list=$param_inout_list . " $param";
	$sth->STORE('driver_param_inout_list',$param_inout_list);

	# store the variable so data can be fetched into it later
	$sth->STORE("driver_param_inout_$param",$variable);

	return 1;
}

sub execute {

	# get parameters
	my ($sth,@bind_values)=@_;
	my $dbh=$sth->{'Database'};

	# handle binds
	my $cursor=$sth->FETCH('driver_cursor');

	# Clear and reset binds if they are being passed to execute()
	if (scalar(@bind_values)) {
		if (@bind_values != $sth->FETCH('NUM_OF_PARAMS')) {
			return $dbh->set_err(1,"Expected ".$sth->FETCH('NUM_OF_PARAMS')." bind values but was given ".@bind_values);
		}

		$cursor->clearBinds();
		my $index=1;
		my $bind_value;
		foreach $bind_value (@bind_values) {
			$sth->bind_param($index,$bind_value)
				or return;
			$index=$index+1;
		}
	}

	# send the query
	if (not $cursor->executeQuery()) {
		$sth->STORE('driver_NUM_OF_ROWS',0);
		if (!$sth->FETCH('NUM_OF_FIELDS')) {
			$sth->STORE('NUM_OF_FIELDS',0);
		}
		$sth->STORE('driver_FETCHED_ROWS',0);
		return $dbh->DBI::set_err(1,$cursor->errorMessage());
	}

	# get some result set info
	my $colcount=$cursor->colCount();
	my $rowcount=$cursor->rowCount();
	my @colnames=map {$cursor->getColumnName($_)} (0..$colcount-1);
	my @coltypes=map {$cursor->getColumnType($_)} (0..$colcount-1);
 	# With "lazy fetching", we don't have a reliable rowcocunt
 	# $sth->STORE('driver_NUM_OF_ROWS',$rowcount);
 	if (!$sth->FETCH('NUM_OF_FIELDS')) {
 		$sth->STORE('NUM_OF_FIELDS',$colcount);
 	}
	$sth->{NAME}=\@colnames;
	$sth->{TYPE}=\@coltypes;
	$sth->STORE('driver_FETCHED_ROWS',0);

	# get the list of output bind variables and turn it into an array
	my $param_inout_list=$sth->FETCH('driver_param_inout_list');
 	my @param_inout_array=split(' ',$param_inout_list || "");

	# loop through the array of parameters, for each, get the appropriate
	# variable and store the output bind data in the variable
	my $param;
	foreach $param(@param_inout_array) {
		my $variable=$sth->FETCH("driver_param_inout_$param");
		# FIXME: support integer/double/blob/clob's
		$$variable=$cursor->getOutputBindString($param);
	}

	my $rows=$sth->rows();
	if ($rows==0) {
		return "0E0";
	}
	return $sth->rows;
}

sub fetchrow_arrayref {

	# get parameters
	my ($sth)=@_;

	# get the number of rows fetched so far
	my $fetched_rows=$sth->FETCH('driver_FETCHED_ROWS');

	# handle end of result set
	# With "lazy fetching", this method doesn't work; see below.
	#if ($fetched_rows==$sth->FETCH('driver_NUM_OF_ROWS')) {
	#	$sth->finish();
	#	return undef;
	#}

	# get a row
	my @row= $sth->FETCH('driver_cursor')->getRow($fetched_rows);
	if (scalar(@row) == 0) { $sth->finish(); return undef; }

	# increment the fetched row count
	$sth->STORE('driver_FETCHED_ROWS',$fetched_rows+1);

	# chop blanks, if that's set
	if ($sth->FETCH('ChopBlanks')) {
		map { $_=~s/\s+$//; } @row;
	}

	return $sth->_set_fbav(\@row);
}


# required alias for fetchrow_arrayref
*fetch=\&fetchrow_arrayref;

sub rows {

	# get parameters
	my ($sth)=@_;

	# return the number of affected rows
	return $sth->FETCH('driver_cursor')->affectedRows();
}

sub finish {
	
	# get parameters
	my ($sth)=@_;

	# call finish from the DBI class
	$sth->SUPER::finish();
}

sub STORE {

	# get parameters
	my ($sth,$attr,$val)=@_;

	if ($attr =~ /^ext_SQLR_BufferSize$/) {
		my $cursor = $sth->FETCH('driver_cursor');
		$cursor->setResultSetBufferSize($val);
		return 1;
	}

	# handle all other cases
	if ($attr =~ /^driver_/) {
		$sth->{$attr}=$val;
		return 1;
	}

	# if the attribute didn't start with 'driver_' 
	# then pass it up to the DBI class
	$sth->SUPER::STORE($attr,$val);
}

sub FETCH {

	# get parameters
	my ($sth,$attr)=@_;

	if ($attr =~ /^ext_SQLR_BufferSize$/) {
		my $cursor = $sth->FETCH('driver_cursor');
		return $cursor->getResultSetBufferSize();
	}

	# handle all other cases
	if ($attr =~ /^driver_/) {
		return $sth->{$attr};
	}

	# if the attribute didn't start with 'driver_' 
	# then pass it up to the DBI class
	$sth->SUPER::FETCH($attr);
}

1;
__END__
#

=head1 NAME

DBD::SQLRelay - perl DBI driver for SQL Relay 

=head1 SYNOPSIS

use DBD::SQLRelay;

my $dbh = DBI -> connect ('dbi:SQLRelay:$dsn', $login, $password);

=head1 DESCRIPTION

This module is a pure-Perl DBI binding to SQL Relay's native API. 
Connection string consists of following parts:

=item B<host=...>      default: I<localhost> --- hostname of SQL Relay server;

=item B<port=...>      default: I<9000>      --- port number that SQL Relay server listens on;

=item B<tries=...>     default: I<1>         --- how much times do we try to connect;

=item B<retrytime=...> default: I<0>         --- time (in seconds) between connect attempts;

=item B<debug=...>     default: I<0>         --- set it to 1 if you want to get some debug messages in stdout;

=head1 USAGE

Once connected, DB handler works as usual (see L<DBI>). 

Don't ever try to share one SQLRelay connect by multiple scripts, for example, if you use 
Apache mod_perl. Every $dbh holds one of server connections, so call disconnect() directly
at the end of every script and don't use Apache::DBI or SQLRelay will be deadlocked.

=head2 Note for HTML::Mason Users

If you use L<HTML::Mason>, your handler.pl sould look like this:

  ...

     {
       package HTML::Mason::Commands;
       use DBI;
       use vars qw($db);  
     }
 
  ...

     sub handler {
       
       $HTML::Mason::Commands::dbh = DBI -> connect (...);
       
       my $status = $ah -> handle_request (...);
     
       $HTML::Mason::Commands::dbh -> disconnect;
       
       return $status;
              
     }
     

=head1 AUTHOR

D. E. Ovsyanko, [e-mail]

Contributions by:

Erik Hollensbe <[e-mail]>

Tony Fleisher <[e-mail]>

=head1 SEE ALSO

http://www.firstworks.com

=cut