PSGI_CGI.pm

package PSGI_CGI;

sub make_psgi_env($$$$){
	my($schema,$CGI_ENV,$stdin,$stderr)=@_;
	$env = { 
		# コマンドラインから実行した場合には存在しないがPSGI的にMUSTな情報
		REQUEST_METHOD => 'GET'
		,SCRIPT_NAME => ''
		,PATH_INFO =>''
		,REQUEST_URI =>''
		,QUERY_STRING =>''
		,SERVER_NAME =>'?'
		,SERVER_PORT =>'80'
		,SERVER_PROTOCOL =>"HTTP/1.1"
		# 実際の環境変数
		,%$CGI_ENV
		# PSGI固有の情報
		,'psgi.version' => [1,1]
		,'psgi.multithread' => 0
		,'psgi.multiprocess' => 0
		,'psgi.run_once' => 1
		,'psgi.nonblocking' => 0
		,'psgi.streaming' => 0
		,'psgi.url_scheme' => $schema
		,'psgi.input' => $stdin
		,'psgi.errors' => $stderr
	};
	#
	return $env;
}

sub write_response($$){
	my($psgi_res,$stdout)=@_;
	my $crlf = "\x0d\x0a";

	# write message header
	$stdout->print( "Status: ",$psgi_res->[0], $crlf );

	my $headers = $psgi_res->[1];
	if( $headers ){
		for(my $i=0;$i<@$headers;$i+=2){
			$stdout->print( $headers->[$i],": ",$headers->[$i+1],$crlf );
		}
	}
	$stdout->print( $crlf);
	
	# write message body
	if( defined $psgi_res->[2] ){
		my $err;
		my $done;
		{
			local $@;
			eval {
				# 1要素を出力する関数
				my $cb = sub{
					return 0 if not defined $_[0];
					if( $_[0] =~ /[^\x00-\xff]/ ){
						my $buf = $_[0];
						utf8::encode($buf);
						$stdout->print( $buf);
					}else{
						$stdout->print( $_[0]);
					}
				};
				# body引数の種別に合わせて処理する
				if( ref $psgi_res->[2] eq 'ARRAY' ){
					for my $line (@{$psgi_res->[2]}) {
						$cb->($line) if length $line;
					}
				} else {
					local $/ = \65536 unless ref $/;
					while (defined(my $line = $psgi_res->[2]->getline)) {
						$cb->($line) if length $line;
					}
					$body->close;
				}
				#
				$done = 1;
			};
			$err = $@;
		};
		unless ($done) {
			if ($err =~ /^failed to send all data\n/) {
				return;
			} else {
				die $err;
			}
		}
	}
}

1;
__END__

使用例。

あのサーバだと特定の環境変数の有無でhttpとhttpsを判別できるようだ
my $scheme = ((exists $ENV{HTTP_X_SAKURA_FORWARDED_FOR}) ? 'https':'http');
my $env = $debug_env = PSGI_CGI::make_psgi_env($scheme,%ENV,*STDIN,*STDERR);
my $res = $app->( $env );
PSGI_CGI::write_response( $res, *STDOUT );