File Coverage

blib/lib/PAB3/CGI.pm

Criterion	Covered	Total	%
statement	32	351	9.1
branch	8	190	4.2
condition	6	99	6.0
subroutine	9	29	31.0
pod	12	17	70.5
total	67	686	9.7

package PAB3::CGI;
# =============================================================================
# Perl Application Builder
# Module: PAB3::CGI
# Use "perldoc PAB3::CGI" for documenation
# =============================================================================

use vars qw(
	$VERSION %HEAD $FIRSTRUN
	%_GET %_POST %_REQUEST %_COOKIE %_FILES
	$HeaderDone $Logger @CleanupHandler
	$MPartBufferSize $MaxBoundary $UploadFileDir $SaveToFile $RequestMaxData
	$TempDir
);

use Carp ();
use Time::HiRes ();

use strict;
no strict 'refs';

our @EXPORT_VAR = qw(
	%_GET %_POST %_REQUEST %_FILES %_COOKIE
);
our @EXPORT_SUB = qw(
	&header &redirect &setcookie &print_r &print_var
	&encode_uri &decode_uri &encode_uri_component &decode_uri_component
);
our @EXPORT_OK = ( @EXPORT_SUB, @EXPORT_VAR );
our @EXPORT = @EXPORT_VAR; # export variables by default
our %EXPORT_TAGS = (
#	'all' => \@EXPORT_OK,
	'default' => \@EXPORT_OK,
#	'var' => \@EXPORT_VAR,
);
require Exporter;
*import = \&Exporter::import;

BEGIN {
	$VERSION = '2.0.1';
	*print_r = \&print_var;
	$GLOBAL::MPREQ = undef;
	$GLOBAL::MODPERL = 0;
	$GLOBAL::MODPERL = 2 if exists $ENV{'MOD_PERL_API_VERSION'}
		&& $ENV{'MOD_PERL_API_VERSION'} == 2;
	$GLOBAL::MODPERL = 1 if ! $GLOBAL::MODPERL && exists $ENV{'MOD_PERL'}
		&& $Apache::VERSION > 1 && $Apache::VERSION < 1.99;
	if( $GLOBAL::MODPERL == 2 ) {
		require mod_perl2;
		require Apache2::Module;
		require Apache2::ServerUtil;
		require Apache2::RequestUtil;
		require APR::Pool;
		require APR::Table;
		require PAB3::CGI::Request;
	}
	elsif( $GLOBAL::MODPERL == 1 ) {
		require Apache;
		require Apache::Log;
		require PAB3::CGI::Request;
	}
	elsif( exists $ENV{'GATEWAY_INTERFACE'}
		&& $ENV{'GATEWAY_INTERFACE'} eq 'CGI-PerlEx'
	) {
		require PAB3::CGI::Request;
	}
	elsif( exists $ENV{'CONTENT_TYPE'}
		&& index( lc( $ENV{'CONTENT_TYPE'} ), 'multipart/form-data' ) >= 0
	) {
		require PAB3::CGI::Request;
	}
	else {
		require PAB3::CGI::RequestStd;
	}
	if( $^O eq 'MSWin32' ) {
		$TempDir = $ENV{'TEMP'}
			? ( $ENV{'TEMP'} . "\\" )
			# CSIDL_WINDOWS (0x0024)
			: ( &Win32::GetFolderPath( 0x0024 ) . "\\Temp\\" )
		;
	}
	else {
		$TempDir = '/tmp/';
	}
	$FIRSTRUN = 1;
}

END {
	if( ! $GLOBAL::MODPERL ) {
		&cleanup();
	}
}

use PAB3::Output::CGI ();

1;

