Tripletail - Tripletail, Framework for Japanese Web Application

  use Tripletail qw(tl.ini);

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

  sub main {
      my $t = $TL->newTemplate('index.html');

      $t->flush;
  }

  use Tripletail qw(/home/www/ini/tl.ini);

  use Tripletail qw(/home/www/ini/tl.ini golduser);

  [HOST]
  Debughost = 192.168.10.0/24
  Testuser = 192.168.11.5 192.168.11.50
  [TL@server:Debughost]
  logdir = /home/tl/logs
  errormail = tl@example.org
  [TL@server:Debughost]
  logdir = /home/tl/logs/register

  [HOST]
  Debughost = 192.168.10.0/24
  Testuser = 192.168.11.5 192.168.11.50
  [TL:register@server:Debughost]
  logdir = /home/tl/logs/register/debug
  [TL@server:Debughost]
  logdir = /home/tl/logs
  errormail = tl@example.org
  [TL]
  logdir = /home/tl/logs
  [TL:register]
  logdir = /home/tl/logs/register
  [Debug@remote:Testuser]
  enable_debug=1

  use Tripletail qw(/home/www/ini/tl.ini register);

  [TL]
  logdir = /home/tl/logs/register/debug
  errormail = tl@example.org
  [Debug]
  enable_debug=1

  [TL]
  logdir = /home/tl/logs/register

  use Tripletail qw(/home/www/ini/tl.ini);

  [TL]
  logdir = /home/tl/logs/debug
  errormail = tl@example.org
  [Debug]
  enable_debug=1

  [TL]
  logdir = /home/tl/logs

  use Tripletail qw(tl.ini);

  # startCgi前に入力フィルタを設定する
  $TL->setInputFilter('Tripletail::InputFilter::MobileHTML');
  $TL->startCgi(
      -main => \&main,
  );

  sub main {
      # mainの最初で出力フィルタを設定する
      $TL->setContentFilter('Tripletail::Filter::MobileHTML');
      my $t = $TL->newTemplate('index.html');

      $t->flush;
  }

  $TL->startCgi(
    -main        => \&Main,    # メイン関数
    -DB          => 'DB',      # DBを使う場合，iniのグループ名を指定
    -Session => 'Session',     # Sessionを使う場合、iniのグループ名を指定
  );

  $TL->startCgi(
    -main => \&Main,
    -DB   => ['DB1', 'DB2'],
  );

  $TL->startCgi(
    -main        => \&Main,
    -DB          => 'DB',
    -Session => ['Session1', 'Session2'],
  );

  $TL->CGI
  $CGI

  $result = $TL->dispatch($value, %params)

  $params{default} = $scalar.
  $params{onerror} = \&error.
  $params{args}    = \@args.

  例:
  package Foo;

  sub main {
      my $what = 'Foo';
      $TL->dispatch($what, default => 'Foo', onerror => \&DoError);
  }

  sub DoFoo {
      ...
  }

  sub DoError {
      ...
  }

  $TL->print($str)

  $TL->location('http://example.org/')

  $TL->eval(sub {
                # Statements which may throw...
              });
  if ($@) {
      ....
  }

  $result = $TL->escapeTag($value)

  $result = $TL->unescapeTag($value)

  $result = $TL->escapeJs($value)

  $result = $TL->unescapeJs($value)

  $result = $TL->escapeJsString($value)

  $TL->escapeJsString("ab\"cd </script> def")

  '"ab\"cd </scr"+"ipt> def"'

  $result = $TL->unescapeJsString($value)

  $result = $TL->encodeURL($value)

  $result = decodeURL($value)

  $result = $TL->escapeSqlLike($value)

  $result = $TL->unescapeSqlLike($value)

  $str = $TL->charconv($str, $from, $to);

  $str = $TL->charconv($str, 'auto' => 'UTF-8');

  $TL->parsePeriod('10hour 30min')

  $TL->parseQuantity('100mi 50ki')

  $DB = $TL->getDB($group)

  $DB = $TL->newDB($group)

  $TL->INI

  $TL->trapError(
    -main => \&Main, # メイン関数
    -DB   => 'DB',   # DBを使う場合，iniのグループ名を指定
  );

  if (my $pid = $TL->fork) {
      # parent
  }
  else {
      # child
  }

  $TL->log($group => $log)

  $TL->setContentFilter($classname, %option)
  $TL->setContentFilter([$classname, $priority], %option)
  $TL->setContentFilter('Tripletail::Filter::HTML', charset => 'Shift_JIS')
  $TL->setContentFilter(
      'Tripletail::Filter::CSV', charset => 'Shift_JIS', filename => 'テストデータ.csv')

  $TL->getContentFilter($priority)

  $TL->removeContentFilter($priority)

  my $logid = $TL->getLogHeader

  $TL->setHook($type, $priority, \&func)

  $TL->removeHook($type, $priority)

  $TL->setInputFilter($classname, %option)
  $TL->setInputFilter([$classname, $priority], %option)

  $TL->getInputFilter($priority)

  $TL->removeInputFilter($priority)

  $TL->sendError(title => "タイトル", error => "エラー")

  $data = $TL->readFile($fpath);

  $data = $TL->readTextFile($fpath, $coding);

  $TL->writeFile($fpath, $fdata, $fmode);

  $TL->writeTextFile($fpath, $fdata, $fmode, $coding);

  $TL->watch(sdata => \$sdata, $reclevel);
  $TL->watch(adata => \@adata, $reclevel);
  $TL->watch(hdata => \%hdata, $reclevel);

  $TL->dump(\$data);
  $TL->dump(\$data, $level);
  $TL->dump(DATA => \$data);
  $TL->dump(DATA => \$data, $level);

  $TL->setCacheFilter($form)
  $TL->setCacheFilter($form, $charset)
  $TL->setCacheFilter($hashref)
  $TL->setCacheFilter($hashref, $charset)

  $bool = $TL->printCacheUnlessModified($key, $status)

  $TL->setCache($key, $priority)

  $TL->deleteCache($key)

  [TL]
  logdir = /home/www/cgilog/
  errortemplate = /home/www/error.html
  errortemplatecharset = Shift_JIS

 perldoc -u Tripletail |  podselect -sections SAMPLE | sed -e '1,4d' -e 's/^ //'




 # master configurations.
 #
 [TL]
 logdir=/home/project/logs/error
 errormail=errors@your.address
 errorlog=2
 trap=diewithprint
 stackallow=0.0.0.0/0

 [TL:SmallDebug]
 stacktrace=onlystack
 outputbuffering=1

 [TL:Debug]
 stacktrace=full
 outputbuffering=1

 [TL:FullDebug]
 stacktrace=full
 outputbuffering=1
 stackallow=0.0.0.0/0

 # database configrations.
 #
 [DB]
 type=mysql
 namequery=1
 tracelevel=0
 AllTransaction=DBALL
 defaultset=AllTransaction
 [DBALL]
 dbname=
 user=
 password=
 #host=

 [DB:SmallDebug]

 [DB:Debug]

 [DB:FullDebug]
 tracelevel=2

 # debug configrations.
 #
 [Debug]
 enable_debug=0

 [Debug:SmallDebug]
 enable_debug=1

 [Debug:Debug]
 enable_debug=1
 request_logging=1
 content_logging=1
 warn_logging=1
 db_profile=1
 popup_type=single
 template_popup=0
 request_popup=1
 db_popup=0
 log_popup=1
 warn_popup=1

 [Debug:FullDebug]
 enable_debug=1
 request_logging=1
 content_logging=0
 warn_logging=1
 db_profile=1
 popup_type=single
 template_popup=1
 request_popup=1
 db_popup=1
 log_popup=1
 warn_popup=1
 location_debug=1

 # misc.
 #
 [SecureCookie]
 path=/
 secure=1

 [Session]
 mode=https
 securecookie=SecureCookie
 timeout=30min
 updateinterval=10min
 dbgroup=DB
 dbset=AllTransaction

 # user data.
 # you can read this data:
 # $val = $TL->INI->get(UserData=>'roses');
 #
 [UserData]
 roses=red
 violets=blue
 sugar=sweet

# -----------------------------------------------------------------------------
# TL - Tripletailメインクラス
# -----------------------------------------------------------------------------
# $Id$
package Tripletail;
use 5.008_000;
use strict;
use warnings;
BEGIN{ our $_CHKNONLAZY=$ENV{PERL_DL_NONLAZY} }
BEGIN{ our $_CHKDYNALDR=$INC{'DynaLoader.pm'} }
use UNIVERSAL qw(isa);
use File::Spec;
use Data::Dumper;
use POSIX qw(:errno_h);
use Cwd ();

our $VERSION = '0.49';
our $XS_VERSION = $VERSION;
$VERSION = eval $VERSION;

our $TL = Tripletail->__new;
our @specialization = ();
our $LOG_SERIAL = 0;
our $LASTERROR;
our %_FILE_CACHE;
my $_FILE_CACHE_MAXSIZE = 10_1024*1024;
my $_FILE_CACHE_CURSIZE = 150; # variables for caching.
our $CWD;
our $IS_FCGI_WIN32;
our $FCGI_LOADMSG_WIN32;

# 動的スコープにより startCgi 内部である事を表す。
# 他のパッケージからも参照されるので削除してはならない。
our $IN_EXTENT_OF_STARTCGI;

require Unicode::Japanese;

if($ENV{TL_COVER_TEST_MODE}) {
	require Devel::Cover;
	Devel::Cover->import(qw(-silent on -summary off -db ./cover_db -coverage statement branch condition path subroutine time +ignore ^/));
}

*errorTrap = \&_errorTrap_is_deprecated;
sub _errorTrap_is_deprecated {
	die "\$TL->errorTrap(..) is deprecated, use \$TL->trapEror(..)"
}

if( $ENV{MOD_PERL} )
{
	&PreloadModperl;
}

1;

