Tripletail::DB - DBI のラッパ

  $TL->startCgi(
      -DB      => 'DB',
      -main        => \&main,
  );

  sub main {
    my $DB = $TL->getDB('DB');

    $DB->setDefaultSet('R_Trans');
    $DB->tx(sub{
      my $sth = $DB->execute(q{SELECT a, b FROM foo WHERE a = ?}, 999);
      while (my $hash = $sth->fetchHash) {
        $TL->print($hash->{a});
      }
      # commit is done implicitly.
    });

    $DB->tx('W_Trans' => sub{
      $DB->execute(q{UPDATE counter SET counter = counter + 1 WHERE id = ?}, 1);
      $DB->commit; # can commit explicitly.
    }
  }

 # DBI
 my $sth = $DB->prepare(q{SELECT * FROM test WHERE id = ?});
 $sth->execute($id);
 while(my $data = $sth->fetchrow_hashref) {
 }
 # TL
 my $sth = $DB->execute(q{SELECT * FROM test WHERE id = ?}, $id);
 while(my $data = $sth->fetchHash) {
 }

 # DBI
 my $sth = $DB->prepare(q{INSERT INTO test VALUES (?, ?)});
 my $ret = $sth->execute($id, $data);
 # TL
 my $sth = $DB->execute(q{INSERT INTO test VALUES (?, ?)}, $id, $data);
 my $ret = $sth->ret;

 # DBI
 my $sth = $DB->prepare(q{SELECT * FROM test LIMIT ?});
 $sth->bind_param(1, $limit, { TYPE => SQL_INTEGER });
 $sth->execute;
 # TL
 my $sth = $DB->execute(q{SELECT * FROM test LIMIT ??}, [$limit, \'SQL_INTEGER']);

 # DBI
 my $sth = $DB->prepare(q{SELECT * FROM test LIMIT ?, ?});
 $sth->bind_param(1, $limit, { TYPE => SQL_INTEGER });
 $sth->bind_param(2, $offset, { TYPE => SQL_INTEGER });
 $sth->execute;
 # TL
 my $sth = $DB->execute(q{SELECT * FROM test LIMIT ??}, [$limit, $offset, \'SQL_INTEGER']);

 # DBI
 my $id = $DB->{mysql_insertid};
 # TL
 my $id = $DB->getLastInsertId;

 # DBI
 my $id = $DB->{RowCacheSize};
 # TL
 my $id = $DB->getDbh()->{RowCacheSize};

 # DBI
 $DB->do(q{BEGIN WORK});
 #   do something.
 $DB->commit;

 # TL
 $DB->tx(sub{
   # do something.
 });

  $DB->execute(
      q{SELECT * FROM a WHERE a IN (??) AND b = ?},
      ['AAA', 'BBB', 'CCC'], 800);

  $DB->execute(
      q{SELECT * FROM a WHERE a IN (?, ?, ?) AND b = ?},
      'AAA', 'BBB', 'CCC', 800);

  $DB->execute(q{SELECT * FROM a LIMIT ??}, [20, \'SQL_INTEGER']);
  ==> SELECT * FROM a LIMIT 20

  $DB->execute(q{SELECT * FROM a LIMIT ??}, [20, 5, \'SQL_INTEGER']);
  ==> SELECT * FROM a LIMIT 20, 5

  $DB->execute(
      q{SELECT * FROM a WHERE a IN (??) AND b = ?},
      [[100, \'SQL_INTEGER'], 'foo', \'SQL_VARCHAR'], 800);
  ==> SELECT * FROM a WHERE a IN (100, 'foo') AND b = '800'

  [DB]
  namequery=1
  type=mysql
  defaultset=SET_R_Trans
  SET_W_Trans=CON_DBW1
  SET_R_Trans=CON_DBR1,CON_DBR2

  [CON_DBW1]
  dbname=test
  user=daemon
  host=192.168.0.100

  [CON_DBR1]
  dbname=test
  user=daemon
  host=192.168.0.110

  [CON_DBR2]
  dbname=test
  user=daemon
  host=192.168.0.111

 # <tl.ini>
 [DB]
 type=mssql
 defaultset=SET_W_Trans
 SET_W_Trans=CON_RW
 [CON_RW]
 # dbname に ODBC-dsn を設定.
 dbname=test
 user=test
 password=test
 # freetds経由の時は, そちらのServernameも指定.
 tdsname=tds_test

 ;; <freetds.conf>
 [tds_test]
 host = 10.0.0.1
 ;;port = 1433
 tds version = 7.0
 client charset = UTF-8

# -----------------------------------------------------------------------------
# Tripletail::DB - DBIのラッパ
# -----------------------------------------------------------------------------
package Tripletail::DB;
use strict;
use warnings;
use Tripletail;
require Time::HiRes;
use DBI qw(:sql_types);

sub _INIT_REQUEST_HOOK_PRIORITY()  { -1_000_000 } # 順序は問わない
sub _POST_REQUEST_HOOK_PRIORITY() { -1_000_000 } # セッションフックの後
sub _TERM_HOOK_PRIORITY()         { -1_000_000 } # セッションフックの後

our $INSTANCES = {}; # グループ名 => インスタンス

sub _TX_STATE_NONE()      { 0 }
sub _TX_STATE_ACTIVE()    { 1 }
sub _TX_STATE_CLOSEWAIT() { 2 }
our @TX_STATE_NAME = qw(NONE ACTIVE CLOSEWAIT);

1;

sub _getInstance {
	my $class = shift;
	my $group = shift;

	if(!defined($group)) {
		$group = 'DB';
	} elsif(ref($group)) {
		die "TL#getDB: arg[1] is a reference. (第1引数がリファレンスです)\n";
	}

	my $obj = $INSTANCES->{$group};
	if(!$obj) {
		die "TL#getDB: DB group [$group] was not passed to the startCgi() / trapError(). (startCgi/trapErrorのDBに指定されていないDBグループ[${group}]が指定されました)\n";
	}

	$obj;
}

sub _reconnectSilentlyAll {
    # fork された後、子プロセス側で呼ばれる。現在 $INSTANCES に保存されている
    # DBI-dbh は全て親と共有されているので、それら全ての InactiveDestroy フラグを
    # 立ててから接続し直さなければならない。
    foreach my $db (values %$INSTANCES) {
        $db->_reconnectSilently;
    }

    return;
}

sub _reconnectSilently {
    my $this = shift;

    # 全ての DB コネクションの InactiveDestroy フラグを立ててから再接続する。
    foreach my $dbh (values %{$this->{dbname}}) {
        $dbh->getDbh->{InactiveDestroy} = 1;
        $dbh->connect($this->{type});
    }
    $this->{tx_state} = _TX_STATE_NONE;

    $this;
}

# エラー時に, DB別固有エラー情報から共通エラー情報に変換.
# 全てのDB種別で実装されているわけではない.
# 実装されていなければ常に COMMON_ERROR 扱い.
sub _errinfo
{
  my $pkg  = shift;
  my $dbh  = shift;
  my $type = shift || (ref($pkg)&&$pkg->getType());

  $dbh  or die __PACKAGE__."#_errinfo, no dbh. (dbhがありません)";
  $type or die __PACKAGE__."#_errinfo, no type. (typeがありません)";

  our $_ERRMAP ||= {};
  $_ERRMAP->{$type} ||= do{
    # $pkg->_load_errmap_mysql();
    my $subname = "_load_errmap_$type";
    my $sub = $pkg->can($subname);
    $sub ? $pkg->$sub() : {};
  };

  my $errno;  # DB固有のエラーコード.
  my $errstr; # DB固有のエラーメッセージ.
  my $errkey; # 共通のエラー識別キー.
  if( $type eq 'mysql' )
  {
    $errno  = $dbh->{mysql_errno};
    $errstr = $dbh->{mysql_error};
    $errkey = $_ERRMAP->{$type}{$errno} || 'COMMON_ERROR';
  }elsif( $type eq 'sqlite' )
  {
    $errno  = $dbh->err;
    $errstr = $dbh->errstr;
    $errkey = $_ERRMAP->{$type}{$errno} || 'COMMON_ERROR';
    if( $errno==1 )
    {
      # ちゃんとエラー番号が返ってこない?
      if( $errstr =~ /^no such table:/ )
      {
        $errkey = 'NO_SUCH_OBJECT';
      }elsif( $errstr =~ /^unable to open database file/ )
      {
        $errkey = $!{EACCES} ? 'CONNECT_DENIED' : 'CONNECT_NO_SERVER';
      }elsif( $errstr =~ /^attempt to write a readonly database/ )
      {
        $errkey = 'ACCESS_DENIED';
      }
    }
  }else
  {
    $errno  = $dbh->err;
    $errstr = $dbh->errstr;
    $errkey = 'COMMON_ERROR';
    #die __PACKAGE__."#_errinfo: DB type [$type] is not supported. (DB type [$type] はサポートされていません)\n";
  }

  $pkg->_errinfo2($type, $errkey, $errno, $errstr);
}
sub _errinfo2
{
  my $pkg    = shift;
  my $type   = shift;
  my $errkey = shift || 'COMMON_ERROR';
  my $errno  = shift;
  my $errstr = shift;

  our $_ERRMSG ||= $pkg->_load_errmsg();

  my $errmsg = $_ERRMSG->{$errkey};
  my ($errmsg_en, $errmsg_ja) = $errmsg =~ /^(.*) \((.*)\)\z/ or die "invalid message format: $errmsg";
  my $info = {
    $errkey   => $errmsg,
    _key      => $errkey,
    _msg      => $errmsg,
    _msg_en   => $errmsg_en,
    _msg_ja   => $errmsg_ja,
    _dbtype   => $type,
    _dberrno  => $errno,
    _dberrstr => $errstr,
  };
}

# 共通エラーコードの可読メッセージ.
sub _load_errmsg
{
  +{
    ACCESS_DENIED  => 'Access denied (アクセス権限がありません)',
    ALREADY_EXISTS => 'Already exists (処理対象が既に存在します)',
    COMMON_ERROR   => 'Error (何らかのエラー)',
    CONNECT_DENIED    => 'Connection denied (接続する権限がありません)',
    CONNECT_NO_SERVER => 'No server to connect (接続先サーバが存在しません)',
    CONNECT_PROTOCOL_MISMATCH => 'Connection protocol mismatch (接続プロトコルが一致しません)',
    NO_ERROR       => 'Success (処理成功)',
    NO_SUCH_OBJECT => 'No such object (処理対象が存在しません)',
    SYNTAX_ERROR   => 'Syntax error (構文エラー)',
  };
}
# エラー情報のDB別固有エラーコードから共通コードへのマッピング(mysql).
sub _load_errmap_mysql
{
  # http://dev.mysql.com/doc/refman/5.0/en/error-messages-server.html
  # http://dev.mysql.com/doc/refman/5.0/en/error-messages-client.html
  #
  +{
    0    => 'NO_ERROR',
    1044 => 'ACCESS_DENIED',
    1045 => 'CONNECT_DENIED',
    1050 => 'ALREADY_EXISTS',
    1064 => 'SYNTAX_ERROR',
    1146 => 'NO_SUCH_OBJECT',
    1149 => 'SYNTAX_ERROR',
    1251 => 'CONNECT_PROTOCOL_MISMATCH',
    2002 => 'CONNECT_NO_SERVER',
    2003 => 'CONNECT_NO_SERVER',
    2005 => 'CONNECT_NO_SERVER',
  };
}
sub _load_errmap_pgsql
{
  # http://www.postgresql.jp/document/pg836doc/html/errcodes-appendix.html
  +{
    00000 => 'NO_ERROR',
  };
}
# エラー情報のDB別固有エラーコードから共通コードへのマッピング(sqlite).
sub _load_errmap_sqlite
{
  # http://www.sqlite.org/c3ref/c_abort.html
  +{
    0    => 'NO_ERROR',
  };
}


sub connect {
	my $this = shift;

	# 全てのDBコネクションの接続を確立する．
	foreach my $dbh (values %{$this->{dbname}}) {
		if(!$dbh->ping) {
			$dbh->connect($this->{type});
		}
	}
	$this->{tx_state} = _TX_STATE_NONE;

	$this;
}

sub disconnect {
	my $this = shift;

	foreach my $dbh (values %{$this->{dbname}}) {
		$dbh->disconnect;
	}
	$this->{tx_state} = _TX_STATE_NONE;

	$this;
}

sub tx
{
	my $this = shift;
	my $setname = !ref($_[0]) && shift;
	my $sub  = shift;
	
	my @ret;
	
	$this->{tx_state}==_TX_STATE_CLOSEWAIT and $this->_closewait_broken();
	my $succ = 0;
	my $anchor = Tripletail::DB::_scope->new(sub{
		$succ and return;
		# on exception.
		if( $this->{tx_state}==_TX_STATE_ACTIVE )
		{
			$this->rollback();
		}
		$this->{tx_state} = _TX_STATE_NONE;
	});
	$this->begin($setname);
	local($Tripletail::Error::LAST_DBH) = $this;
	$this->{tx_state} = _TX_STATE_ACTIVE;
	if( wantarray )
	{
		@ret    = $sub->();
	}else
	{
		$ret[0] = $sub->();
	}
	if( $this->{trans_dbh} )
	{
		$this->commit();
	}
	$this->{tx_state} = _TX_STATE_NONE;
	$succ = 1;
	wantarray ? @ret : $ret[0];
}

sub _closewait_broken
{
	my $this = shift;
	my $where = shift;
	if( !$where )
	{
		$where = (caller(1))[3];
		$where =~ s/.*:://;
	}
	die __PACKAGE__."#$where: you can't do anything related to DB after doing rollback or commit in tx(). (txの中でrollback/commitした後はSQLを実行できません)\n";
}
sub inTx
{
	my $this = shift;
	my $set  = shift;
	$this->_requireTx($set, 'inTx');
}
sub _requireTx
{
	my $this    = shift;
	my $setname = shift;
	my $where   = shift;
	
	$this->{tx_state}==_TX_STATE_CLOSEWAIT and $this->_closewait_broken($where);
	if( my $trans = $this->{trans_dbh} )
	{
		my $set = $this->_getDbSetName($setname);
		
		my $trans_set = $trans->getSetName;
		if($trans_set eq $set)
		{
			# same transaction.
			return 1;
		}
		# another transaction running, always die.
		die __PACKAGE__."#$where: attempted to begin a".
			" new transaction on DB Set [$set] but".
			" another DB Set [$trans_set] were already in transaction.".
			" Commit or rollback it before beginning another one.".
			" (DB Set [$trans_set] でトランザクションを実行中に DB Set [$set] でトランザクションを開始しようとしました。".
			"別の DB Set でトランザクションを開始する前にcommit/rollbackする必要があります)\n";
	}else
	{
		# no transaction.
		return 0;
	}
}

sub begin {
	my $this = shift;
	my $setname = shift;

	my $set = $this->_getDbSetName($setname);

	$this->_requireTx($setname, 'begin');

	my $begintime = [Time::HiRes::gettimeofday()];

	my $dbh = $this->{dbh}{$set};
	$dbh->begin;

	my $elapsed = Time::HiRes::tv_interval($begintime);

	my $sql = $this->__nameQuery('BEGIN', $dbh);

	$TL->getDebug->_dbLog(sub{
		group   => $this->{group},
		set     => $dbh->getSetName,
		db      => $dbh->getGroup,
		id      => -1,
		query   => $sql,
		params  => [],
		elapsed => $elapsed,
	});

	$this->{trans_dbh} = $dbh;
	$this;
}

sub rollback {
	my $this = shift;
	$this->{tx_state}==_TX_STATE_CLOSEWAIT and $this->_closewait_broken();
	
	my $dbh = $this->{trans_dbh};
	if(!defined($dbh)) {
		die __PACKAGE__."#rollback: not in transaction. (トランザクションの実行中ではありません)\n";
	}

	my $begintime = [Time::HiRes::gettimeofday()];

	$dbh->rollback;
	if( $this->{tx_state}==_TX_STATE_ACTIVE )
	{
		$this->{tx_state} = _TX_STATE_CLOSEWAIT;
	}

	my $elapsed = Time::HiRes::tv_interval($begintime);

	my $sql = $this->__nameQuery('ROLLBACK', $dbh);

	$TL->getDebug->_dbLog(sub{
		group   => $this->{group},
		set     => $dbh->getSetName,
		db      => $dbh->getGroup,
		id      => -1,
		query   => $sql,
		params  => [],
		elapsed => $elapsed,
	});

	$this->{trans_dbh} = undef;
	$this;
}

sub commit {
	my $this = shift;
	$this->{tx_state}==_TX_STATE_CLOSEWAIT and $this->_closewait_broken();

	my $dbh = $this->{trans_dbh};
	if (!defined($dbh)) {
		die __PACKAGE__."#commit: not in transaction. (トランザクションの実行中ではありません)\n";
	}

	my $begintime = [Time::HiRes::gettimeofday()];

	$dbh->commit;
	if( $this->{tx_state}==_TX_STATE_ACTIVE )
	{
		$this->{tx_state} = _TX_STATE_CLOSEWAIT;
	}

	my $elapsed = Time::HiRes::tv_interval($begintime);

	my $sql = $this->__nameQuery('COMMIT', $dbh);

	$TL->getDebug->_dbLog(sub{
		group   => $this->{group},
		set     => $dbh->getSetName,
		db      => $dbh->getGroup,
		id      => -1,
		query   => $sql,
		params  => [],
		elapsed => $elapsed,
	});

	$this->{trans_dbh} = undef;
	$this;
}

sub setDefaultSet {
	my $this = shift;
	my $setname = shift;

	if(defined($setname)) {
		$this->{default_set} = $this->_getDbSetName($setname);
	} else {
		$this->{default_set} = undef;
	}

	$this;
}

sub execute {
	my $this = shift;
	my $dbset = shift;
	$this->{tx_state}==_TX_STATE_CLOSEWAIT and $this->_closewait_broken();
	
	if(ref($dbset)) {
		$dbset = $$dbset;
	} else {
		unshift(@_, $dbset);
		$dbset = undef;
	}
	my $sql = shift;
	my $sql_backup = $sql; # デバッグ用

	if(!defined($sql)) {
		die __PACKAGE__."#execute: arg[1] is not defined. (第1引数が指定されていません)\n";
	} elsif(ref($sql)) {
		die __PACKAGE__."#execute: arg[1] is a reference. (第1引数がリファレンスです)\n";
	} elsif($sql =~ m/^\s*(LOCK|UNLOCK|BEGIN|ROLLBACK|COMMIT)/i) {
		# これらのSQL文をexecuteすると整合性が失われる。
		die __PACKAGE__."#execute: attempted to execute [$1] statement directly.".
			" Use special methods not to ruin the consistency of Tripletail::DB.".
			" ($1はTripletail::DBの状態管理に影響を与えるためexecuteで実行できません。専用のメソッドを利用してください)\n";
	}

	my @params;
	if($sql =~ m/\?\?/) {
		# パラメータの中からARRAY Refのものを全て抜き出し、 ?? を ?, ?, ... に置換
		foreach my $param (@_) {
			if(!ref($param)) {
				push @params, $param;
			} elsif(ref($param) eq 'ARRAY') {
				if(@$param == 0) {
					# 0要素の配列があってはならない。
					die __PACKAGE__."#execute: some arguments are an empty array. (空の配列へのリファレンスが渡されました)\n";
				}

				my $n_params = @$param;

				if(ref($param->[-1]) eq 'SCALAR') {
					# 最後の要素がSCALAR Refなら、それは全体の型指定。

					my $type = $param->[-1];
					$n_params--;

					for(my $i = 0; $i < @$param - 1; $i++) {
						if(ref($param->[$i]) eq 'ARRAY') {
							# これは個別に型が指定されているので、デフォルトの型を適用しない。
							push @params, $param->[$i];
						} else {
							push @params, [$param->[$i], $type];
						}
					}
				} else {
					push @params, @$param;
				}

				unless($sql =~ s{\?\?}{
										join(', ', ('?') x $n_params);
								}e) {
					die __PACKAGE__."#execute: the number of `??' is fewer than the number of given parameters. (??の数が不足しています)\n";
				}
			} else {
				die __PACKAGE__."#execute: arg[$param] is not a scalar nor ARRAY Ref. (arg[$param]はスカラでも配列へのリファレンスでもありません)\n";
			}
		}

		if($sql =~ m/\?\?/) {
			die __PACKAGE__."#execute: the number of given parameters is fewer than the number of `??'. (??の数に対して引数の数が不足しています)\n";
		}
	} else {
		@params = @_;

		# この中にARRAY Refが入っていてはならない。
		if(grep {ref eq 'ARRAY'} @params) {
			die __PACKAGE__."#execute: use `??' instead of `?' if you want to use ARRAY Ref as a bind parameter.".
				" (配列へのリファレンスは ?? に対してのみ使用できます)\n";
		}
	}
	
	# executeを行うDBセットを探す
	my $dbh = undef;
	if(defined($dbset)) {
		#DBセットが明示的に指定された
		$dbh = $this->{dbh}{$dbset};
		if(!$dbh) {
			die __PACKAGE__."#execute: DB set [$dbset] is unavailable. (DB Set [$dbset] の指定が不正です)\n";
		}
	} else {
		$dbh = $this->{trans_dbh};
		$dbh = $this->{locked_dbh} if(!$dbh);
		$dbh = $this->{dbh}{$this->_getDbSetName} if(!$dbh);
	}
	
	if( $dbh->{bindconvert} )
	{
		my $sub = $dbh->{bindconvert};
		$dbh->$sub(\$sql, \@params);
	}

	my $sth = Tripletail::DB::STH->new(
		$this,
		$dbh,
		$dbh->getDbh->prepare($sql)
	);
	if( $dbh->{fetchconvert} )
	{
		my $sub = $dbh->{fetchconvert};
		$dbh->$sub($sth, new => [\$sql, \@params]);
	}

	# 全てのパラメータをbind_paramする。
	for(my $i = 0; $i < @params; $i++) {
		my $p = $params[$i];
		my $argno = $i + 2;

		if(!ref($p)) {
			$sth->{sth}->bind_param($i + 1, $p);
		} elsif(ref($p) eq 'ARRAY') {
			if(@$p != 2 || ref($p->[1]) ne 'SCALAR') {
				die __PACKAGE__."#execute: arg[$argno]: attempted to bind an invalid array: [".join(', ', @$p)."]".
				" (第${argno}引数に不正な形式の配列が渡されました)\n";
			}

			my $type = ${$p->[1]};
			my $typeconst = $this->{types_symtable}{$type};
			if(!$typeconst) {
				die __PACKAGE__."#execute: arg[$argno] is an invalid sql type: [$type] (第${argno}引数のSQL型指定が不正です)\n";
			}
			$p->[1] = *{$typeconst}{CODE}->();

			$sth->{sth}->bind_param($i + 1, @$p);
		} else {
			die __PACKAGE__."#execute: arg[$argno] is an unacceptable reference. [$p] (第${argno}引数に不正なリファレンスが渡されました)\n";
		}
	}

	$sql = $this->__nameQuery($sql, $dbh);
	$sql_backup = $this->__nameQuery($sql_backup, $dbh);

	my $begintime = [Time::HiRes::gettimeofday()];
	my $log_params = \@_;

	while(1) {
		eval {
			local $SIG{__DIE__} = 'DEFAULT';

			$sth->{ret} = $sth->{sth}->execute;
		};
		if( my $err = $@ ) {
			my $elapsed = Time::HiRes::tv_interval($begintime);
			$TL->getDebug->_dbLog(sub{
				group   => $this->{group},
				set     => $dbh->getSetName,
				db      => $dbh->getGroup,
				id      => $sth->{id},
				query   => $sql_backup . " /* ERROR: $err */",
				params  => $log_params,
				elapsed => $elapsed,
				names   => $TL->eval(sub{ $sth->nameArray }) || undef,
				error   => 1,
			});

			die $err;
		} else {
			# dieしなかったならループ終了
			last;
		}
	}

	my $elapsed = Time::HiRes::tv_interval($begintime);
	$TL->getDebug->_dbLog(sub{
		group   => $this->{group},
		set     => $dbh->getSetName,
		db      => $dbh->getGroup,
		id      => $sth->{id},
		query   => $sql_backup,
		params  => $log_params,
		elapsed => $elapsed,
		names   => $TL->eval(sub{ $sth->nameArray }) || undef
	});

	$sth;
}

sub selectAllHash {
	my $this = shift;
	$this->{tx_state}==_TX_STATE_CLOSEWAIT and $this->_closewait_broken();
	
	my $sth = $this->execute(@_);
	my $result = [];
	while(my $data = $sth->fetchHash) {
		push @$result, { %$data };
	}
	$result;
}

sub selectAllArray {
	my $this = shift;
	$this->{tx_state}==_TX_STATE_CLOSEWAIT and $this->_closewait_broken();

	my $sth = $this->execute(@_);
	my $result = [];
	while (my $data = $sth->fetchArray) {
		push @$result, [ @$data ];
	}
	$result;
}

sub selectRowHash {
	my $this = shift;
	$this->{tx_state}==_TX_STATE_CLOSEWAIT and $this->_closewait_broken();
	
	my $sth = $this->execute(@_);
	my $data = $sth->fetchHash();
	$data = $data ? {%$data} : undef;
	$sth->finish();
	
	$data;
}

sub selectRowArray {
	my $this = shift;
	$this->{tx_state}==_TX_STATE_CLOSEWAIT and $this->_closewait_broken();
	
	my $sth = $this->execute(@_);
	my $data = $sth->fetchArray();
	$data = $data ? [@$data] : undef;
	$sth->finish();
	
	$data;
}

sub lock {
	my $this = shift;
	my $opts = { @_ };

	my @tables;			# [name, alias, 'WRITE' or 'READ']
	foreach my $type (qw(read write))
	{
		if(defined(my $table = $opts->{$type})) {
			if(!ref($table)) {
				push @tables, [$table, undef, uc $type];
			} elsif (ref($table) eq 'ARRAY') {
				push @tables, map {
					if(!defined) {
						die __PACKAGE__."#lock: $type => [...] contains an undef. (${type}にundefが含まれています)\n";
					} elsif('HASH' eq ref) {
						[(keys %$_)[0], (values %$_)[0], uc $type];
					} elsif(ref) {
						die __PACKAGE__."#lock: $type => [...] contains a reference. [$_] (${type}にリファレンスが含まれています)\n";
					} else {
						[$_, undef, uc $type];
					}
				} @$table;
			} else {
				die __PACKAGE__."#lock: arg[$type] is an unacceptable reference. [$table] (arg[$type]は不正なリファレンスです)\n";
			}
		}
	};

	if(!@tables) {
		die __PACKAGE__."#lock: no tables are being locked. Specify at least one table. (テーブルが1つも指定されていません)\n";
	}

	my $set = $this->_getDbSetName($opts->{set});

	if(my $locked = $this->{locked_dbh}) {
		my $locked_set = $locked->getSetName;
		if($locked_set ne $set) {
			die __PACKAGE__."#lock: attempted to lock the DB Set [$set] but ".
			"another DB Set [$locked_set] were locked. Unlock old one before locking new one.".
			" (他の DB Set [$locked_set] でロック中なので DB Set [$set] でロックをすることができません)\n";
		} else {
			die __PACKAGE__."#lock: you are already locking some tables.".
			" (既に他のテーブルをロック中です)\n";
		}
	}

	my $dbh = $this->{dbh}{$set};
	my $type = $dbh->{type} or die __PACKAGE__."#lock: \$dbh->{type} is undef (接続されていません)";

	my $sql;
	if( $type eq 'mysql' )
	{
		$sql = 'LOCK TABLES '.join(
		', ',
		map {
			my $table = $_->[0];
			my $alias = $_->[1];
			my $type  = $_->[2];

			defined $alias ? 
				sprintf '%s AS %s %s',
					$this->symquote($table, $opts->{set}),
					$this->symquote($alias, $opts->{set}),
					$type : 
				sprintf '%s %s',
					$this->symquote($table, $opts->{set}),
					$type;
		} @tables);
	}else
	{
		# on pgsql, LOCK [ TABLE ] name [, ...] [ IN lockmode MODE ] [ NOWAIT ]
		die __PACKAGE__."#lock: DB type [$type] is not supported. (DB type [$type] に対する lock はサポートされていません)\n";
	}

	$sql = $this->__nameQuery($sql, $dbh);

	my $begintime = [Time::HiRes::gettimeofday()];

	$dbh->{dbh}->do($sql);
	$dbh->{locked} = 1;

	my $elapsed = Time::HiRes::tv_interval($begintime);
	$TL->getDebug->_dbLog(sub{
		group   => $this->{group},
		set     => $dbh->getSetName,
		db      => $dbh->getGroup,
		id      => -1,
		query   => $sql,
		params  => [],
		elapsed => $elapsed,
	});

	$this->{locked_dbh} = $dbh;
	$this;
}

sub unlock {
	my $this = shift;
	$this->{tx_state}==_TX_STATE_CLOSEWAIT and $this->_closewait_broken();

	my $dbh = $this->{locked_dbh};
	if(!defined($dbh)) {
		die __PACKAGE__."#unlock: no tables are locked. (ロックされているテーブルはありません)\n";
	}
	my $type = $dbh->{type} or die __PACKAGE__."#lock: \$dbh->{type} is undef (接続されていません)";

	my $sql;
	if( $type eq 'mysql' )
	{
		$sql = 'UNLOCK TABLES';
	}else
	{
		die __PACKAGE__."#unlock: DB type [$type] is not supported. (DB type [$type] に対する unlock はサポートされていません)\n";
	}
	$sql &&= $this->__nameQuery($sql, $dbh);
	my $begintime = [Time::HiRes::gettimeofday()];

	if( $sql )
	{
		$dbh->{dbh}->do($sql);
	}
	$dbh->{locked} = undef;

	my $elapsed = Time::HiRes::tv_interval($begintime);
	$TL->getDebug->_dbLog(sub{
		group   => $this->{group},
		set     => $dbh->getSetName,
		db      => $dbh->getGroup,
		id      => -1,
		query   => $sql,
		params  => [],
		elapsed => $elapsed,
	});

	$this->{locked_dbh} = undef;
	$this;
}

sub setBufferSize {
	my $this = shift;
	my $kib = shift;

	if(ref($kib)) {
		die __PACKAGE__."#setBufferSize: arg[1] is a reference. (第1引数がリファレンスです)\n";
	}

	$this->{bufsize} = defined $kib ? $kib * 1024 : undef;
	$this;
}

sub getLastInsertId
{
	my $this = shift;
	my $dbh;
	if( @_ && ref($_[0]) )
	{
		my $dbset_ref = shift;
		$dbh ||= $this->{dbh}{$$dbset_ref};
		$dbh or warn Dumper([keys %{$this->{dbh}}]); use Data::Dumper;
		$dbh or die "no such dbset: $$dbset_ref";
	}else
	{
		$dbh ||= $this->{trans_dbh};
		$dbh ||= $this->{locked_dbh};
		$dbh ||= $this->{dbh}{$this->_getDbSetName};
	}
	$dbh->getLastInsertId(@_);
}

sub symquote {
	my $this = shift;
	my $str = shift;

	if(!defined($str)) {
		die __PACKAGE__."#symquote: arg[1] is not defined. (第1引数が指定されていません)\n";
	} elsif(ref($str)) {
		die __PACKAGE__."#symquote: arg[1] is a reference. [$str] (第1引数がリファレンスです)\n";
	} elsif($str =~ m/[\'\"\`]/) {
		die __PACKAGE__."#symquote: arg[1] contains a quote character. [$str] (第1引数がquote記号\'\"\`を含んでいます)\n";
	}

	if($this->getType eq 'mysql') {
		qq[`$str`];
	} else {
		qq["$str"];
	}
}

sub getType {
	my $this = shift;

	$this->{type};
}

sub getDbh {
	my $this = shift;
	my $setname = shift;

	my $set = $this->_getDbSetName($setname);
	$this->{dbh}{$set}->getDbh;
}

sub _getDbSetName {
	my $this = shift;
	my $setname = shift;

	if(ref($setname)) {
		die __PACKAGE__."#_getDbSetName: arg[1] is a reference. [$setname] (第1引数がリファレンスです)\n";
	}

	my $set;
	if(!defined($setname) || !length($setname)) {
		if($this->{default_set}) {
			$set = $this->{default_set};
		} else {
			die __PACKAGE__."#_getDbSetName: do not omit the DB Set because no default DB Set has been specified." .
				" (デフォルトの DB Set が指定されていない場合は、DB Set の指定を省略できません)\n";
		}
	} else {
		if($this->{dbh}{$setname}) {
			$set = $setname;
		} else {
			die __PACKAGE__."#_getDbSetName: DB set [$setname] was not defined. Please check the INI file.".
			" (DB Set [$setname] が存在しません)\n";
		}
	}

	$set;
}

sub _connect {
	# クラスメソッド。TL#startCgi，TL#trapErrorのみが呼ぶ。
	my $class = shift;
	my $groups = shift;

	foreach my $group (@$groups) {
		if (!defined($group)) {
			die "TL#startCgi: -DB has an undefined value. (DB指定にundefが含まれます)\n";
		} elsif(ref($group)) {
			die "TL#startCgi: -DB has a reference. (DB指定にリファレンスが含まれます)\n";
		}

		$INSTANCES->{$group} = $class->_new($group)->connect;
	}

	# initRequest, postRequest, term をフックする
	$TL->setHook(
		'initRequest',
		_INIT_REQUEST_HOOK_PRIORITY,
		\&__initRequest,
	);

	$TL->setHook(
		'postRequest',
		_POST_REQUEST_HOOK_PRIORITY,
		\&__postRequest,
	);

	$TL->setHook(
		'term',
		_TERM_HOOK_PRIORITY,
		\&__term,
	);

	undef;
}

sub _new {
	my $class = shift;
	my $group = shift;

	my $this = bless {} => $class;
	$this->{group} = $group;
	$this->{namequery} = $TL->INI->get($group => 'namequery');
	$this->{type} = $TL->INI->get($group => 'type');

	$this->{bufsize} = undef; # 正の値でなければ無制限
	$this->{types_symtable} = \%Tripletail::DB::SQL_TYPES::;

	$this->{dbh} = {};    # {DBセット名 => Tripletail::DB::Dbh}
	$this->{dbname} = {}; # {DBコネクション名 => Tripletail::DB::Dbh}

	$this->{default_set} = $TL->INI->get($group => 'defaultset', undef); # デフォルトのセット名

	$this->{locked_dbh}   = undef; # Tripletail::DB::Dbh
	$this->{trans_dbh}    = undef; # Tripletail::DB::Dbh
	$this->{tx_state}     = _TX_STATE_NONE;

	do {
		local $SIG{__DIE__} = 'DEFAULT';
		eval q{
						package Tripletail::DB::SQL_TYPES;
						use DBI qw(:sql_types);
				};
	};
	if($@) {
		die $@;
	}

	# ここでセット定義を読む
	foreach my $setname ($TL->INI->getKeys($group)) {
		$setname =~ m/^[a-z]+$/ and next; # 予約済

		my @db = split /\s*,\s*/, $TL->INI->get($group => $setname);
		if (!scalar(@db)) {
			# ゼロ個のDBから構成されるDBセットを作ってはならない。
			die __PACKAGE__."#new: DB Set [$setname] has no databases. (DB Set [$setname] にDBが1つもありません)\n";
		}

		my $dbname = $db[$$ % scalar(@db)];
		if(!$this->{dbname}{$dbname}) {
			$this->{dbname}{$dbname} = Tripletail::DB::Dbh->new($setname, $dbname);
		}
		$this->{dbh}{$setname} = $this->{dbname}{$dbname};
	}

	$this;
}

sub __nameQuery {
	my $this = shift;
	my $query = shift;
	my $dbh = shift;

	if(!$this->{namequery}) {
		return $query;
	}

	# スタックを辿り、最初に現れたTripletail::DB以外のパッケージが作ったフレームを見て、
	# ファイル名と行番号を得る。
	for(my $i = 0;; $i++) {
		my ($pkg, $fname, $lineno) = caller $i;
		if($pkg !~ m/^Tripletail::DB/) {
			$fname =~ m!([^/]+)$!;
			$fname = $1;

			my $comment = sprintf '/* %s:%d [%s.%s.%s] */',
			$fname, $lineno, $this->{group}, $dbh->getSetName, $dbh->getGroup;

			$query =~ s/^(\s*\w+)/$1 $comment/;
			return $query;
		}
	}

	$query;
}

sub __initRequest {
	# $INSTANCESの中から、接続が確立していないものを接続する。
	foreach my $db (values %$INSTANCES) {
		$db->connect;
	}
}

sub __term {
	# $INSTANCESの接続を切断する。
	foreach my $db (values %$INSTANCES) {
		$db->disconnect;
	}
	undef $INSTANCES;
}

sub __postRequest {
	# $INSTANCESの中から、lockedのままになっているものに対して
	# UNLOCK TABLESを実行する。
	# また、トランザクションが済んでいないものについてはrollbackする。

	# 更にDBセットのデフォルト値を Ini の物にする

	foreach my $db (values %$INSTANCES) {
		if(my $dbh = $db->{locked_dbh}) {
			$db->unlock;

			my $setname = $dbh->getSetName;
			$TL->log(
				__PACKAGE__,
				"DB [$db->{group}] (DB Set [$setname]) has been left locked after the last request.".
				" Tripletail::DB automatically unlocked it for safety.".
				" (DB [$db->{group}] (DB Set [$setname]) はロックしたままリクエスト処理を終えました。安全のため自動的にunlockしました)"
			);
		}
		if(my $dbh = $db->{trans_dbh}) {
			$db->rollback;

			my $setname = $dbh->getSetName;
			$TL->log(
				__PACKAGE__,
				"DB [$db->{group}] (DB Set [$setname]) has been left in transaction after the last request.".
				" Tripletail::DB automatically rollbacked it for safety.".
				" (DB [$db->{group}] (DB Set [$setname]) はトランザクション中のままリクエスト処理を終えました。安全のため自動的にrollbackしました)"
			);
		}

		$db->setDefaultSet($TL->INI->get($db->{group} => 'defaultset', undef));
	}
}


package Tripletail::DB::Dbh;
use Tripletail;

sub new {
	my $class = shift;
	my $setname = shift;
	my $dbname = shift;
	my $this = bless {} => $class;

	$this->{setname} = $setname;
	$this->{inigroup} = $dbname;
	$this->{dbh} = undef; # DBI-dbh
	$this->{type} = undef; # set on connect().

	$this;
}

sub getSetName {
	my $this = shift;

	$this->{setname};
}

sub getGroup {
	my $this = shift;

	$this->{inigroup};
}

sub getDbh {
	my $this = shift;

	$this->{dbh};
}

sub ping {
	my $this = shift;

	$this->{dbh} and $this->{dbh}->ping;
}

sub connect {
	my $this = shift;
	my $type = shift;

	$type or die __PACKAGE__."#connect: type is not specified. (typeが指定されていません)\n";
	$this->{type} = $type;
	if($type eq 'mysql') {
		my $opts = {
			dbname => $TL->INI->get($this->{inigroup} => 'dbname'),
		};
		if( !$opts->{dbname} )
		{
			if( $TL->INI->existsGroup($this->{inigroup}) )
			{
				die __PACKAGE__."#connect: dbname is not set. (dbnameが指定されていません)\n";
			}else
			{
				die __PACKAGE__."#connect: inigroup '$this->{inigroup}' does not exist. (inigroup '$this->{inigroup}' が存在しません)\n";
			}
		}

		my $host = $TL->INI->get($this->{inigroup} => 'host');
		if(defined($host)) {
			$opts->{host} = $host;
		}

		my $port = $TL->INI->get($this->{inigroup} => 'port');
		if(defined($port)) {
			$opts->{port} = $port;
		}

		# mysql_read_default_file, mysql_read_default_group オプションを渡す
		my $default_file = $TL->INI->get_reloc($this->{inigroup} => 'mysql_read_default_file');
		if(defined($default_file)) {
			if ( ! -e $default_file ) {
				die __PACKAGE__."#connect: file $default_file does not exist. ($default_file が存在しません) ('mysql_read_default_file' in [$this->{inigroup}])\n";
			}
			$opts->{mysql_read_default_file} = $default_file;

			my $default_group = $TL->INI->get($this->{inigroup} => 'mysql_read_default_group');
			if(defined($default_group)) {
				$opts->{mysql_read_default_group} = $default_group;
			}
		}

		no warnings 'redefine';
		$DBI::installed_drh{mysql} or DBI->install_driver('mysql');
		my $orig = \&DBD::mysql::db::_login;
		local($Tripletail::Error::LAST_DBH);
		local(*DBD::mysql::db::_login) = sub{
			my @ret;
			@ret = wantarray ? &$orig : scalar(&$orig);
			if( !$ret[0] )
			{
				# $_[0]がdbh.
				# 保持してしまうとその後のエラーメッセージがでなくなり,
				# リファレンスではundefに消されてしまうので
				# ここでエラー情報を作成.
				my $err = Tripletail::DB->_errinfo($_[0], $type);
				$Tripletail::Error::LAST_DBH = ['error' => $err];
			}
			wantarray ? @ret : $ret[0];
		};

		$this->{dbh} = DBI->connect(
			'dbi:mysql:' . join(';', map { "$_=$opts->{$_}" } keys %$opts),
			$TL->INI->get($this->{inigroup} => 'user'),
			$TL->INI->get($this->{inigroup} => 'password'), {
			AutoCommit => 1,
			PrintError => 0,
			RaiseError => 1,
		});
	} elsif($type eq 'pgsql') {
		my $opts = {
			dbname => $TL->INI->get($this->{inigroup} => 'dbname'),
		};
		$opts->{dbname} or die __PACKAGE__."#connect: dbname is not set. (dbnameが指定されていません)\n";

		my $host = $TL->INI->get($this->{inigroup} => 'host');
		if(defined($host) && $host ne '') {
			$opts->{host} = $host;
		}

		my $port = $TL->INI->get($this->{inigroup} => 'port');
		if(defined($port) && $host ne '') {
			$opts->{port} = $port;
		}

		$this->{dbh} = DBI->connect(
			'dbi:Pg:' . join(';', map { "$_=$opts->{$_}" } keys %$opts),
			$TL->INI->get($this->{inigroup} => 'user'),
			$TL->INI->get($this->{inigroup} => 'password'), {
			AutoCommit => 1,
			PrintError => 0,
			RaiseError => 1,
		});
	} elsif($type eq 'oracle') {
		$ENV{ORACLE_SID} = $TL->INI->get($this->{inigroup} => 'sid');
		$ENV{ORACLE_SID} or die __PACKAGE__."#connect: sid is not set. (sidが指定されていません)\n";
		$ENV{ORACLE_HOME} = $TL->INI->get($this->{inigroup} => 'home');
		$ENV{ORACLE_HOME} or die __PACKAGE__."#connect: home is not set. (homeが指定されていません)\n";
		$ENV{ORACLE_TERM} = 'vt100';
		$ENV{PATH} = $ENV{PATH} . ':' . $ENV{ORACLE_HOME} . '/bin';
		$ENV{LD_LIBRARY_PATH} = $ENV{LD_LIBRARY_PATH} . ':'
			. $ENV{ORACLE_HOME} . '/lib';
		$ENV{ORA_NLS33} = $ENV{ORACLE_HOME} . '/ocommon/nls/admin/data';
		$ENV{NLS_LANG} = 'JAPANESE_JAPAN.UTF8';

		$TL->INI->get($this->{inigroup} => 'user') or die __PACKAGE__."#connect: user is not set. (userが指定されていません)\n";
		$TL->INI->get($this->{inigroup} => 'password') or die __PACKAGE__."#connect: password is not set. (passwordが指定されていません)\n";
		my $option = $TL->INI->get($this->{inigroup} => 'user') . '/' . $TL->INI->get($this->{inigroup} => 'password');
		my $host = $TL->INI->get($this->{inigroup} => 'host');
		if(defined($host)) {
			$option .= '@' . $host;
		}

		$this->{dbh} = DBI->connect(
			'dbi:Oracle:',
			$option,
			'', {
			AutoCommit => 1,
			PrintError => 0,
			RaiseError => 1,
		});
	} elsif($type eq 'interbase') {
		my $opts = {
			dbname => $TL->INI->get($this->{inigroup} => 'dbname'),
			ib_charset => 'UNICODE_FSS',
		};
		$opts->{dbname} or die __PACKAGE__."#connect: dbname is not set. (dbnameが指定されていません)\n";

		my $host = $TL->INI->get($this->{inigroup} => 'host');
		if(defined($host)) {
			$opts->{host} = $host;
		}

		my $port = $TL->INI->get($this->{inigroup} => 'port');
		if(defined($port)) {
			$opts->{port} = $port;
		}

		$this->{dbh} = DBI->connect(
			'dbi:InterBase:' . join(';', map { "$_=$opts->{$_}" } keys %$opts),
			$TL->INI->get($this->{inigroup} => 'user'),
			$TL->INI->get($this->{inigroup} => 'password'), {
			AutoCommit => 1,
			PrintError => 0,
			RaiseError => 1,
		});
	} elsif($type eq 'sqlite') {
		my $opts = {
			dbname => $TL->INI->get_reloc($this->{inigroup} => 'dbname'),
		};
		$opts->{dbname} or die __PACKAGE__."#connect: dbname is not set. (dbnameが指定されていません)\n";

		no warnings 'redefine';
		$DBI::installed_drh{SQLite} or DBI->install_driver('SQLite');
		my $orig = \&DBD::SQLite::db::_login;
		local($Tripletail::Error::LAST_DBH);
		local(*DBD::SQLite::db::_login) = sub{
			my @ret;
			@ret = wantarray ? &$orig : scalar(&$orig);
			if( !$ret[0] )
			{
				# $_[0]がdbh.
				# 保持してしまうとその後のエラーメッセージがでなくなり,
				# リファレンスではundefに消されてしまうので
				# ここでエラー情報を作成.
				my $err = Tripletail::DB->_errinfo($_[0], $type);
				$Tripletail::Error::LAST_DBH = ['error' => $err];
			}
			wantarray ? @ret : $ret[0];
		};

		$this->{dbh} = DBI->connect(
			'dbi:SQLite:' . join(';', map { "$_=$opts->{$_}" } keys %$opts),
			$TL->INI->get($this->{inigroup} => 'user'),
			$TL->INI->get($this->{inigroup} => 'password'), {
			AutoCommit => 1,
			PrintError => 0,
			RaiseError => 1,
		});
	} elsif($type eq 'mssql' || $type eq 'odbc' ) {
		my $nl = $Tripletail::_CHKNONLAZY || 0;
		my $dl = $Tripletail::_CHKDYNALDR || 0;
		my $opts = {
			map{ $_ => $TL->INI->get($this->{inigroup} => $_) }
				qw(dbname host port tdsname odbcdsn odbcdriver),
				qw(bindconvert fetchconvert)
		};
		$opts->{dbname} or die __PACKAGE__."#connect: dbname is not set. (dbnameが指定されていません)\n";

		# build data source string.
		my $dsn;
		if( $opts->{odbcdsn} )
		{
			my $odbcdsn = $opts->{odbcdsn} || '';
			if( $odbcdsn =~ m/^(\w+)$/ )
			{
				$dsn = "dbi:ODBC:DSN=$odbcdsn";
			}elsif( $odbcdsn =~ /^Driver=|^DSN=/i )
			{
				$dsn = "dbi:ODBC:$odbcdsn";
			}elsif( $odbcdsn =~ /^dbi:/ )
			{
				$dsn = $odbcdsn;
			}else
			{
				die __PACKAGE__."#connect: unknown odbcdsn. (対応していないodbcdsnが指定されました)\n";
			}
		}
		# odbc driver.
		if( !$dsn || $dsn!~/[:;]Driver=/i || $opts->{odbcdriver} )
		{
			my $driver = $opts->{odbcdriver};
			$driver ||= $^O eq 'MSWin32' ? 'SQL Server' : 'freetdsdriver';
			if( !$dsn )
			{
				$dsn = "dbi:ODBC:DRIVER={$driver}";
			}else
			{
				$dsn .= ";DRIVER={$driver}";
			}
		}
		$opts->{tdsname} and $dsn .= ";Servername=$opts->{tdsname}";
		$opts->{host}    and $dsn .= ";Server=$opts->{host}";
		$opts->{port}    and $dsn .= ";Port=$opts->{port}";
		$opts->{dbname}  and $dsn .= ";Database=$opts->{dbname}";
		
		# bindconvert/fetchconvert from driver.
		my $odbc_driver = $dsn =~ /[:;]DRIVER=\{(.*?)\}/i ? lc($1) : '';
		if( $odbc_driver eq 'freetdsdriver' )
		{
			$opts->{bindconvert} ||= 'freetds';
		}elsif( $odbc_driver eq 'sql server' )
		{
			local($SIG{__DIE__},$@) = 'DEFAULT';
			my $codepage = eval{
				require Win32::API;
				my $get_acp   = Win32::API->new("kernel32", "GetACP",   "", "N");
				$get_acp && $get_acp->Call();
			} || 0;
			if( !$codepage || $codepage==932 )
			{
				$opts->{bindconvert}  ||= 'mssql_cp932';
				$opts->{fetchconvert} ||= 'mssql_cp932';
				#$dsn .= ';AutoTranslate=No';
			}
		}
		foreach my $key (qw(bindconvert fetchconvert))
		{
			$opts->{$key} or next;
			$opts->{$key} eq 'no' and next;
			my $sub = $this->can("_${key}_$opts->{$key}");
			$sub or die __PACKAGE__."#connect: no such $key: $opts->{$key} (${key}が指定されていません)";
			$this->{$key} = $sub;
		}
		
		#print "dsn = [$dsn]\n";
		my $conn = sub{
			$this->{dbh} = DBI->connect(
				$dsn,
				$TL->INI->get($this->{inigroup} => 'user'),
				$TL->INI->get($this->{inigroup} => 'password'),
				{
					AutoCommit => 1,
					PrintError => 0,
					RaiseError => 1,
				}
			);
		};
		if( (!$dl && $nl) || $^O eq 'MSWin32' )
		{
			$conn->();
		}else
		{
			eval{ $conn->(); };
			if( $@ )
			{
				my $err = $@;
				chomp $err;
				$err .= " (perhaps you forgot to set env PERL_DL_NONLAZY=1?)";
				$err .= " ...propagated";
				die $err;
			}
		}
		if( $this->{fetchconvert} )
		{
			my $sub = $this->{fetchconvert};
			$this->$sub(undef, connect => undef);
		}
	} else {
		die __PACKAGE__."#connect: DB type [$type] is not supported. (DB type [$type] はサポートされていません)\n";
	}

	if(!$this->{dbh}) {
		die __PACKAGE__."#connect: DBI->connect failed. (DBI->connectに失敗しました)\n";
	}

	$this;
}

sub getLastInsertId
{
	my $this = shift;
	# $this->{type}はconnect時にセットされる
	my $type = $this->{type} or die __PACKAGE__."#getLastInsertId: \$this->{type} is undef (接続されていません)";
	my $obj  = shift; # for sequence on pgsql and oracle?
	if( $type eq 'mysql' )
	{
		return $this->{dbh}{mysql_insertid};
	}elsif($type eq 'pgsql')
	{
		defined($obj) or die __PACKAGE__."#getLastInsertId: $type requires secuence name";
		my ($curval) = $this->{dbh}->selectrow_array(q{
						SELECT currval(?)
				}, undef, $obj);
		return $curval;
	}elsif($type eq 'oracle')
	{
		$obj =~ /^((?:\w+\.)\w+)$/
			or die __PACKAGE__."#getLastInsertId: internal error: it is not possible to quote symbols of Oracle.".
				" (内部エラー:Oracle用のquote処理は未実装です)\n";
  		my $obj_sym = $1;
		my ($curval) = $this->{dbh}->selectrow_array(q{
						SELECT $obj_sym.curval
			  			  FROM dual
				});
		return $curval;
	}elsif( $type eq 'sqlite' )
	{
		return $this->{dbh}->func('last_insert_rowid');
	}elsif( $type eq 'mssql' )
	{
		my ($curval) = $this->{dbh}->selectrow_array(q{
						SELECT @@IDENTITY
				});
		return $curval;
	}else
	{
		die __PACKAGE__."#getLastInsertId: $type is not supported. (${type}はサポートされていません)";
	}
}

sub _bindconvert_freetds
{
	my $this = shift;
	my $ref_sql = shift;
	my $params  = shift;
	my $i = -1;
	foreach my $elm (@$params)
	{
		++$i;
		ref($elm) or next;
		if( ${$elm->[1]} eq 'SQL_WVARCHAR' )
		{
			my $u = $TL->charconv($elm->[0], 'utf8', 'ucs2');
			$elm->[0] = pack("v*",unpack("n*",$u));
			$elm->[1] = \'SQL_BINARY';
			
			my $l = length($u)/2;
			my $j = 0;
			my $repl = "CAST(? AS NVARCHAR($l))";
			$$ref_sql =~ s{\?}{$j++==$i?$repl:'?'}ge;
		}
	}
}

sub _bindconvert_mssql_cp932
{
	my $this = shift;
	my $ref_sql = shift;
	my $params  = shift;
	$$ref_sql = $TL->charconv($$ref_sql, 'utf8' => 'sjis');
	my $i = -1;
	foreach my $elm (@$params)
	{
		++$i;
		if( !ref($elm) )
		{
			$elm = $TL->charconv($elm, 'utf8', 'sjis');
		}elsif( ${$elm->[1]} =~ /^SQL_W(?:(?:LONG)?VAR)?CHAR$/ )
		{
			my $u = $TL->charconv($elm->[0], 'utf8', 'ucs2');
			$elm->[0] = pack("v*",unpack("n*",$u));
			$elm->[1] = \'SQL_BINARY';
			
			my $l = length($u)/2;
			my $j = 0;
			my $repl = "CAST(? AS NVARCHAR($l))";
			$$ref_sql =~ s{\?}{$j++==$i?$repl:'?'}ge;
		}elsif( ${$elm->[1]} =~ /^SQL_(?:(?:LONG)?VAR)?CHAR$/ )
		{
			$elm = $TL->charconv($elm, 'utf8', 'sjis');
		}
	}
}
sub _fetchconvert
{
	my $this = shift;
	if( $this->{fetchconvert} )
	{
		my $sub = $this->{fetchconvert};
		$this->$sub(@_);
	}
}
sub _fetchconvert_mssql_cp932
{
	my $this = shift;
	my $sth  = shift;
	my $mode = shift;
	my $obj  = shift;
	
	if( $mode eq 'new' )
	{
		# obj is [\$sql, \@params];
		
		# なんだか先に一回やっとかないとおかしくなる?
		$this->{dbh}->type_info(1);
		
		my $types = $sth->{sth}{TYPE};
		my $dbh = $sth->{dbh}{dbh};
		my @types = map{ $dbh->type_info($_)->{TYPE_NAME} } @$types;
		$sth->{_types} = \@types;
		$sth->{_name_hash} = {%{$sth->{sth}{NAME_hash}||{}}}; # raw encoded.
		my @names;
		while(my($k,$v)=each%{$sth->{_name_hash}})
		{
			$names[$v] = $TL->charconv($k, "sjis" => "utf8");
		}
		$sth->{_name_arraymap} = \@names;
		$sth->{_decode_cols} = [];
	}elsif( $mode eq 'nameArray' )
	{
		# obj is arrayref.;
		@$obj = @{$sth->{sth}{NAME}||[]};
		foreach my $elm (@$obj)
		{
			$elm = lc $TL->charconv($elm, 'cp932' => 'utf8');
		}
	}elsif( $mode eq 'nameHash' )
	{
		# obj is hashref.
		foreach my $key (keys %$obj)
		{
			my $ukey = lc $TL->charconv($key, 'cp932' => 'utf8');
			$obj->{$ukey} = delete $obj->{$key};
		}
	}elsif( $mode eq 'fetchArray' )
	{
		# obj is arrayref.
		my $i = -1;
		foreach my $val (@$obj)
		{
			++$i;
			defined($val) or next;
			my $type = (defined($i) && $sth->{_types}[$i]) || '';
			if( $type =~ /^n?((long)?var)?char$/ )
			{
				if( defined($val) && $val =~ /[^\0-\x7f]/ )
				{
					$val = $TL->charconv($val, 'cp932' => 'utf8');
				}
			}
			my $ukey = $sth->{_name_arraymap}[$i] || "\0";
			if( grep{$_ eq $i || $_ eq $ukey} @{$sth->{_decode_cols}} )
			{
				my $bin = pack("v*",unpack("n*",$val));
				$val = $TL->charconv($bin,"ucs2","utf8");
			}
		}
	}elsif( $mode eq 'fetchHash' )
	{
		# obj is hashref.
		foreach my $key (keys %$obj)
		{
			my $ukey = $TL->charconv($key, 'cp932' => 'utf8');
			my $i = $sth->{_name_hash}{$key}; # raw encoded.
			my $type = (defined($i) && $sth->{_types}[$i]) || '*';
			my $val = delete $obj->{$key};
			if( $type =~ /^n?((long)?var)?char$/ )
			{
				if( defined($val) && $val =~ /[^\0-\x7f]/ )
				{
					$val = $TL->charconv($val, 'cp932' => 'utf8');
				}
			}
			if( grep{$_ eq $i || $_ eq $ukey} @{$sth->{_decode_cols}} )
			{
				my $bin = pack("v*",unpack("n*",$val));
				$val = $TL->charconv($bin,"ucs2","utf8");
			}
			$obj->{$ukey} = $val;
		}
	}
}

sub disconnect {
	my $this = shift;

	$this->{dbh} and $this->{dbh}->disconnect;
	$this->{dbh} = undef; # DBI-dbh
	$this->{type} = undef; # set on connect().
	$this;
}

sub begin {
	my $this = shift;

	$this->{dbh}->begin_work;
}

sub rollback {
	my $this = shift;

	$this->{dbh}->rollback;
}

sub commit {
	my $this = shift;

	$this->{dbh}->commit;
}


package Tripletail::DB::STH;
use Tripletail;
our $STH_ID = 0;

1;

sub new {
	my $class = shift;
	my $db = shift;
	my $dbh = shift;
	my $sth = shift;
	my $this = bless {} => $class;

	$this->{db_center} = $db; # Tripletail::DB
	$this->{dbh} = $dbh; # Tripletail::DB::DBH
	$this->{sth} = $sth; # native sth
	$this->{ret} = undef; # last return value
	$this->{id} = $STH_ID++;

	$this;
}

sub fetchHash {
	my $this = shift;
	my $hash = $this->{sth}->fetchrow_hashref;

	if($hash) {
		$TL->getDebug->_dbLogData(sub{
			group   => $this->{group},
			set     => $this->{set}{name},
			db      => $this->{dbh}{inigroup},
			id      => $this->{id},
			data    => $hash,
		});
	}
	if( $this->{dbh}{fetchconvert} )
	{
		my $sub = $this->{dbh}{fetchconvert};
		$this->{dbh}->$sub($this, fetchHash => $hash);
	}


	if(my $lim = $this->{db_center}{bufsize}) {
		my $size = 0;
		foreach(values %$hash) {
			$size += length;
		}

		if($size > $lim) {
			die __PACKAGE__."#fetchHash: buffer size exceeded: size [$size] / limit [$lim] (バッファサイズを超過しました。size [$size] / limit [$lim])\n";
		}
	}

	$hash;
}

sub fetchArray {
	my $this = shift;
	my $array = $this->{sth}->fetchrow_arrayref;

	if( $this->{dbh}{fetchconvert} )
	{
		my $sub = $this->{dbh}{fetchconvert};
		$this->{dbh}->$sub($this, fetchArray => $array);
	}
	if($array) {
		$TL->getDebug->_dbLogData(sub{
			group   => $this->{group},
			set     => $this->{set}{name},
			db      => $this->{dbh}{inigroup},
			id      => $this->{id},
			data    => $array,
		});
	}

	if(my $lim = $this->{db_center}{bufsize}) {
		my $size = 0;
		foreach(@$array) {
			$size += length;
		}

		if($size > $lim) {
			die __PACKAGE__."#fetchArray: buffer size exceeded: size [$size] / limit [$lim] (バッファサイズを超過しました。size [$size] / limit [$lim])\n";
		}
	}

	$array;
}

sub ret {
	my $this = shift;
	$this->{ret};
}

sub rows {
	my $this = shift;
	$this->{sth}->rows;
}

sub finish {
	my $this = shift;
	$this->{sth}->finish;
}

sub nameArray {
	my $this = shift;
	my $name_lc = $this->{sth}{NAME_lc};
	if( $name_lc && $this->{dbh}{fetchconvert} )
	{
		$name_lc = [@{$this->{sth}{NAME}}]; # start from mixed case.
		my $sub = $this->{dbh}{fetchconvert};
		$this->{dbh}->$sub($this, nameArray => $name_lc);
	}
	$name_lc;
}

sub nameHash {
	my $this = shift;
	my $name_lc_hash = $this->{sth}{NAME_lc_hash};
	if( $name_lc_hash && $this->{dbh}{fetchconvert} )
	{
		$name_lc_hash = {%{$this->{sth}{NAME_hash}}}; # start from mixed case.
		my $sub = $this->{dbh}{fetchconvert};
		$this->{dbh}->$sub($this, nameHash => $name_lc_hash);
	}
	$name_lc_hash;
}

sub _fetchconvert
{
	my $this = shift;
	if( $this->{dbh}{fetchconvert} )
	{
		my $sub = $this->{dbh}{fetchconvert};
		$this->{dbh}->$sub($this, @_);
	}
}

package Tripletail::DB::_scope;

# -----------------------------------------------------------------------------
# Tripletail::DB::_scope->new(sub{ ... });
# Tripletail::DB::_scope->new(sub{ ... }, { args=>[...] });
#  create colosing object. it is similar to destructor or finally clause.
#
sub new
{
	my $pkg  = shift;
	my $code = shift;
	my $opts = shift;
	
	my $this = bless {}, $pkg;
	$this->{code}     = $code;
	$this->{args}     = $opts->{args} || undef;
	$this->{disabled} = $opts->{disabled};
	$this;
}

# -----------------------------------------------------------------------------
# $obj->raise();
# $obj->raise({ args => [...] });
#  invoke scope_finalizer code before it run automatically.
#
sub raise
{
	my $this = shift;
	my $opts = shift || {};
	if( !$this->{disabled} )
	{
		my $args = $opts->{args} || $this->{args} || [];
		$this->{code}->(@$args);
		$this->{disabled} = 1;
	}else
	{
		return;
	}
}

# -----------------------------------------------------------------------------
# $obj->disable();
#  disable auto raise.
#
sub disable
{
	my $this = shift;
	$this->{disabled} = @_ ? shift : 1;
	$this;
}

# -----------------------------------------------------------------------------
# DESTRUCTOR.
#  invoke scope_finalizer code.
#
sub DESTROY
{
	my $this = shift;
	$this->raise();
}

# -----------------------------------------------------------------------------
# End of Module.
# -----------------------------------------------------------------------------
__END__