sub _import {
	my $pkg = shift;
	my $callpkg = caller();
	if( $_[0] and $pkg eq __PACKAGE__ and $_[0] eq 'import' ) {
		*{$callpkg . '::import'} = \&import;
		return;
	}
	# export symbols
	foreach( @_ ) {
		if( $_ eq ':default' ) {
			*{$callpkg . '::' . $_} = \%{$pkg . '::' . $_} foreach @EXPORT_SUB;
		}
	}
	*{$callpkg . '::' . $_} = \%{$pkg . '::' . $_} foreach @EXPORT_VAR;
}

sub cleanup {
	return if $FIRSTRUN;
	if( %_FILES ) {
		foreach( keys %_FILES ) {
			unless( $_FILES{$_}->{'tmp_name'} ) {
				next;
			}
			unlink( split( "\0", $_FILES{$_}->{'tmp_name'} ) );
		}
	}
	undef %_GET;
	undef %_POST;
	undef %_REQUEST;
	undef %_FILES;
	undef %_COOKIE;
	undef $HeaderDone;
	undef %HEAD;
	print ''; # untie stdout
	$FIRSTRUN = 1;
	my( $handler, $h, $ref );
	foreach $h( @CleanupHandler ) {
		if( ref( $h ) eq 'ARRAY' ) {
			$handler = shift @$h;
		}
		else {
			$handler = $h;
			$h = [];
		}
		if( ( $ref = ref( $handler ) ) ) {
			if( $ref eq 'CODE' ) {
				eval{
					local( $SIG{'__DIE__'}, $SIG{'__WARN__'} );
					$handler->( @$h );
				};
			}
		}
		else {
			eval{
				local( $SIG{'__DIE__'}, $SIG{'__WARN__'} );
				&{$handler}( @$h );
			};
		}
	}
	undef @CleanupHandler;
	if( $PAB3::Statistic::VERSION ) {
		&PAB3::Statistic::send(
			'CSN|' . ( $GLOBAL::MPREQ || $$ )
				. '|' . time
				. '|' . µtime()
				. '|' . ( $GLOBAL::STATUS || ( $GLOBAL::MPREQ ? $GLOBAL::MPREQ->status : 200 ) )
		);
	}
	undef $GLOBAL::MPREQ;
}

sub cleanup_register {
	push @CleanupHandler, [ @_ ];
}

sub setenv {
	if( $ENV{'SCRIPT_FILENAME'}
		&& $ENV{'SCRIPT_FILENAME'} =~ /^(.+[\\\/])(.+?)$/
	) {
		$ENV{'SCRIPT_PATH'} = $1;
		$ENV{'SCRIPT'} = $2;
	}
	elsif( $0 =~ /^(.+[\\\/])(.+?)$/ ) {
		$ENV{'SCRIPT_PATH'} = $1;
		$ENV{'SCRIPT'} = $2;
	}
	else {
		$ENV{'SCRIPT_PATH'} = '';
		$ENV{'SCRIPT'} = $0;
	}
	my $hua = lc( $ENV{'HTTP_USER_AGENT'} );
	if( index( $hua, 'win' ) >= 0 ) {
		$ENV{'REMOTE_OS'} = 'windows'
	}
	elsif( index( $hua, 'linux' ) >= 0 ) {
		$ENV{'REMOTE_OS'} = 'linux';
	}
	elsif( index( $hua, 'ppc' ) >= 0 ) {
		$ENV{'REMOTE_OS'} = 'macos';
	}
	elsif( index( $hua, 'freebsd' ) >= 0 ) {
		$ENV{'REMOTE_OS'} = 'freebsd';
	}
	else {
		$ENV{'REMOTE_OS'} = 'unknown';
	}
}