# -----------------------------------------------------------------------------
# ロード時初期化
# -----------------------------------------------------------------------------
sub import {
	my $package = shift;
	my $callpkg1 = (caller(0))[0];
	local($SIG{__WARN__}) = sub { warn "warn-import: $_[0]\n" };
	no strict qw(refs);
	*{"$callpkg1\::TL"} = *{"Tripletail\::TL"};

	if(!$TL->{INI}) {
		my $inifile = shift;
		if(!defined($inifile)) {
			_inside_pod_coverage()
				or die "use Tripletail: ini file isn't defined. Usage: \"use Tripletail qw(config.ini);\" (use Tripletail の際にiniファイルの指定が必要です)\n";
			$inifile = '/dev/null';
		}
		if( $inifile ne '/dev/null' && $inifile ne 'nul' )
		{
			$TL->{INI} = $TL->newIni($inifile);
		}else
		{
			$TL->{INI} = $TL->newIni();
		}
		$TL->{INI}->const;
		
		if(defined($_[0])) {
			@specialization = @_;
		}

		my $trap = $TL->{INI}->get(TL => 'trap', 'die');
		if($trap ne 'none' && $trap ne 'die' && $trap ne 'diewithprint') {
			die __PACKAGE__."#import: invalid trap option [$trap] (trapオプションの指定が正しくありません).\n";
		}


		$TL->{trap} = $trap;

		if($trap =~ /^(die|diewithprint)$/ )
		{
			my $trap = $1;
			$SIG{__DIE__} = \&__die_handler_for_startup;
		}
		*{"$callpkg1\::CGI"} = _gensym(); # dummy symbol to avoid the false alarm by strict.pm.
	} else {
		if(defined($_[0])) {
			die "use Tripletail: ini file has been already loaded. (iniファイルを指定した use Tripletail は一度しか行えません)";
		}
	}
}

sub PreloadModperl
{
	require Apache2::RequestRec;
	require Apache2::RequestIO;
	require Apache2::RequestUtil;
	require Apache2::Const;
	Apache2::Const->import(-compile => qw(OK REDIRECT));
	require APR::Table;
}