sub set {
	my( $index, $len );
	$len = $#_ + 1;
	for( $index = 0; $index < $len; $index += 2 ) {
		if( $_[ $index ] eq 'request_max_size' ) {
			$RequestMaxData = $_[ $index + 1 ];
		}
		elsif( $_[ $index ] eq 'mpart_buffer_size' ) {
			$MPartBufferSize = $_[ $index + 1 ];
		}
		elsif( $_[ $index ] eq 'max_boundary' ) {
			$MaxBoundary = $_[ $index + 1 ];
		}
		elsif( $_[ $index ] eq 'temp_dir' ) {
			$UploadFileDir = $_[ $index + 1 ];
		}
		elsif( $_[ $index ] eq 'save_to_file' ) {
			$SaveToFile = $_[ $index + 1 ];
		}
		elsif( $_[ $index ] eq 'logger' ) {
			$Logger = $_[ $index + 1 ];
		}
		elsif( $_[ $index ] eq 'request' ) {
			$GLOBAL::MPREQ = $_[ $index + 1 ];
		}
		else {
#			&Carp::carp( 'Unknown parameter ' . $_[ $index ] );
		}
	}
}

sub init {
	&cleanup() if ! $FIRSTRUN;
	$UploadFileDir = $TempDir;
	$RequestMaxData = 131072;
	$MPartBufferSize = 8192;
	$MaxBoundary = 10;
	$SaveToFile = 1;
	$Logger = undef;
	$GLOBAL::MPREQ = undef;
	&set( @_ );
	if( $FIRSTRUN ) {
		$FIRSTRUN = 0;
		if( $GLOBAL::MODPERL ) {
			if( $GLOBAL::MODPERL == 2 ) {
				$GLOBAL::MPREQ ||= Apache2::RequestUtil->request();
				$GLOBAL::MPREQ->pool->cleanup_register( \&cleanup );
				if( $GLOBAL::MPREQ->handler() eq 'modperl' ) {
					tie *STDIN, $GLOBAL::MPREQ;
				}
			}
			elsif( $GLOBAL::MODPERL == 1 ) {
				$GLOBAL::MPREQ ||= Apache->request();
				$GLOBAL::MPREQ->register_cleanup( \&cleanup );
			}
			if( $PAB3::Statistic::VERSION ) {
				my $r = $GLOBAL::MPREQ;
				my $s = $r->server();
				my $s2 = $GLOBAL::MODPERL == 2
					? Apache2::ServerUtil->server()
					: $r->server()
				;
				my $c = $r->connection();
				&PAB3::Statistic::send(
					'ISN|' . $r
						. '|' . time
						. '|' . µtime()
						. '|' . $s->server_hostname
						. '|' . ( $s->port || $s2->port )
						. '|' . $s->is_virtual
						. '|' . $r->document_root
						. '|' . $r->uri
						. '|' . ( $c->remote_host || $c->remote_ip )
						. '|' . $GLOBAL::MODPERL
				);
			}
		}
		else {
			my $iru = index( $ENV{'REQUEST_URI'}, '?' );
			if( $PAB3::Statistic::VERSION ) {
				&PAB3::Statistic::send(
					'ISN|' . $$
						. '|' . time
						. '|' . µtime()
						. '|' . $ENV{'SERVER_NAME'}
						. '|' . $ENV{'SERVER_PORT'}
						. '|' . '2'
						. '|' . $ENV{'DOCUMENT_ROOT'}
						. '|' . ( $iru > 0 ? substr( $ENV{'REQUEST_URI'}, 0, $iru ) : $ENV{'REQUEST_URI'} )
						. '|' . $ENV{'REMOTE_ADDR'}
						. '|' . '0'
				);
			}
		}
		%HEAD = ();
		$HeaderDone = 0;
		tie *STDOUT, 'PAB3::Output::CGI';
		$SIG{'__DIE__'} = \&_die_handler;
		$SIG{'__WARN__'} = \&_warn_handler;
		&_parse_cookie();
		&_parse_request();
	}
	return 1;
}

sub setcookie {
	my( $name, $value, $expire, $path, $domain, $secure ) = @_;
	unless( $name ) {
		&Carp::croak(
			'Usage: setcookie( $name [, $value [, $expire [, $path [, $domain'
			. ' [, $secure ]]]]] )'
		);
	}
	if( $HeaderDone ) {
		&Carp::carp(
			'CGI Headers already sent at '
				. $HeaderDone->[1] . ':' . $HeaderDone->[2]
		);
		return 0;
	}
	if( $domain ) {
		my $suffix = substr( $domain, rindex( $domain, '.' ) + 1 );
		my $len = length( $suffix );
		if( $suffix !~ /\d{$len}|com|net|org/i && $domain !~ /^\./ ) {
			$domain = '.' . $domain;
		}
	}
	if( defined $expire && $expire > 0 ) {
		my @t = split( / +/, gmtime( $expire ) );
		push @t, split( /:/, $t[3] );
		$expire = $t[0] . ', ' . $t[2] . '-' . $t[1] . '-' .
			$t[4] . ' ' . $t[5] . ':' . $t[6] . ':' . $t[7] .
			' GMT';
	}
	if( $value ) {
		$value =~ s/([^0-9A-z]{1})/"%".unpack("H2",$1)/ge;
	}
	$name =~ s/([^0-9A-z]{1})/"%".unpack("H2",$1)/ge;
	&header(
		'Set-Cookie: ' . $name . '='
		. ( defined $value ? '"' . $value . '";' : ';' )
		. ( defined $expire ? ' Expires="' . $expire . '";' : '' )
		. ( $domain ? ' Domain="' . $domain . '";' : '' )
		. ( $path ? ' Path="' . $path . '";' : '' )
		. ( $secure ? ' Secure="1";' : '' )
		. ' Version="1";'
		. "\n\r"
	) or return 0;
	return 1;
}

sub redirect {
	my( $location, $params, $internal ) = @_;
	if( ! $location ) {
		&Carp::croak(
			'Usage: &PAB3::CGI::redirect( $location [, \%params [, $internal ] ] )'
		);
	}
	if( defined $params && ref( $params ) eq 'HASH' ) {
		my( $index );
		if( $location && index( $location, '?' ) >= 0 ) {
			$location .= '&';
			$index = 1;
		}
		else {
			$location .= '?';
			$index = 0;
		}
		foreach( keys %$params ) {
			$location .= '&' if $index ++ > 0;
			$location .= $_ . '=' . &encode_uri_component( $params->{$_} );
		}
	}
	&header( 'Status: 302 Moved' );
	&header(
		$internal && $GLOBAL::MPREQ
			? 'intredir: ' . $location
			: 'Location: ' . $location
	);
	print '';
	return 302;
}

sub header {
	# my( $header, $replace ) = @_;
	my( $key, $val, $k );
	if( $HeaderDone ) {
		&Carp::carp(
			'CGI Headers already sent at '
				. $HeaderDone->[1] . ':' . $HeaderDone->[2]
		);
	}
	if( $_[0] =~ m!^HTTP/\d+\.\d+\s+(\d+\s*.*)!i ) {
		&header( "Status: $1", $_[1] );
	}
	( $key, $val ) = $_[0] =~ m!^\s*([\w\-\_]+)\s*?\:\s*(.+)! or return;
	$k = lc( $key );
	if( ! defined $_[1] || $_[1] || ! defined $HEAD{$k} ) {
		$HEAD{$k} = $val;
	}
	elsif( defined $HEAD{$k} ) {
		$HEAD{$k} = [ $HEAD{$k} ] if ! ref( $HEAD{$k} );
		push @{ $HEAD{$k} }, $val;
	}
}