sub __die_handler_for_startup
{
	my $msg = shift;
	my $trap = shift || $TL->{trap};

	if( isa($msg, 'Tripletail::Error') )
	{
		die $msg;
	}
	my $prev = $LASTERROR;
	if( $prev && !ref($msg) && $msg =~ s/^\Q$prev\E(?=Compilation failed in require at )// )
	{
		$prev->{message} .= $msg;
		die $prev;
	}

	my $err = $TL->newError(error => $msg);
	$LASTERROR = $err;

	if( $trap eq 'diewithprint' && $err->{appear} ne 'usertrap' )
	{
		# die-with-print時かつevalの外であれば,
		# エラーをヘッダと共に表示する.
		$TL->__dispError($err);
	}elsif( $err->{appear} eq 'sudden' && $TL->_getRunMode eq 'CGI' && !$^S )
	{
		# Internal Server Error.
		# 詳細なエラー内容がでても微妙なことがあるので軽いメッセージにしておく.
		# でも Status: 500 は ErrorDocument 500 に反応しなくなるようなので,
		# 一応compatも入れておく.
		$err->{message} = "Internal Error has occured. To display details, you should set [TL] trap=diewithprint on ini file. (内部エラーが発生しました. 詳細を表示するには ini ファイルに [TL] trap=diewithprint の設定を加えてください)";
		if( !$TL->INI->get(TL=>'compat_no_trap_for_cgi_internal_error') )
		{
			$TL->__dispError($err);
		}
	}

	die $err;
}

# -----------------------------------------------------------------------------
# Pod::Coverage内からロードされているかの判定.
#  (Test::Pod::Cover用)
# -----------------------------------------------------------------------------
sub _inside_pod_coverage
{
	$INC{"Pod/Coverage.pm"} or return; # false.
	my $i = 0;
	my $in_pod_coverage = 0;
	while(my $pkg = caller(++$i))
	{
		$pkg eq 'Pod::Coverage' and return 1;
	}
	return; # false.
}

# -----------------------------------------------------------------------------
# 生成
# -----------------------------------------------------------------------------
sub __new {
	my $pkg = shift;
	my $this = bless {} => $pkg;

	$this->{INI} = undef; # Tripletail::Ini
	$this->{CGI} = undef; # Tripletail::Form。preRequest直前に生成され、postRequest後に消される。
	$this->{CGIORIG} = undef; # Tripletail::Form。preRequest直前に生成され、postRequest後に消される。

	$this->{trap} = 'die'; # 'none' | 'die' | 'diewithprint'

	$this->{filter} = {}; # 優先順位 => Tripletail::Filter
	$this->{filterlist} = []; # [Tripletail::Filter, ...] 優先順位でソート済み

	$this->{saved_filter} = {}; # $this->{filter} のコピー

	$this->{inputfilter} = {}; # 優先順位 => Tripletail::InputFilter
	$this->{inputfilterlist} = []; # [Tripletail::InputFilter, ...] 優先順位でソート済み

	$this->{hook} = {
		init        => {}, # 優先順位 => CODE
		term        => {},
		initRequest => {},
		preRequest  => {},
		postRequest => {},
	};
	$this->{hooklist} = {
		init        => [], # [CODE, ...] 優先順位でソート済み
		term        => [],
		initRequest => [],
		preRequest  => [],
		postRequest => [],
	};

	$this->{encode_is_available} = undef; # undef: 不明  0: Encode利用不可  1: Encode利用可

    $this->{ fcgi_request} = undef; # FCGI または undef

	$this->{script_name} = undef; # プログラム名

	$this;
}

sub DESTROY {
	my $this = shift;
	$SIG{__DIE__} = 'DEFAULT';
	if(exists($this->{cacheLogFh})) {
		close($this->{cacheLogFh});
	}
}

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

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

sub fork {
    my $this = shift;

    if ($this->{fcgi_request}) {
        $this->{fcgi_request}->Detach;
    }

    my $pid = CORE::fork();
    
    if (not defined $pid) {
        die "TL#fork: failed: $!";
    }
    elsif ($pid == 0) {
        # child
        
        if ($this->{fcgi_request}) {
            # 何故か FCGI::DESTROY を殺して置かないと、子プロセスの方が早く死んだ
            # 時に Internal Server Error になってしまう。Detach しているのだから
            # DESTROY がソケットを弄るのはおかしいのだが、現実としてそうなってい
            # る。
            # http://wiki.dreamhost.com/Perl_FastCGI
            *FCGI::DESTROY = sub {};
        }
        
        require Tripletail::DB;

        Tripletail::DB::_reconnectSilentlyAll();
    }
    else {
        # parent
        if ($this->{fcgi_request}) {
            $this->{fcgi_request}->Attach;
        }
    }

    return $pid;
}

sub eval {
    my $this = shift;
    my $sub  = shift;

    local $SIG{__DIE__} = 'DEFAULT';
    return CORE::eval { $sub->() };
}

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

	if(!defined($str)) {
		die "TL#escapeTag: arg[1] is not defined. (第1引数が指定されていません)\n";
	}

	$str = "$str"; # stringify.
	$str =~ s/\&/\&/g;
	$str =~ s/</\&lt;/g;
	$str =~ s/>/\&gt;/g;
	$str =~ s/\"/\&quot;/g;
	$str =~ s/\'/\&#39;/g;

	$str;
}

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

	if(!defined($str)) {
		die "TL#unescapeTag: arg[1] is not defined. (第1引数が指定されていません)\n";
	}

	$str = "$str"; # stringify.
	$str =~ s/\&lt;/</g;
	$str =~ s/\&gt;/>/g;
	$str =~ s/\&quot;/\"/g;
	$str =~ s/\&apos;/\'/g;
	$str =~ s!(\&(?:(amp)|#(\d+)|#x([0-9a-fA-F]+));)!
				if( $2 ) {
						'&';
				} elsif ( defined($3) && $3 ne '' ) {
						$3>=0x20 && $3<=0x7e ? pack("C",$3) : $1;
				} else { 
						hex($4)>=0x20 && hex($4)<=0x7e ? pack("C",hex($4)) : $1;
				}!ge;

	$str;
}

our $JSSTRING_SPLIT_RE = sub {
	# </script と --> を分割する為の正規表現
	# 要は、"111</script>222-->333"のような文字列をsplitすると、
	# [ "111</scr", "ipt>222-", "->333" ]
	# のように分割されるような正規表現を用意する
	# (これは最終的には'"111</scr"+"ipt>222-"+"->333"'のように加工される)
	# TODO: もう少し緩い判定にすべきかも知れない
	#       (「< / script>」等が有り得る？)
	my $scr = quotemeta('</scr');
	my $ipt = quotemeta('ipt');
	my $comment_end1 = quotemeta('-');
	my $comment_end2 = quotemeta('->');
	qr/(?:(?<=${scr})(?=${ipt}))|(?:(?<=${comment_end1})(?=${comment_end2}))/i;
}->();

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

	if(!defined($str)) {
		die "TL#escapeJsString: arg[1] is not defined. (第1引数が指定されていません)\n";
	}

	my $splitted = [ split($JSSTRING_SPLIT_RE, $str) ];
	# 分割した文字列をJavaScriptの'"</scr"+"ipt>"'状態にする
	my $result = join('"+"', (map { $this->escapeJs($_) } grep { defined } (@$splitted)));
	'"' . $result . '"';
}

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

	if(!defined($str)) {
		die "TL#unescapeJsString: arg[1] is not defined. (第1引数が指定されていません)\n";
	}

	die "TL#unescapeJsString: arg[1] is not JsString. (第1引数がJsString形式になっていません)\n" if not ($str =~ /^['"](.*)['"]$/);
	my $body = $1;
	$body =~ s/(?:\"\+\")|(?:\'\+\')//g;
	$this->unescapeJs($body);

	$body;
}
sub escapeJs {
	my $this = shift;
	my $str = shift;

	if(!defined($str)) {
		die "TL#escapeJs: arg[1] is not defined. (第1引数が指定されていません)\n";
	}

	$str = "$str"; # stringify.
	$str =~ s/(['"\\])/\\$1/g;
	$str =~ s/\r/\\r/g;
	$str =~ s/\n/\\n/g;
	$str =~ s/</\\x3c/g;
	$str =~ s/>/\\x3e/g;

	$str;
}

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

	if(!defined($str)) {
		die "TL#unescapeJs: arg[1] is not defined. (第1引数が指定されていません)\n";
	}

	my $map = {
	  'r' => "\r",
	  'n' => "\n",
	  "'" => "'",
	  '"' => '"',
	  "\\" => "\\",
	  "x3c" => "<",
	  "x3e" => ">",
	};
	$str = "$str"; # stringify.
	$str =~ s/\\([rn'"\\]|x3[ce])/$map->{$1}/ge;

	$str;
}

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

	if(!defined($str)) {
		die "TL#encodeURL: arg[1] is not defined. (第1引数が指定されていません)\n";
	}

	$str = "$str"; # stringify.
	$str =~ s/([^a-zA-Z0-9\-\_\.\!\~\*\'\(\)])/
		'%' . sprintf('%02x', unpack("C", $1))/eg;

	$str;
}

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

	if(!defined($str)) {
		die "TL#decodeURL: arg[1] is not defined. (第1引数が指定されていません)\n";
	}

	$str = "$str"; # stringify.
	$str =~ s/\%([a-zA-Z0-9]{2})/pack("C", hex($1))/eg;

	$str;
}

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

	if(!defined($str)) {
		die "TL#escapeSqlLike: arg[1] is not defined. (第1引数が指定されていません)\n";
	}

	$str = "$str"; # stringify.
	$str =~ s/\\/\\\\/g;
	$str =~ s/\%/\\\%/g;
	$str =~ s/\_/\\\_/g;

	$str;
}

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

	if(!defined($str)) {
		die "TL#unescapeSqlLike: arg[1] is not defined. (第1引数が指定されていません)\n";
	}

	$str = "$str"; # stringify.
	$str =~ s/\\\%/\%/g;
	$str =~ s/\\\_/\_/g;
	$str =~ s/\\\\/\\/g;

	$str;
}

sub __die_handler_for_localeval
{
	# スタックトレースを付け加えて再度dieする。
	# それ以外の事はしない。
	my $msg = shift;

	die isa($msg, 'Tripletail::Error') ? $msg : $TL->newError(error => $msg);
}

sub startCgi {
	my $this = shift;
	my $param = { @_ };

    local $IN_EXTENT_OF_STARTCGI = 1;
	$this->{script_name} = $0;

	$this->_clearCwd();
	$this->{outputbuffering} = $this->INI->get(TL => 'outputbuffering', 0);

	my $main_err;
	CORE::eval {
		# trap = diewithprint の場合はエラーハンドラを付け替える
		# そうしないと Content-Type: text/plain が出力されてしまう。
		if($this->{trap} eq 'diewithprint') {
			$SIG{__DIE__} = \&__die_handler_for_localeval;
		}

		# Tripletail::Debugをロード。debug機能が有効になっていれば、
		# ここで各種フック類がインストールされる。
		$this->getDebug;

		if(defined(my $group = $param->{-DB})) {
			require Tripletail::DB;

			if(!ref($group)) {
				Tripletail::DB->_connect([$group]);
			} elsif (ref($group) eq 'ARRAY') {
				Tripletail::DB->_connect($group);
			}
		}

		if(!defined($param->{'-main'})) {
			die __PACKAGE__."#startCgi: -main handler is not defined. (-main引数が指定されていません)\n";
		}

		# ここでフィルタ類のデフォルトを設定
		if(!$this->getContentFilter) {
			$this->setContentFilter('Tripletail::Filter::HTML');
		}
		if(!$this->getInputFilter) {
			$this->setInputFilter('Tripletail::InputFilter::HTML');
		}
		if( $ENV{MOD_PERL} )
		{
			my $r = Apache2::RequestUtil->request;
			$TL->{mod_perl} = { request => $r };
		}

		if($this->_getRunMode eq 'FCGI') {
			# FCGIモードならメモリ監視フックとファイル監視フックをインストール
			$this->getMemorySentinel->__install;
			$this->getFileSentinel->__install;
		}


		if($this->_getRunMode eq 'FCGI') {
			# FCGIモード

			my $maxrequestcount = $this->INI->get(TL => 'maxrequestcount', 0);
            if ($this->INI->get(TL => 'fcgilog')) {
                $this->log(FCGI => 'Starting FCGI Loop... maxrequestcount: ' . $maxrequestcount);
            }
			my $requestcount = 0;

			do {
				local $SIG{__DIE__} = 'DEFAULT';
				#no warnings;
				CORE::eval 'use FCGI';
			};
			if($@) {
				die __PACKAGE__."#startCgi: failed to load FCGI.pm [$@] (FCGI.pmがロードできません)\n";
			}

			my $exit_requested;
			my $handling_request;
			local $SIG{USR1} = sub {
                if ($this->INI->get(TL => 'fcgilog')) {
                    $this->log("SIGUSR1 received");
                }
				$exit_requested = 1;
			} if( exists($SIG{USR1}) );
			local $SIG{TERM} = sub {
				# NB: FCGIモードでは、fastcgiマネージャから
				#     SIGTERMが送られてくる為、
				#     状況に応じて挙動を変更する(以下を参照)
				# http://d.tir.jp/pw?mod_fastcgi の一番下
				# https://192.168.0.17/mantis/view.php?id=1037
                if ($this->INI->get(TL => 'fcgilog')) {
                    $this->log("SIGTERM received");
                }
				$exit_requested = 1;
			};
			local $SIG{PIPE} = 'IGNORE';

			{
				#no warnings;
				$this->{fcgi_request} = FCGI::Request(
					\*STDIN, \*STDOUT, \*STDERR, \%ENV,
					0, FCGI::FAIL_ACCEPT_ON_INTR());
			}

			while(1) {
				my $accepted = CORE::eval {
					#no warnings;
					local $SIG{__DIE__} = 'DEFAULT';
					local $SIG{USR1} = sub {
						$exit_requested = 1;
						die("SIGUSR1 received\n");
					} if( exists($SIG{USR1}) );
					local $SIG{TERM} = sub {
						$exit_requested = 1;
						die("SIGTERM received\n");
					};
					$this->{fcgi_request}->Accept() >= 0;
				};
				if($@) {
					if($exit_requested) {
                        if ($this->INI->get(TL => 'fcgilog')) {
                            $this->log(FCGI => "FCGI_request->Accept() got interrupted : $@");
                        }
						$this->{fcgi_request}->Finish();
						last;
					}else {
						$this->log(FCGI => "FCGI_request->Accept() failed : $@");
						exit 1;
					}
				}

				if(!$accepted) {
					last;
				}

				if( $requestcount==0 )
				{
					# 最初のリクエスト受信時でプロセスの初期化.
					if(defined(my $groups = $param->{-Session})) {
						require Tripletail::Session;

						Tripletail::Session->_init($groups);
					}
					$this->__executeHook('init');
				}
				$this->_update_processname('fcgi run');
				
				$this->__executeCgi($param->{-main});
				$main_err = $@;
				$this->_update_processname('fcgi wait');

				{
					#no warnings;
					$this->{fcgi_request}->Flush;
				}

				$requestcount++;

				if($exit_requested || ($maxrequestcount && ($requestcount >= $maxrequestcount))) {
					last;
				}
				$this->{fcgi_restart} and last;
			}
			{
				#no warnings;
				$this->{fcgi_request}->Finish;
			}
            $this->{fcgi_request} = undef;

            if ($this->INI->get(TL => 'fcgilog')) {
                $this->log(FCGI => "FCGI Loop is terminated ($requestcount reqs processed).");
            }
		} else {
			# CGIモード
            if ($this->INI->get(TL => 'fcgilog')) {
                $this->log(TL => 'CGI mode');
            }
			
			# プロセスの初期化.
			if(defined(my $groups = $param->{-Session})) {
				require Tripletail::Session;

				Tripletail::Session->_init($groups);
			}
			$this->__executeHook('init');

			$this->__executeCgi($param->{-main});
			$main_err = $@;
		}

		$this->__executeHook('term');
	};
	if(my $err = $@) {
		if ($this->{trap} eq 'none') {
			die $err;
		}

		if (isa($err, 'Tripletail::Error') and $err->type eq 'error') {
			$err->message(
				"Died outside the `-main':\n" . $err->message);
		}

		$this->_sendErrorIfNeeded($err);
        $this->_call_fault_handler($err);
	}
	!$@ && $main_err and $@ = $main_err;

	if( $ENV{MOD_PERL} )
	{
		Apache2::Const->OK;
	}else
	{
		$this;
	}
}

sub _update_processname
{
	my $this = shift;
	my $command = shift;
	
	if($this->INI->get(TL => 'command_add_processname', '1'))
	{
	#	my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime(time);
	#	my $timestr = sprintf('%02d:%02d:%02d', $mon + 1, $mday, $hour, $min, $sec);
		my $serial = sprintf('%06d', $LOG_SERIAL % 1000000);
		
		$0 = "perl $serial ($command) " . (defined($this->{script_name}) ? $this->{script_name} : '');
	}
	
}

sub _call_fault_handler
{
	my $this = shift;
	my $err  = shift;
	
	my $printed;
	FAULT_HANDLER:
	{
		my $handler_name = $this->INI->get(TL => 'fault_handler');
		$handler_name or last FAULT_HANDLER;
		
		my ($modname, $subname) = $handler_name =~ /^(?:::)?(?:(\w+(?:::\w+)*)::)?(\w+)$/;
		if( !defined($subname) )
		{
			$TL->log("fault_handler: invalid name [$handler_name]");
			last FAULT_HANDLER;
		}
		$modname ||= 'main';
		my $sub = $modname->can($subname);
		if( !$sub )
		{
			# load module.
			(my $pmname = $modname.'.pm') =~ s{::}{/}g;
			if( !$INC{$pmname} )
			{
				local($@);
				CORE::eval "require $modname; 1;";
				if( $@ )
				{
					$TL->log("fault_handler: failed to load module [$modname]: $@");
					last FAULT_HANDLER;
				}
			}
			$sub = $modname->can($subname);
			if( !$sub )
			{
				$TL->log("fault_handler: no such subroutine [$subname] in [$modname]");
				last FAULT_HANDLER;
			}
		}
		if( !defined(&$sub) )
		{
			$TL->log("fault_handler: subroutine [$subname] in [$modname] is undefined");
			last FAULT_HANDLER;
		}
		
		local($@);
		CORE::eval{
			$modname->$sub($err);
		};
		if( $@ )
		{
			$TL->log("fault_handler: subroutine [$subname] in [$modname] threw an error: $@");
			last FAULT_HANDLER;
		}
		$printed = 1;
	}
	
	if( !$printed )
	{
		$this->__dispError($err);
	}
	return;
}

sub _fcgi_restart
{
	my $this = shift;
	@_ and $this->{fcgi_restart} = shift;
	$this->{fcgi_restart};
} 

sub trapError {
	my $this = shift;
	my $param = { @_ };

	my $main_err;
	CORE::eval {
		# trap = diewithprint の場合はエラーハンドラを付け替える
		# そうしないと Content-Type: text/plain が出力されてしまう。
		local($SIG{__DIE__}) = 'DEFAULT';
		if ($this->{trap} eq 'diewithprint'){
			$SIG{__DIE__} = \&__die_handler_for_localeval;
		}
		# Tripletail::Debugをロード。debug機能が有効になっていれば、
		# ここで各種フック類がインストールされる。
		$this->getDebug;

		if(defined(my $group = $param->{-DB})) {
			require Tripletail::DB;

			if(!ref($group)) {
				Tripletail::DB->_connect([$group]);
			} elsif(ref($group) eq 'ARRAY') {
				Tripletail::DB->_connect($group);
			}
		}

		if(!defined($param->{'-main'})) {
			die __PACKAGE__."#trapError: -main handler is not defined. (-main引数が指定されていません)\n";
		}

		$this->__executeHook('init');
		$this->__executeHook('initRequest');
		$this->__executeHook('preRequest');
		$this->_saveContentFilter;

		CORE::eval {
			$param->{'-main'}();
		};
		$main_err = $@;
		if(my $err = $@) {
			if($this->{trap} eq 'none') {
				die $err;
			}

			$this->_sendErrorIfNeeded($err);
			print STDERR $err;
			
			my $errorlog = $this->INI->get(TL => 'errorlog', 1);
			if($errorlog > 0) {
				$this->log(__PACKAGE__, "$err");
			}
		}

		$this->_restoreContentFilter;
		$this->__executeHook('postRequest');
		$this->__executeHook('term');
	};
	if(my $err = $@) {
		if ($this->{trap} eq 'none'){
			die $err;
		}

		# このevalでキャッチされたという事は、-mainの外で例外が起きた。
		$this->log(trapError => "Died outside the `-main': $err");
		print STDERR __PACKAGE__."#trapError: died outside the `-main': $err (main関数の外側でdieしました)\n";
	}
	!$@ && $main_err and $@ = $main_err;

	$this;
}

sub dispatch {
	my $this = shift;
	my $name = shift;
	my $param = { @_ };

	if(!defined($name)) {
		if(!defined($param->{'default'})) {
			die __PACKAGE__."#dispatch： arg[1] is not defined but no default value is specified. (第1引数もdefaultも指定されていません)\n";
		} elsif(ref($param->{'default'})) {
			die __PACKAGE__."#dispatch: the default value is a reference [$param->{'default'}]. (default指定がリファレンスです)\n";
		} else {
			$name = $param->{'default'};
		}
	} elsif(ref($name)) {
		die __PACKAGE__."#dispatch: arg[1] is a reference. [$name] (第1引数がリファレンスです)\n";
	} elsif( $name !~ /^[A-Z]/ ) {
		if(!defined($param->{'onerror'})) {
			die __PACKAGE__."#dispatch: arg[1] must start with upper case character. (第1引数は大文字から始まる必要があります)\n";
		} else {
			CORE::eval {
				$param->{'onerror'}();
			};
			if($@) {
				die __PACKAGE__."#dispatch: onerror handler threw an error. [$@] (onerrorの関数でエラーが発生しました)\n";
			}
			return;
		}
	}

	my $args = $param->{args} || [];
	if( !UNIVERSAL::isa($args, 'ARRAY') )
	{
		die __PACKAGE__."#dispatch： arg{args} is not array-ref. (args 引数がarray-refではありません)\n";
	}

	# 呼ばれる関数のあるパッケージはcallerから得る。
	my $pkg = caller;
	my $func = $pkg->can("Do$name");

	if($func && defined(&$func)) {
		$this->_update_processname("Do$name");
		$func->(@$args);
		1;
	} else {
		if(!defined($param->{'onerror'})) {
			undef;
		} else {
			CORE::eval {
				$param->{'onerror'}();
			};
			if($@) {
				die __PACKAGE__."#dispatch: onerror handler threw an error. [$@] (onerrorの関数でエラーが発生しました)\n";
			}
		}
	}
}

sub log {
	my $this = shift;
    my $group;
    my $message;

    my $stringify = sub {
        my $val = shift;
        
        if (ref $val) {
            Data::Dumper->new([$val])
              ->Indent(1)->Purity(0)->Useqq(1)->Terse(1)->Deepcopy(1)
                ->Quotekeys(0)->Sortkeys(1)->Deparse(1)->Dump;
        }
        else {
            $val; # 元々スカラーだった
        }
    };
    
    if (@_ == 1) {
        # "呼出し元ファイル名(行数):関数名"
        my ($filename, $line) = (caller 0)[1, 2];
        my $sub = (caller 1)[3];
        defined($sub) or $sub = '(nosub)';

        $group   = sprintf '%s(%d) >> %s', $filename, $line, $sub;
        $message = $stringify->(shift);
    }
    elsif (@_ == 2) {
        $group   = shift;
        $message = $stringify->(shift);
    }
    else {
        die "TL#log: invalid call of \$TL->log(). (引数の数が正しくありません)\n";
    }

	if(!defined($group)) {
		die "TL#log: arg[1] is not defined. (第1引数が指定されていません)\n";
	}
	if(!defined($message)) {
		die "TL#log: arg[2] is not defined. (第2引数が指定されていません)\n";
	}

	$this->getDebug->_tlLog(
		group => $group,
		log   => $message,
	);

	$this->_log($group, $message);
}

sub _log {
	my $this = shift;
	my $group = shift;
	my $log = shift;

	if(!defined($group)) {
		die "TL#_log: arg[1] is not defined. (第1引数が指定されていません)\n";
	}
	if(!defined($log)) {
		die "TL#_log: arg[2] is not defined. (第2引数が指定されていません)\n";
	}

	my $time = time;
	my @localtime = localtime($time);
	$localtime[4]++;
	$localtime[5] += 1900;

	$log = sprintf('== %02d:%02d:%02d(%08x) %04x %04x [%s]',
		@localtime[2,1,0], $time, $$, ($LOG_SERIAL % 0x10000), $group)
		. "\n" . $log . "\n";

	if(!exists($this->{logdir})) {
		$this->{logdir} = $this->INI->get_reloc(TL => 'logdir');
		if( defined($this->{logdir}) )
		{
			# trust TL.logdir parameter.
			$this->{logdir} = $this->{logdir}=~/^(.*)\z/ && $1 or die "untaint";
		}
	}
	if(!defined($this->{logdir})) {
		return $this;
	}

	my $dirpath = $this->{logdir} . '/'
		. sprintf('%04d%02d', @localtime[5,4]);
	my @dirstat = stat($dirpath);

	my $path = $this->{logdir} . '/'
		. sprintf('%04d%02d/%02d-%02d.log', @localtime[5,4,3,2]);

	if(!exists($this->{cacheLogPath}) || !defined($dirstat[1]) || $path ne $this->{cacheLogPath}) {
		# month is changed.
		delete $this->{cacheLogFh};
		my $umask = umask(0);
		local($@);
		CORE::eval {
			use File::Path;
			my $dir = $path;
			$dir =~ s,/[^/]*$,,;
			mkpath($dir);
		};
		if ($@){
            print "Status: 500 Internal Server Error\r\n";
			print "Content-Type: text/plain\r\n\r\n";
			print "Failed to create a directory [$path]\n";
			warn "Failed to create a directory [$path] (logdirで指定されたログ用のディレクトリを作成できません)";
			$this->sendError(
				title => "TL LogError",
				error => "Failed to create a directory [$path]($!)",
				nologging => 1,
			);
			exit;
		}
		$this->{cacheLogPath} = $path;
		umask($umask);
	}

	my @stat = stat($path);
	if(!defined($this->{cacheLogFh}) || !defined($stat[1]) || ($this->{cacheLogInode} != $stat[1])) {

		# hour is changed.
		my $fh = $this->_gensym;
		if(!open($fh, ">>$path")) {
            print "Status: 500 Internal Server Error\r\n";
			print "Content-Type: text/plain\r\n\r\n";
			print "Failed to open [$path]\n";
			warn "Failed to open [$path] (logdirで指定されたログ用のディレクトリにアクセスできません)";
			$this->sendError(
				title => "TL LogError",
				error => "Failed to open a log [$path]($!)",
				nologging => 1,
			);
			exit;
		}
		binmode($fh);
		my @newstat = stat($path);
		$this->{cacheLogFh} = $fh;
		$this->{cacheLogInode} = $newstat[1];
		local($@);
		CORE::eval
		{
			my $rel_to_logfile = sprintf('%04d%02d/%02d-%02d.log', @localtime[5,4,3,2]);
			local($SIG{__DIE__}) = 'DEFAULT';
			my $cur_linkfile = File::Spec->catfile($this->{logdir}, "current");
			unlink($cur_linkfile);
			symlink($rel_to_logfile, $cur_linkfile);
		};
	}

	my $fh = $this->{cacheLogFh};
	flock($fh, 2);
	seek($fh, 0, 2);
	syswrite($fh, $log);
	flock($fh, 8);

	$this;
}

sub getLogHeader {
	my $this = shift;
	
	my $time = time;
	my @localtime = localtime($time);
	$localtime[4]++;
	$localtime[5] += 1900;

	sprintf('%02d:%02d:%02d(%08x) %04x %04x',
		@localtime[2,1,0], $time, $$, ($LOG_SERIAL % 0x10000));
}

sub setHook {
	my $this = shift;
	my $type = shift;
	my $priority = shift;
	my $code = shift;

	if(!defined($type)) {
		die __PACKAGE__."#setHook: arg[1] is not defined. (第1引数が指定されていません)\n";
	}
	if(ref($type)) {
		die __PACKAGE__."#setHook: arg[1] is a reference. (第1引数がリファレンスです)\n";
	}
	if(!exists($this->{hook}{$type})) {
		die __PACKAGE__."#setHook: [$type] is an invalid hook type. (hook type の指定が不正です)\n";
	}
	if(!defined($priority)) {
		die __PACKAGE__."#setHook: arg[2] is not defined. (第2引数が指定されていません)\n";
	}
	if(ref($priority)) {
		die __PACKAGE__."#setHook: arg[2] is a reference. (第2引数がリファレンスです)\n";
	}
	if($priority !~ m/^-?\d+$/) {
		die __PACKAGE__."#setHook: arg[2] must be an integer. [$priority] (priorityは整数のみ指定できます)\n";
	}
	if(ref($code) ne 'CODE') {
		die __PACKAGE__."#setHook: arg[3] is not a CODE Ref. (第3引数がコードリファレンスではありません)\n";
	}

	$this->{hook}{$type}{$priority} = $code;

	@{$this->{hooklist}{$type}} = map {
			$this->{hook}{$type}{$_};
		} sort {
			$a <=> $b;
		} keys %{$this->{hook}{$type}};

	$this;
}

sub removeHook {
	my $this = shift;
	my $type = shift;
	my $priority = shift;

	if(!defined($type)) {
		die __PACKAGE__."#removeHook: arg[1] is not defined. (第1引数が指定されていません)\n";
	}
	if(ref($type)) {
		die __PACKAGE__."#removeHook: arg[1] is a reference. (第1引数がリファレンスです)\n";
	}
	if(!exists($this->{hook}{$type})) {
		die __PACKAGE__."#removeHook: [$type] is an invalid hook type. (hook type の指定が不正です)\n";
	}
	if(!defined($priority)) {
		die __PACKAGE__."#setHook: arg[2] is not defined. (第2引数が指定されていません)\n";
	}
	if(ref($priority)) {
		die __PACKAGE__."#setHook: arg[2] is a reference. (第2引数がリファレンスです)\n";
	}

	delete $this->{hook}{$type}{$priority};

	@{$this->{hooklist}{$type}} = map {
			$this->{hook}{$type}{$_};
		} sort {
			$a <=> $b;
		} keys %{$this->{hook}{$type}};

	$this;
}

sub setContentFilter {
	my $this = shift;
	my $classname = shift;
	my $priority = 1000;
	my %option = @_;

	if(!defined($classname)) {
		die __PACKAGE__."#setContentFilter: arg[1] is not defined. (第1引数が指定されていません)\n";
	} elsif(ref($classname) eq 'ARRAY') {
		($classname, $priority) = @$classname;
		if(!defined($classname)) {
			die __PACKAGE__."#setContentFilter: arg[1][0] is not defined. (第1引数の配列の1番目の要素にクラス名が指定されていません)\n";
		} elsif(ref($classname)) {
			die __PACKAGE__."#setContentFilter: arg[1][0] is a reference. (第1引数の配列の1番目の要素がリファレンスです)\n";
		}

		if (!defined($priority)) {
			die __PACKAGE__."#setContentFilter: arg[1][1] is not defined. (第1引数の配列の2番目の要素にプライオリティが指定されていません)\n";
		} elsif(ref($priority)) {
			die __PACKAGE__."#setContentFilter: arg[1][1] is a reference. (第1引数の配列の2番目の要素がリファレンスです)\n";
		} elsif($priority !~ m/^\d+$/) {
			die __PACKAGE__."#setContentFilter: arg[1][1] must be an integer. [$priority] (priorityは整数のみ指定できます)\n";
		}
	} elsif(ref($classname)) {
		die __PACKAGE__."#setContentFilter: arg[1] is not a scalar nor an ARRAY ref. (第1引数がスカラでも配列のリファレンスでもありません)\n";
	}

	do {
		local $SIG{__DIE__} = 'DEFAULT';
		CORE::eval "require $classname";
	};
	if($@) {
		die $@;
	}

	do {
		no strict;
		*{"${classname}\::TL"} = *Tripletail::TL;
	};

	$this->{filter}{$priority} = $classname->_new(%option);
	$this->_updateFilterList('filter');

	$this;
}

sub removeContentFilter {
	my $this = shift;
	my $priority = @_ ? shift : 1000;

	delete $this->{filter}{$priority};
	$this->_updateFilterList('filter');

	$this;
}

sub getContentFilter {
	my $this = shift;
	my $priority = @_ ? shift : 1000;

	$this->{filter}{$priority};
}

sub setInputFilter {
	my $this = shift;
	my $classname = shift;
	my $priority = 1000;
	my %option = @_;

	if (!defined($classname)) {
		die __PACKAGE__."#setInputFilter: arg[1] is not defined. (第1引数が指定されていません)\n";
	} elsif(ref($classname) eq 'ARRAY') {
		($classname, $priority) = @$classname;
		if(!defined($classname)) {
			die __PACKAGE__."#setInputFilter: arg[1][0] is not defined. (第1引数の配列の1番目の要素にクラス名が指定されていません)\n";
		} elsif(ref($classname)) {
			die __PACKAGE__."#setInputFilter: arg[1][0] is a reference. (第1引数の配列の1番目の要素がリファレンスです)\n";
		}

		if(!defined($priority)) {
			die __PACKAGE__."#setInputFilter: arg[1][1] is not defined. (第1引数の配列の2番目の要素にプライオリティが指定されていません)\n";
		} elsif(ref($priority)) {
			die __PACKAGE__."#setInputFilter: arg[1][1] is a reference. (第1引数の配列の2番目の要素がリファレンスです)\n";
		} elsif($priority !~ m/^\d+$/) {
			die __PACKAGE__."#setInputFilter: arg[1][1] must be an integer. [$priority] (priorityは整数のみ指定できます)\n";
		}
	} elsif(ref($classname)) {
		die __PACKAGE__."#setInputFilter: arg[1] is not a scalar nor an ARRAY ref. (第1引数がスカラでも配列のリファレンスでもありません)\n";
	}

	do {
		local $SIG{__DIE__} = 'DEFAULT';
		CORE::eval "require $classname";
	};
	if($@) {
		die $@;
	}

	do {
		no strict;
		*{"${classname}\::TL"} = *Tripletail::TL;
	};

	$this->{inputfilter}{$priority} = $classname->_new(%option);
	$this->_updateFilterList('inputfilter');

	$this;
}

sub removeInputFilter {
	my $this = shift;
	my $priority = @_ ? shift : 1000;

	delete $this->{inputfilter}{$priority};
	$this->_updateFilterList('inputfilter');

	$this;
}

sub getInputFilter {
	my $this = shift;
	my $priority = @_ ? shift : 1000;

	$this->{inputfilter}{$priority};
}

sub _sendErrorIfNeeded {
    my $this = shift;
    my $err = shift;
    
    isa($err, 'Tripletail::Error') or
      $err = $TL->newError('error' => $err);

    my $emtype = $this->INI->get(TL => 'errormailtype', 'error memory-leak');
    my $types = {map { $_ => 1 } split /\s+/, $emtype};

    if ($types->{$err->type}) {
        my $title  = 'Tripletail: ' . $err->title;
        my $maxlen = $this->INI->get(TL => errormail_subject_len => 100);

        $title =~ s/\r|\n/ /g;
        $title =~ s/[\x00-\x1F]//g;

        if (length($title) > $maxlen) {
            $title = substr($title, 0, $maxlen) . '...';
        }

        $this->sendError(
            title => $title,
            error => ($err->type eq 'error' ? "$err" : $err->message),
           );
    }
}

sub _hostname
{
	my $this = shift;
	my $host = $this->_readcmd("hostname -f 2>&1");
	$host ||= $this->_readcmd("hostname 2>&1");
	$host && $host=~/^\s*([\w.-]+)\s*$/ ? $1 : '';
}

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

	my $email;
	my ($rcpt, $group);
	if($email = $this->INI->get(TL => 'errormail')) {
		if($email =~ m/^(.+?)%(.+)$/) {
			$rcpt = $1;
			$group = $2;
		} else {
			$rcpt = $email;
			$group = 'Sendmail';
		}
	} else {
		return;
	}

	local($@);

	if(!defined($opts->{title})) {
		$opts->{title} = "Untitled";
	}
	if(!defined($opts->{error})) {
		$opts->{title} = "Unknown Error";
	}

	my @lines;
	push @lines, "TITLE: $opts->{title}";
	push @lines, "ERROR: $opts->{error}";
	push @lines, '';
	push @lines, '----';

	my $host = $this->_hostname();
	if($host) {
		chomp $host;
		unshift @lines, "HOST: $host";
	}

	my $locinfo = '@' . ($host || '-');
	if(defined $0) {
		$locinfo = $0 . $locinfo;

		unshift @lines, "SCRIPT: $0";
	}

	if($this->{CGIORIG}) {
		foreach my $key ($this->{CGIORIG}->getKeys) {
			foreach my $data ($this->{CGIORIG}->getValues($key)) {
				push @lines, "[CGI:$key] $data";
			}
		}
	}

	foreach my $key (keys %ENV) {
		push @lines, "[ENV:$key] $ENV{$key}";
	}

	CORE::eval {
		my $mail = $this->newMail->setHeader(
				From    => $rcpt,
				To      => $rcpt,
				Subject => "$opts->{title} $locinfo",
		)->setBody(join "\n", @lines)->toStr;

		$this->newSendmail($group)->_setLogging(0)->connect->send(
			from => $rcpt,
			rcpt => $rcpt,
			data => $mail,
		)->disconnect;
	};
	if(my $err = $@) {
		if(! $opts->{nologging}) {
			$this->log(__PACKAGE__, "Failed to send an error mail: $err");
		}
	}
}

sub print {
	my $this = shift;
	my $data = shift;

	local $| = 1;

	if(!defined($data)) {
		die __PACKAGE__."#print: arg[1] is not defined. (第1引数が指定されていません)\n";
	}

	if(@{$this->{filterlist}} == 0) {
		# フィルタが一つも無い時はprintできない。
		die __PACKAGE__."#print: we have no content-filters. Set at least one filter. (コンテンツフィルタが指定されていません)\n";
	}

	foreach my $filter (@{$this->{filterlist}}) {
		$data = $filter->print($data);
	}
	if($this->{outputbuffering}) {
		$this->{outputbuff} .= $data;
	} else {
		print $data;
	}

	$this->{printflag} ||= 1;

	$this;
}

sub location {
	my $this = shift;
	my $url = shift;
	
	if(exists($this->{printflag})) {
		die __PACKAGE__."#location: \$TL->location() must not be called after calling \$TL->print(). (printを実行後にlocationが呼び出されました)\n";
	}
	
	$this->getContentFilter->_location($url);
	
	$this;
}

sub parsePeriod {
	# 時刻指定 (sec, min等) をパースし、秒数に変換する。
	my $this = shift;
	my $str = shift;

	if(!defined($str)) {
		die __PACKAGE__."#parsePeriod: arg[1] is not defined. (第1引数が指定されていません)\n";
	}

	$str = lc($str);

	my $result = 0;

	my $lastnum = undef;
	local *commit = sub {
			my $unit = shift;

		if(!defined($lastnum)) {
			die __PACKAGE__."#parsePeriod: invalid time string [$str]:".
			" It has an isolated unit that does not follow any digits. (時刻指定が正しくありません。単位の前に数字がありません)\n";
		}

		$result += $lastnum * $unit;
		$lastnum = undef;
	};

	local($_) = $str;
	while(1) {
		length or last;

		s/^\s+//;

		if(s/^sec(?:onds?)?//) {
			commit(1);
		} elsif(s/^min(?:utes?)?//) {
			commit(60);
		} elsif(s/^hours?//) {
			commit(60 * 60);
		} elsif(s/^days?//) {
			commit(60 * 60 * 24);
		} elsif(s/^mon(?:ths?)?//) {
			commit(60 * 60 * 24 * 30.436875);
		} elsif(s/^years?//) {
			commit(60 * 60 * 24 * 365.2425);
		} elsif(s/^(\d+)//) {
			if(defined($lastnum)) {
				die __PACKAGE__."#parsePeriod: invalid time string [$str]:".
				" It has digits followed by another digits instead of unit. (時刻指定が正しくありません。単位の指定が足りません)\n";
			}

			$lastnum = $1;
		} else {
			die __PACKAGE__."#parsePeriod: invalid format: [$_] (形式が不正です)\n";
		}
	}

	if(defined($lastnum)) {
		commit(1);
	}

	int($result);
}

sub parseQuantity {
	# 量指定 (k, m等) をパースし、そのままの数に変換する。
	my $this = shift;
	my $str = shift;

	if(!defined($str)) {
		die __PACKAGE__."#parseQuantity: arg[1] is not defined. (第1引数が指定されていません)\n";
	}

	$str = lc($str);

	my $result = 0;

	my $lastnum = undef;
	local *commit = sub {
		my $unit = shift;

		if(!defined($lastnum)) {
			die __PACKAGE__."#parsePeriod: invalid quantity string [$str]:".
			" It has an isolated unit that does not follow any digits. (量指定が正しくありません。単位の前に数字がありません)\n";
		}

		$result += $lastnum * $unit;
		$lastnum = undef;
	};

	local($_) = $str;
	while(1) {
		length or last;

		s/^\s+//;

		if(s/^ki//) {
			commit(1024);
		} elsif(s/^mi//) {
			commit(1024 * 1024);
		} elsif(s/^gi//) {
			commit(1024 * 1024 * 1024);
		} elsif(s/^ti//) {
			commit(1024 * 1024 * 1024 * 1024);
		} elsif(s/^pi//) {
			commit(1024 * 1024 * 1024 * 1024 * 1024);
		} elsif(s/^ei//) {
			commit(1024 * 1024 * 1024 * 1024 * 1024 * 1024);
		} elsif(s/^k//) {
			commit(1000);
		} elsif(s/^m//) {
			commit(1000 * 1000);
		} elsif(s/^g//) {
			commit(1000 * 1000 * 1000);
		} elsif(s/^t//) {
			commit(1000 * 1000 * 1000 * 1000);
		} elsif(s/^p//) {
			commit(1000 * 1000 * 1000 * 1000 * 1000);
		} elsif(s/^e//) {
			commit(1000 * 1000 * 1000 * 1000 * 1000 * 1000);
		} elsif(s/^(\d+)//) {
			if(defined($lastnum)) {
				die __PACKAGE__."#parseQuantity: invalid quantity string [$str]:".
				" It has digits followed by another digits instead of unit. (量指定が正しくありません。単位の指定が足りません)\n";
			}

			$lastnum = $1;
		} else {
			die __PACKAGE__."#parsePeriod, invalid format: [$_] (形式が不正です)\n";
		}
	}

	if(defined($lastnum)) {
		commit(1);
	}

	$result;
}


sub getCookie {
	my $this = shift;

    if (not $IN_EXTENT_OF_STARTCGI) {
        die __PACKAGE__.'#getCookie: this method must not be called outside $TL->startCgi(). (このメソッドを $TL->startCgi() の外から呼ぶ事は出来ません。)';
    }

	require Tripletail::Cookie;

	Tripletail::Cookie->_getInstance(@_);
}

sub newDateTime {
	my $this = shift;

	require Tripletail::DateTime;

	Tripletail::DateTime->_new(@_);
}

sub getDB {
	my $this = shift;

	require Tripletail::DB;

	Tripletail::DB->_getInstance(@_);
}

sub newDB {
	my $this = shift;

	require Tripletail::DB;

	Tripletail::DB->_new(@_);
}

sub getDebug {
	my $this = shift;

	require Tripletail::Debug;
	
	Tripletail::Debug->_getInstance(@_);
}

sub getCsv {
	my $this = shift;

	require Tripletail::CSV;

	Tripletail::CSV->_getInstance(@_);
}

sub newForm {
	my $this = shift;

	require Tripletail::Form;

	*Tripletail::Form::TL = *Tripletail::TL;

	Tripletail::Form->_new(@_);
}

sub newHtmlFilter {
	my $this = shift;

	require Tripletail::HtmlFilter;

	Tripletail::HtmlFilter->_new(@_);
}

sub newHtmlMail {
	my $this = shift;

	require Tripletail::HtmlMail;

	Tripletail::HtmlMail->_new(@_);
}

sub newIni {
	my $this = shift;

	require Tripletail::Ini;

	*Tripletail::Ini::TL = *Tripletail::TL;

	Tripletail::Ini->_new(@_);
}

sub newMail {
	my $this = shift;

	require Tripletail::Mail;

	Tripletail::Mail->_new(@_);
}

sub newPager {
	my $this = shift;

	require Tripletail::Pager;

	Tripletail::Pager->_new(@_);
}

sub getRawCookie {
	my $this = shift;

    if (not $IN_EXTENT_OF_STARTCGI) {
        die __PACKAGE__.'#getRawCookie: this method must not be called outside $TL->startCgi(). (このメソッドを $TL->startCgi() の外から呼ぶ事は出来ません。)';
    }

	require Tripletail::RawCookie;

	Tripletail::RawCookie->_getInstance(@_);
}

sub newSendmail {
	my $this = shift;

	require Tripletail::Sendmail;

	Tripletail::Sendmail->_new(@_);
}

sub newSMIME {
	my $this = shift;

	require Crypt::SMIME;

	Crypt::SMIME->new(@_);
}

sub newTagCheck {
	my $this = shift;

	require Tripletail::TagCheck;

	Tripletail::TagCheck->_new(@_);
}

sub newTemplate {
	my $this = shift;
	
	my $err;
	{
		local($@);
		CORE::eval{ require Tripletail::Template; };
		$err = $@;
	}
	$err and die $err;

	Tripletail::Template->_new(@_);
}

sub getSession {
	my $this = shift;

	require Tripletail::Session;

	Tripletail::Session->_getInstance(@_);
}

sub newValue {
	my $this = shift;

	require Tripletail::Value;

	Tripletail::Value->_new(@_);
}

sub newValidator {
	my $this = shift;
	
	require Tripletail::Validator;
	
	Tripletail::Validator->_new(@_);
}

sub newError {
	my $this = shift;

	# Tripletail::Error のロード失敗は特別に扱わなければならない。
	# die ハンドラがこれを利用する為である。
	if( !Tripletail::Error->can("_new") )
	{
		local($@);
		CORE::eval {
			require Tripletail::Error;
		};
		if ($@) {
			print STDERR $@;
			exit 1;
		}
	}

	Tripletail::Error->_new(@_);
}

sub getMemorySentinel {
	my $this = shift;

	require Tripletail::MemorySentinel;

	Tripletail::MemorySentinel->_getInstance(@_);
}

sub getFileSentinel {
	my $this = shift;

	require Tripletail::FileSentinel;

	Tripletail::FileSentinel->_getInstance(@_);
}

sub newMemCached {
	my $this = shift;

	require Tripletail::MemCached;

	Tripletail::MemCached->_new();
}

sub charconv {
	my $this = shift;

	require Tripletail::CharConv;

	Tripletail::CharConv->_getInstance()->_charconv(@_);
}

# -----------------------------------------------------------------------------
# ファイル関連.
# -----------------------------------------------------------------------------

sub _filecacheMax
{
	my $this = shift;
	@_ and $_FILE_CACHE_MAXSIZE = shift;
	$_FILE_CACHE_MAXSIZE;
}

sub _filecacheMemorySize
{
	$_FILE_CACHE_CURSIZE;
}

sub _fetchFileCache
{
	my $this = shift;
	my $fpath = shift;
	
	my $now = time;
	
	my ($inode, $size, $mtime);
	
	if( my $cache = $_FILE_CACHE{$fpath} )
	{
		if( $cache->{fetch_at}==$now )
		{
			return $cache;
		}
		
		my @st = stat($fpath);
		if( !@st )
		{
			if( $!{ENOENT} )
			{
				die __PACKAGE__."#_fetchFileCache: failed to stat file [$fpath]: $! (ファイルをstatできません; ファイルが存在しません)\n";
			}else
			{
				die __PACKAGE__."#_fetchFileCache: failed to stat file [$fpath]: $! (ファイルをstatできません)\n";
			}
		}
		($inode, $size, $mtime) = @st[1, 7, 9];
		if( $inode==$cache->{inode} && $size==$cache->{size} && $mtime==$cache->{mtime} )
		{
			$cache->{fetch_at} = $now;
			return $cache;
		}
		
		# unload.
		$_FILE_CACHE_CURSIZE -= $cache->{cache_size};
		delete $_FILE_CACHE{$fpath};
	}else
	{
		my @st = stat($fpath);
		if( !@st )
		{
			if( $!{ENOENT} )
			{
				die __PACKAGE__."#_fetchFileCache: failed to stat file [$fpath]: $! (ファイルをstatできません; ファイルが存在しません)\n";
			}else
			{
				die __PACKAGE__."#_fetchFileCache: failed to stat file [$fpath]: $! (ファイルをstatできません)\n";
			}
		}
		($inode, $size, $mtime) = @st[1, 7, 9];
	}
	
	my $cache = {
		inode => $inode,
		size  => $size,
		mtime => $mtime,
		path  => $fpath,
		data  => undef,
		text  => undef,
		
		fetch_at   => $now,
		cache_size => 312 + 24*5 + (25+length($fpath)) + 12*2,
	};
	if( $mtime < $now )
	{
		$_FILE_CACHE{$fpath} = $cache;
		$_FILE_CACHE_CURSIZE += $cache->{cache_size};
	}else
	{
		$cache->{cache_size} = undef;
	}
	$cache;
}

sub readFile {
	my $this = shift;
	my $fpath = shift;

	if(!defined($fpath)) {
		die __PACKAGE__."#readFile: arg[1] is not defined. (第1引数が指定されていません)\n";
	} elsif(ref($fpath)) {
		die __PACKAGE__."#readFile: arg[1] is a reference. (第1引数がリファレンスです)\n";
	}

	my $cache = $this->_fetchFileCache($fpath);
	if( !defined($cache->{data}) )
	{
		open my $fh, '<', $fpath
			or die __PACKAGE__."#readFile: failed to read file [$fpath]: $! (ファイルをstatできません)\n";

		local $/ = undef;
		$cache->{data} = <$fh>;
		if( $cache->{cache_size} )
		{
			$cache->{cache_size} += 25 + length($cache->{data});
			$_FILE_CACHE_CURSIZE  += 25 + length($cache->{data});
		}
	}
	$cache->{data};
}

sub readTextFile {
	my $this = shift;
	my $fpath = shift;
	my $coding = shift;

	my $cache = $this->_fetchFileCache($fpath);
	if( !defined($cache->{text}) )
	{
		$cache->{text} = $this->charconv(
			$this->readFile($fpath),
			$coding,
			'UTF-8',
		);
		if( $cache->{cache_size} )
		{
			$cache->{cache_size} += 25 + length($cache->{text});
			$_FILE_CACHE_CURSIZE += 25 + length($cache->{text});
		}
		
		# rawデータは使わないと思うので削除.
		if( defined($cache->{data}) )
		{
			if( $cache->{cache_size} )
			{
				$cache->{cache_size} -= 25 + length($cache->{data});
				$_FILE_CACHE_CURSIZE -= 25 + length($cache->{data});
			}
			delete $cache->{data};
		}
	}
	$cache->{text};
}

sub writeFile {
	my $this = shift;
	my $fpath = shift;
	my $fdata = shift;
	my $fmode = shift;

	if(!defined($fpath)) {
		die __PACKAGE__."#writeFile: arg[1] is not defined. (第1引数が指定されていません)\n";
	} elsif(ref($fpath)) {
		die __PACKAGE__."#writeFile: arg[1] is a reference. (第1引数がリファレンスです)\n";
	}
	
	$fmode = 0 if(!defined($fmode));

	my $fmode_str = '>';
	$fmode_str = '>>' if($fmode == 1);

	open my $fh, $fmode_str, $fpath
	  or die __PACKAGE__."#writeFile: failed to read file [$fpath]: $! (ファイルを読めません)\n";
	print $fh $fdata;
	close $fh;

}

sub writeTextFile {
	my $this = shift;
	my $fpath = shift;
	my $fdata = shift;
	my $fmode = shift;
	my $coding = shift;

	if(!defined($coding)) {
		$coding = 'UTF-8';
	}
	if(ref($coding)) {
		die __PACKAGE__."#writeTextFile: arg[4] is a reference. (第4引数がリファレンスです)\n";
	}

	$this->writeFile($fpath,$this->charconv($fdata,'UTF-8',$coding,),$fmode);
}

# -----------------------------------------------------------------------------
# --
# -----------------------------------------------------------------------------
sub watch {
	my $this = shift;

	require Tripletail::Debug::Watch;

	Tripletail::Debug::Watch::watch(@_);
}

sub dump {
    # dump($group, $obj)
    # dump($group, $obj, $level)
    # dump($obj)
    # dump($obj, $level)
	my $this = shift;
    my $group;
    my $val;
    my $level;

    my $auto_group = sub {
        # "呼出し元ファイル名(行数):関数名"
        my ($filename, $line) = (caller 1)[1, 2];
        my $sub = (caller 2)[3];

        sprintf '%s(%d) >> %s', $filename, $line, $sub;
    };

    if (@_ == 0 || @_ > 3) {
        die __PACKAGE__."#dump: invalid call of \$TL->dump(). (引数の数が正しくありません)\n";
    }
    elsif (@_ == 1) {
        $group = $auto_group->();
        $val   = shift;
        $level = 0;
    }
    elsif (@_ == 2) {
        if (ref $_[0]) {
            # dump($obj, $level)
            $group = $auto_group->();
            $val   = shift;
            $level = shift;
        }
        else {
            # dump($group, $obj)
            $group = shift;
            $val   = shift;
            $level = 0;
        }
    }
    elsif (@_ == 3) {
        $group = shift;
        $val   = shift;
        $level = shift;
    }
    else {
        die "Internal error";
    }

    my $dump = Data::Dumper->new([$val])
      ->Indent(1)->Purity(0)->Useqq(1)->Terse(1)->Deepcopy(1)
        ->Quotekeys(0)->Sortkeys(1)->Deparse(1)->Maxdepth($level)->Dump;

    $this->log($group => $dump);
}

sub setCacheFilter {
	my $this = shift;
	my $form = shift;
	my $charset = shift;
	
	if(!defined($form)) {
		die __PACKAGE__."#setCacheFilter: arg[1] is not defined. (第1引数が指定されていません)\n";
	} elsif(ref($form) eq 'HASH') {
		$form = $TL->newForm($form);
	} elsif(ref($form) ne 'Tripletail::Form') {
		die __PACKAGE__."#setCacheFilter: arg[1] is neither an instance of Tripletail::Form nor a HASH Ref. (第1引数がFormオブジェクトではありません)\n";
	}
	if(ref($charset)) {
		die __PACKAGE__."#setCacheFilter: arg[2] is a reference. (第2引数がリファレンスです)\n";
	}
	
	$charset = 'Shift_JIS' if(!defined($charset));

	$this->{memcache_form} = $form;
	$this->{memcache_charset} = $charset;
}

sub printCacheUnlessModified {
	my $this = shift;
	my $key = shift;
	my $status = shift;

	if(!defined($key)) {
		die __PACKAGE__."#printCacheUnlessModified: arg[1] is not defined. (第1引数が指定されていません)\n";
	} elsif(ref($key)) {
		die __PACKAGE__."#printCacheUnlessModified: arg[1] is a reference. [$key] (第1引数がリファレンスです)\n";
	}
	
	if(!defined($status)) {
		$status = 304;
	} elsif(ref($status)) {
		die __PACKAGE__."#printCacheUnlessModified: arg[2] is a reference. [$key] (第2引数がリファレンスです)\n";
	} elsif($status ne '200' && $status ne '304') {
		die __PACKAGE__."#printCacheUnlessModified: arg[2] is neither 200 nor 304. [$key] (第2引数は200か304のみ指定できます)\n";
	}

	my $cachedata = $TL->newMemCached->get($key);
	return 1 if(!defined($cachedata));
	if($cachedata =~ s/^(\d+),//) {
		my $cachetime = $1;
		if($status eq '304') {
			my $http_if_modified_since = $ENV{HTTP_IF_MODIFIED_SINCE};
			if(defined($http_if_modified_since)) {
				#;より後ろのデータは日付ではないので落とす
				$http_if_modified_since =~ s/;.+//;
				if($TL->newDateTime($http_if_modified_since)->getEpoch >= $cachetime) {
					$TL->setContentFilter('Tripletail::Filter::HeaderOnly');
					$TL->getContentFilter->setHeader('Status' => '304');
					$TL->getContentFilter->setHeader('Last-Modified' => $TL->newDateTime->setEpoch($cachetime)->toStr('rfc822'));
					return undef;
				}
			}
		}
		if(exists($this->{memcache_form}) && defined($this->{memcache_form})) {
			$this->{memcache_charset} = 'Shift_JIS' if(!exists($this->{memcache_charset}) || !defined($this->{memcache_charset}));
			foreach my $key2 ($this->{memcache_form}->getKeys){
				my $val = $TL->charconv($this->{memcache_form}->get($key2), 'UTF-8' => $this->{memcache_charset});
				$cachedata =~ s/$key2/$val/g;
			}
		}
		$TL->setContentFilter('Tripletail::Filter::MemCached',key => $key, mode => 'pass-through', cachedata => $cachedata);
		return undef;
	}
	1;
}

sub setCache {
	my $this = shift;
	my $key = shift;
	my $priority = shift;

	if(!defined($key)) {
		die __PACKAGE__."#setCache: arg[1] is not defined. (第1引数が指定されていません)\n";
	} elsif(ref($key)) {
		die __PACKAGE__."#setCache: arg[1] is a reference. [$key] (第1引数がリファレンスです)\n";
	}
	if(ref($priority)) {
		die __PACKAGE__."#setCache: arg[2] is a reference. (第2引数がリファレンスです)\n";
	}

	$priority = 1500 if(!defined($priority));
	$this->{memcache_charset} = 'Shift_JIS' if(!exists($this->{memcache_charset}) || !defined($this->{memcache_charset}));

	if(exists($this->{memcache_form}) && defined($this->{memcache_form})) {
		$TL->setContentFilter(['Tripletail::Filter::MemCached',$priority],key => $key, mode => 'write', form => $this->{memcache_form},  formcharset => $this->{memcache_charset});
	} else {
		$TL->setContentFilter(['Tripletail::Filter::MemCached',$priority],key => $key, mode => 'write');
	}
}

sub deleteCache {
	my $this = shift;
	my $key = shift;

	if(!defined($key)) {
		die __PACKAGE__."#deleteCache: arg[1] is not defined. (第1引数が指定されていません)\n";
	} elsif(ref($key)) {
		die __PACKAGE__."#deleteCache: arg[1] is a reference. [$key] (第1引数がリファレンスです)\n";
	}

	$TL->newMemCached->delete($key);
}

sub _gensym {
	package Tripletail::Symbol;
	no strict;
	$genpkg = "Tripletail::Symbol::";
	$genseq = 0;

	my $name = "GEN" . $genseq++;
	my $ref = \*{$genpkg . $name};
	delete $$genpkg{$name};

	$ref;
}

sub _getRunMode
{
	my $this = shift;

	if( UNIVERSAL::isa(tied(*STDIN), "FCGI::Stream") )
	{
		# already in fcgi-request.
		return 'FCGI';
	}
	if( defined(fileno(STDIN)) && !defined(getpeername(STDIN)) and $!{ENOTCONN} ) {
		# http://www.fastcgi.com/devkit/doc/fcgi-spec.html#S2.2
		# but win32 says ENOTSOCK.
		return 'FCGI';
	}
	if( $ENV{GATEWAY_INTERFACE} )
	{
		return 'CGI';
	}
	if( $^O eq 'MSWin32' )
	{
		if( !defined($IS_FCGI_WIN32) )
		{
			local($@);
			local $SIG{__DIE__} = 'DEFAULT';
			CORE::eval 'use FCGI';
			if( $@ )
			{
				$IS_FCGI_WIN32 = 0;
				$FCGI_LOADMSG_WIN32 = $@;
			}else
			{
				my $req = FCGI::Request();
				$IS_FCGI_WIN32 = $req->IsFastCGI();
				$FCGI_LOADMSG_WIN32 = $IS_FCGI_WIN32 ? '' : 'No FCGI Enviconment';
			}
		}
		if( $IS_FCGI_WIN32 )
		{
			return 'FCGI';
		}
	}
	'script';
}

sub _decodeFromURL {
	my $this = shift;
	my $url = shift;

	if(@{$this->{inputfilterlist}} == 0) {
		# フィルタが一つも無い時はデコードできない。
		die __PACKAGE__."#_decodeFromURL: we have no input-filters. Set at least one filter. (入力フィルタが1つも指定されていません)\n";
	}

	# フラグメントを除去
	my $fragment;
	if($url =~ s/#(.+)$//) {
		$fragment = $1;
	}

	# 最初に空のTripletail::Formを作り、それを順々にフィルタに通して行く。
	my $form = $this->newForm;
	foreach my $filter (@{$this->{inputfilterlist}}) {
		$filter->decodeURL($form, $url, $fragment);
	}

	($form, $fragment);
}

sub _saveContentFilter {
	my $this = shift;
	
	%{$this->{saved_filter}} = %{$this->{filter}};
	$this->_updateFilterList('filter');
}

sub _restoreContentFilter {
	my $this = shift;

	%{$this->{filter}} = %{$this->{saved_filter}};
	$this->_updateFilterList('filter');

	%{$this->{saved_filter}} = ();
}

sub _updateFilterList {
	my $this = shift;
	my $key = shift;
	my $listkey = $key . 'list';

	@{$this->{$listkey}} =
		map { $this->{$key}{$_} }
			(sort {$a <=> $b} keys %{$this->{$key}});
}

sub __decodeCgi {
	my $this = shift;

	if(@{$this->{inputfilterlist}} == 0) {
		# フィルタが一つも無い時はデコードできない。
		die __PACKAGE__."#__decodeCgi: we have no input-filters. Set at least one filter. (入力フィルタが1つも指定されていません)\n";
	}

	# 最初に空のTripletail::Formを作り、それを順々にフィルタに通して行く。
	my $form = $this->newForm;
	foreach my $filter (@{$this->{inputfilterlist}}) {
		$filter->decodeCgi($form);
	}

	$form;
}

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

	foreach (@{$this->{hooklist}{$type}}) {
		$_->();
	}

	$this;
}

sub __dispError {
	my $this = shift;
	my $err  = shift;

	isa($err, 'Tripletail::Error') or
	  $err = $TL->newError('error' => $err);

	my $errortemplate = $TL->INI->get(TL => 'errortemplate', '');
	my $http_headers;
	my $html;
    if ($this->{printflag} and not $this->{outputbuffering}) {
        $html = "<p>$err</p>";
        $html =~ s!\n!<br />!g;
        my $filter = $this->getContentFilter();
        $http_headers = $filter->{header_flushed} ? '' : $filter->_flush_header();
    }
	elsif (length $errortemplate) {
		my $t = $TL->newTemplate($errortemplate);
		my $errortemplatecharset = $this->INI->get(TL => 'errortemplatecharset', 'UTF-8');
		$html = $TL->charconv($t->toStr, 'UTF-8', $errortemplatecharset);

		my $status = ref($err) && $err->{http_status_line};
		$status ||= '500 Internal Server Error';
		$http_headers  = "Status: $status\r\n";
		$http_headers .= "Content-Type: text/html; charset=$errortemplatecharset\r\n";
		$http_headers .= "\r\n";
	}
    else {
		my $popup = $TL->getDebug->_implant_disperror_popup;
		$html = $err->toHtml;
		$html =~ s|</html>$|$popup</html>|;

		my $status = ref($err) && $err->{http_status_line};
		$status ||= '500 Internal Server Error';
		$http_headers  = "Status: $status\r\n";
		$http_headers .= "Content-Type: text/html; charset=UTF-8\r\n";
		$http_headers .= "\r\n";
	}

	print $http_headers.$html;

	$this->_sendErrorIfNeeded($err);

	my $errorlog = $this->INI->get(TL => 'errorlog', 1);
	if($errorlog > 0) {
		$this->log(__PACKAGE__, "$err");
	}
	if($errorlog > 1) {
		$TL->getDebug->__log_request;
	}
}

sub __executeCgi {
	my $this = shift;
	my $mainfunc = shift;

	$LOG_SERIAL++;
	
	$this->__executeHook('initRequest');
	
	# ここで$CGIを作り、constにする。
	$this->{CGIORIG} = CORE::eval { $this->__decodeCgi->const };
	if ($@) {
		die $@ if not (
			ref($@)
				and
			UNIVERSAL::isa($@, "Tripletail::Error")
				and
			(
				($@->message =~ /we got IO error while reading from stdin/)
					or
				($@->message =~ /we got EOF while reading from stdin/)
			)
		);
		print "Status: 500 Internal Server Error\r\n";
		print "Content-Type: text/plain\r\n\r\nI/O Error\r\n$@";
	}
	else {
		$this->{CGI} = $this->{CGIORIG}->clone;
		if( !$TL->INI->get(TL => 'allow_mutable_input_cgi_object') )
		{
			$this->{CGI}->const();
		}
		$this->{CGI}->_trace();
		our $CGI = $this->{CGI};
		$this->{outputbuff} = '';

		# $CGI の export
		my $callpkg = caller(2);
		{
			no strict "refs";
			*{"$callpkg\::CGI"} = *{"Tripletail::CGI"};
		}

		$this->__executeHook('preRequest');
		$this->_saveContentFilter;

		CORE::eval {
			$mainfunc->();
		};
		if($@) {
			$this->__dispError($@);
		} else {
			$this->__flushContentFilter;
		}
		$this->__resetContentFilter();

		$this->_restoreContentFilter();
		$this->__executeHook('postRequest');
	}

	# $CGIを消す。
	$this->{CGI} = undef;
	$this->{CGIORIG} = undef;
	$this->{outputbuff} = '';
	$this;
}

sub __flushContentFilter {
	my $this = shift;

	delete $this->{printflag};

	my $add_clen;
	if( $this->{outputbuffering} && !$TL->{mod_perl} )
	{
		my $filter = $this->getContentFilter();
		if( !exists($filter->{replacement}{'Content-Length'}) && !exists($filter->{addition}{'Content-Length'}) )
		{
			$add_clen = 1;
		}
	}


	my $str = '';
	foreach my $filter (@{$this->{filterlist}}) {
		$str = $filter->print($str);
		$str .= $filter->flush;
	}
	$str = $this->{outputbuff} . $str;

	if( $add_clen )
	{
		my $body = $str;
		$body =~ s/^.*?(?:\r?\n\r?\n|\r\r)//s;
		my $clen = length($body);
		$str = "Content-Length: $clen\r\n" . $str;
	}

	print $str;
}

sub __resetContentFilter {
	my $this = shift;

	delete $this->{printflag};

	foreach my $filter (@{$this->{filterlist}})
	{
		my $sub = $filter->can('reset');
		if( $sub )
		{
			$filter->$sub();
		}
	}
}

sub _cwd
{
	$CWD ||= Cwd::cwd;
}
sub _clearCwd
{
	$CWD = undef;
}

sub _readcmd
{
	my $this = shift;
	my $cmd = shift;
	my $secure_env = $this->_secure_env();
	local(%ENV) = %$secure_env;
	`$cmd`;
}
sub _secure_env
{
	my $this = shift;
	my $uid = $<;
	my ($username, $home);
	if( $^O ne 'MSWin32' )
	{
		$username = getpwuid($uid);
		$home     = (getpwuid($uid))[7];
	}else
	{
		$username = 'anonymous';
		$home     = 'C:/';
	}
	+{
		LANG => 'C',
		PATH => '/bin:/usr/bin',
		USER => $username,
		HOME => $home,
		SHELL => '/bin/sh',
	};
}


__END__