sub print_hash {
	my( $hashname, $ref_table, $level ) = @_;
	my( $r_hash, $r, $k );
	$ref_table ||= [];
	if( $hashname =~ /HASH\(0x\w+\)/ ) {
		$r_hash = $hashname;
	}
	else {
		return;
	}
	print $r_hash;
	if( $ref_table->{$r_hash} && $ref_table->{$r_hash} <= $level ) {
		print " [recursive loop]\n";
		return;
	}
	print "\n", "    " x $level, "(\n";
	$ref_table->{$r_hash} = $level + 1;
	foreach $k( sort { lc( $a ) cmp lc( $b ) } keys %{ $r_hash } ) {
		print "    " x ( $level + 1 ) . "[$k] => ";
		$r = ref( $r_hash->{$k} );
		if( $r && index( $r_hash->{$k}, 'ARRAY(' ) >= 0 ) {
			&print_array( $r_hash->{$k}, $ref_table, $level + 1 );
		}
		elsif( $r && index( $r_hash->{$k}, 'HASH(' ) >= 0 ) {
			&print_hash( $r_hash->{$k}, $ref_table, $level + 1 );
		}
		else {
			print ( ! defined $r_hash->{$k} ? '(null)' : $r_hash->{ $k } );
			print "\n";
		}
	}
	print "    " x $level, ")\n";
}

sub print_array {
	my( $arrayname, $ref_table, $level ) = @_;
	my( $r_array, $r, $v, $i );
	$ref_table ||= {};
	$level ||= 0;
	if( $arrayname =~ /ARRAY\(0x\w+\)/ ) {
		$r_array = $arrayname;
	}
	else {
		return;
	}
	print $r_array;
	if( $ref_table->{$r_array} && $ref_table->{$r_array} <= $level ) {
		print " [recursive loop]\n";
		return;
	}
	print "\n", "    " x $level, "(\n";
	$ref_table->{$r_array} = $level + 1;
	$i = 0;
	foreach $v( @{ $r_array } ) {
		$r = ref( $v );
		print "    " x ( $level + 1 ) . "[$i] => ";
		if( $r && index( $v, 'ARRAY(' ) >= 0 ) {
			&print_array( $v, $ref_table, $level + 1 );
		}
		elsif( $r && index( $v, 'HASH(' ) >= 0 ) {
			&print_hash( $v, $ref_table, $level + 1 );
		}
		else {
			print "" . ( ! defined $v ? '(null)' : $v ) . "\n";
		}
		$i ++;
	}
	print "    " x $level, ")\n";
}

sub print_var {
	my( $v, $r, $ref_table );
	$ref_table = {};
	print "\n";
	foreach $v( @_ ) {
		$r = ref( $v );
		if( $r && index( $v, 'ARRAY(' ) >= 0 ) {
			&print_array( $v, $ref_table, 0 );
		}
		elsif( $r && index( $v, 'HASH(' ) >= 0 ) {
			&print_hash( $v, $ref_table, 0 );
		}
		elsif( $r && index( $v, 'SCALAR(' ) >= 0 ) {
			print $$v, "\n";
		}
		else {
			print $v, "\n";
		}
	}
	print "\n";
}

sub print_code {
	my( $content, $filename ) = @_;
	my( $t, $l, $p );
	return if ! defined $content;
	$content =~ s/\r//go;
	$content =~ s/
	$content =~ s/>/>/go;
	#$content =~ s/ / /go;
	print "\n"; \n" if $filename; \n"; 




513




0




  
  0
  




 





 





 





 



 	print "$filename




514




0





 





 





 





 





 



 	print "\n"; 




515




0





 





 





 





 





 



 	$p = 1; 




516




0





 





 





 





 





 



 	foreach $l( split( /\n/, $content ) ) { 




517




0





 





 





 





 





 



 		print $p . "\t" . $l . "\n"; 




518




0





 





 





 





 





 



 		$p ++; 




519




 





 





 





 





 





 



 	} 




520




0





 





 





 





 





 



 	print "




521




0





 





 





 





 





 



 	print "\n";
	print "
	print "
	$p = 1;
	foreach $l( split( /\n/, $content ) ) {
		print $p . "\t" . $l . "\n";
		$p ++;
	}
	print "
	print "
}

sub encode_uri($) {
	my $s = $_[0] or return $_[0];
	$s =~ s/([^A-Za-z0-9\-_.!~*\'()\,\/\?\:\@\&\=\+\$]{1})/sprintf('%%%02X',ord($1))/ge;
	return $s;
}

sub decode_uri($) {
	my $s = $_[0] or return $_[0];
	$s =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/ge;
	return $s;
}

sub encode_uri_component($) {
	my $s = $_[0] or return $_[0];
	$s =~ s/([^A-Za-z0-9\-_.!~*\'()]{1})/sprintf('%%%02X',ord($1))/ge;
	return $s;
}

sub decode_uri_component($) {
	my $s = $_[0] or return $_[0];
	$s =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/ge;
	return $s;
}

sub microtime {
	my( $sec, $usec ) = &Time::HiRes::gettimeofday();
	return $sec + $usec / 1000000;
}

sub _parse_cookie {
	my( $key, $val, $i, @in, $iv );
	%_COOKIE = ();
	return 1 unless defined $ENV{'HTTP_COOKIE'};
	@in = split( /; */, $ENV{'HTTP_COOKIE'} );
	for $i( 0 .. $#in ) {
		$iv = index( $in[$i], '=' );
		if( $iv > 0 ) {
			$key = substr( $in[$i], 0, $iv );
			$val = substr( $in[$i], $iv + 1 );
			$key =~ tr/+/ /;
			$key =~ s/%([A-Fa-f0-9]{2})/chr(hex($1))/ge;
			if( $val ) {
				$val =~ s!\"!!gso;
				#$val =~ s/^\"(.+)\"$/$1/;
				$val =~ tr/+/ /;
				$val =~ s/%([A-Fa-f0-9]{2})/chr(hex($1))/ge;
			}
			$_COOKIE{ $key } = defined $_COOKIE{ $key } ? "\0" . $val : $val;
		}
		else {
			$_COOKIE{ $in[$i] } .= defined $_COOKIE{ $in[$i] } ? "\0" : "";
		}
	}
	return 1;
}

sub _die_handler {
	my $str = shift;
	my( @c, $step );
	if( $str =~ /(.+) at (.+) line (.+)$/s ) {
		print "\nFatal:\n"
			. "$1\n"
			. 'at ' . $2 . ' line ' . $3 . ''
			. "\n"
		;
	}
	else {
		print "\nFatal:\n"
			. '' . $str . "\n"
		;
	}
	@c = caller();
	print "\n";
	print ''
		. '' . $c[0] . ' raised the exception'
		. ' at '	. $c[1] . ' line ' . $c[2] . ''
		. "\n"
	;
	$step = 1;
	while( @c = caller( $step ) ) {
		print ''
			. '' . $c[0] . ' called ' . $c[3] . ''
			. ' at ' . $c[1] . ' line ' . $c[2] . ''
			. "\n"
		;
		$step ++;
	}
	print "\n";
	print "\n";
	my $s = $str;
	$s =~ s!\n+$!!;
	if( $Logger ) {
		$Logger->error( $s );
	}
	if( $GLOBAL::MPREQ ) {
		$GLOBAL::MPREQ->log()->error( $s );
		#$GLOBAL::MPREQ->status( 500 );
		$GLOBAL::STATUS = 500;
		Apache::exit() if $GLOBAL::MODPERL == 1;
	}
	else {
		print STDERR '[error] Perl: ' . $str;
	}
#	return 500;
	exit( 0 );
}

sub _warn_handler {
	my $str = shift;
	if( $str =~ /(.+) at (.+) line (.+)$/s ) {
		print "\nWarning: $1\n"
			. 'at ' . $2 . ' line ' . $3 . ''
			. "\n\n"
		;
	}
	else {
		print "\nWarning: $str\n\n";
	}
	my $s = $str;
	$s =~ s!\n+$!!;
	if( $Logger ) {
		$Logger->warn( $s );
	}
	if( $GLOBAL::MPREQ ) {
		$GLOBAL::MPREQ->log()->warn( $s );
	}
	else {
		print STDERR '[warn] Perl: ' . $str;
	}
}


__END__