File Coverage

blib/lib/NetSDS/App/FCGI.pm

Criterion	Covered	Total	%
statement	12	12	100.0
branch			n/a
condition			n/a
subroutine	4	4	100.0
pod			n/a
total	16	16	100.0

#===============================================================================
#
#         FILE:  FCGI.pm
#
#  DESCRIPTION:  Common FastCGI applications framework
#
#        NOTES:  This fr
#       AUTHOR:  Michael Bochkaryov (Rattler),
#      COMPANY:  Net.Style
#      CREATED:  15.07.2008 16:54:45 EEST
#===============================================================================

=head1 NAME

NetSDS::App::FCGI - FastCGI applications superclass

=head1 SYNOPSIS

	# Run application
	MyFCGI->run();

	1;

	# Application package itself
	package MyFCGI;

	use base 'NetSDS::App::FCGI';

	sub process {
		my ($self) = @_;

		$self->data('Hello World');
		$self->mime('text/plain');
		$self->charset('utf-8');

	}


=head1 DESCRIPTION

C module contains superclass for FastCGI applications.
This class is based on C module and inherits all its functionality
like logging, configuration processing, etc.

=cut

package NetSDS::App::FCGI;

use 5.8.0;
use strict;
use warnings;

use base 'NetSDS::App';

use CGI::Fast;
use CGI::Cookie;

use version; our $VERSION = '1.301';

#***********************************************************************

=head1 CLASS API

=over

=item B - class constructor

Normally constructor of application framework shouldn't be invoked directly.

=cut

#-----------------------------------------------------------------------

sub new {

	my ( $class, %params ) = @_;

	my $self = $class->SUPER::new(
		cgi      => undef,
		mime     => undef,
		charset  => undef,
		data     => undef,
		redirect => undef,
		cookie   => undef,
		status   => undef,
		headers  => {},
		%params,
	);

	return $self;

}

#***********************************************************************

=item B - accessor to CGI.pm request handler

	my $https_header = $self->cgi->https('X-Some-Header');

=cut

#-----------------------------------------------------------------------

__PACKAGE__->mk_accessors('cgi');

#***********************************************************************

=item B - set response HTTP status

Paramters: new status to set

Returns: response status value

	$self->status('200 OK');

=cut

#-----------------------------------------------------------------------

__PACKAGE__->mk_accessors('status');

#***********************************************************************

=item B - set response MIME type

Paramters: new MIME type for response

	$self->mime('text/xml'); # output will be XML data

=cut

#-----------------------------------------------------------------------

__PACKAGE__->mk_accessors('mime');

#***********************************************************************

=item B - set response character set if necessary

	$self->mime('text/plain');
	$self->charset('koi8-r'); # ouput as KOI8-R text

=cut

#-----------------------------------------------------------------------

__PACKAGE__->mk_accessors('charset');

#***********************************************************************

=item B - set response data

Paramters: new data "as is"

	$self->mime('text/plain');
	$self->data('Hello world!');

=cut

#-----------------------------------------------------------------------

__PACKAGE__->mk_accessors('data');

#***********************************************************************

=item B - send HTTP redirect

Paramters: new URL (relative or absolute)

This method send reponse with 302 status and new location.

	if (havent_data()) {
		$self->redirect('http://www.google.com'); # to google!
	};

=cut

#-----------------------------------------------------------------------

__PACKAGE__->mk_accessors('redirect');

#***********************************************************************

=item B -

Paramters:

Returns:

This method provides.....

=cut

#-----------------------------------------------------------------------

__PACKAGE__->mk_accessors('cookie');

#***********************************************************************

=item B - set/get response HTTP headers

Paramters: new headers as hash reference

	$self->headers({
		'X-Beer' => 'Guiness',
	);

=cut

#-----------------------------------------------------------------------

__PACKAGE__->mk_accessors('headers');

#***********************************************************************

=item B - main FastCGI loop

Paramters: none

This method implements common FastCGI (or CGI) loop.

=cut

#-----------------------------------------------------------------------

sub main_loop {

	my ($self) = @_;

	$self->start();

	$SIG{TERM} = undef;
	$SIG{INT}  = undef;

	# Switch of verbosity
	$self->{verbose} = undef;

	# Enter FastCGI loop
	while ( $self->cgi( CGI::Fast->new() ) ) {

		# Retrieve request cookies
		$self->_set_req_cookies();

		# Set default response parameters
		$self->mime('text/plain');    # plain text output
		$self->charset('utf-8');      # UTF-8 charset
		$self->data('');              # empty string response
		$self->status("200 OK");      # everything OK
		$self->cookie( [] );          # no cookies
		$self->redirect(undef);       # no redirects

		# Call request processing method
		$self->process();

		# Send 302 and Location: header if redirect
		if ( $self->redirect ) {
			print $self->cgi->header(
				-cookie    => $self->cookie,
				-status    => '302 Moved',
				'Location' => $self->redirect
			);

		} else {

			# Implement generic content output
			use bytes;
			print $self->cgi->header(
				-type           => $self->mime,
				-status         => $self->status,
				-charset        => $self->charset,
				-cookie         => $self->cookie,
				-Content_length => bytes::length( $self->data ),
				%{ $self->headers },
			);
			no bytes;

			# Send return data to client
			if ( $self->data ) {
				$| = 1;    # set autoflushing mode to avoid output buffering
				binmode STDOUT;
				print $self->data;
			}
		} ## end else [ if ( $self->redirect )

	} ## end while ( $self->cgi( CGI::Fast...

	# Call finalization hooks
	$self->stop();

} ## end sub main_loop

#***********************************************************************

=item B - set cookie

Paramters: hash (name, value, expires)

	$self->set_cookie(name => 'sessid', value => '343q5642653476', expires => '+1h');

=cut

#-----------------------------------------------------------------------

sub set_cookie {

	my ( $self, %par ) = @_;

	push @{ $self->{cookie} }, $self->cgi->cookie( -name => $par{name}, -value => $par{value}, -expires => $par{expires} );

}

#***********************************************************************

=item B - get cookie by name

Paramters: cookie name

Returns cookie value by it's name

	my $sess = $self->get_cookie('sessid');

=cut

#-----------------------------------------------------------------------

sub get_cookie {

	my ( $self, $name ) = @_;

	return $self->{req_cookies}->{$name}->{value};

}

#***********************************************************************

=item B - CGI request parameter

Paramters: CGI parameter name

Returns: CGI parameter value

This method returns CGI parameter value by it's name.

	my $cost = $self->param('cost');

=cut

#-----------------------------------------------------------------------

sub param {
	my ( $self, @par ) = @_;
	return $self->cgi->param(@par);
}

#***********************************************************************

=item B - CGI request parameter

Paramters: URL parameter name

Returns: URL parameter value

This method works similar to B method, but returns only parameters
from the query string.

	my $action = $self->url_param('a');

=cut

#-----------------------------------------------------------------------

sub url_param {
	my ( $self, @par ) = @_;
	return $self->cgi->url_param(@par);
}

#***********************************************************************

=item B - request HTTP header

Paramters: request header name

Returns: header value

This method returns HTTP request header value by name.

	my $beer = $self->http('X-Beer');

=cut

#-----------------------------------------------------------------------

sub http {

	my $self = shift;
	my $par  = shift;

	return $self->cgi->http($par);
}

#***********************************************************************

=item B - request HTTPS header

This method returns HTTPS request header value by name and is almost
the same as http() method except of it works with SSL requests.

	my $beer = $self->https('X-Beer');

=cut

#-----------------------------------------------------------------------

sub https {

	my $self = shift;
	my $par  = shift;

	return $self->cgi->https($par);
}

#***********************************************************************

=item B - get raw cookie data

Just proxying C method from CGI.pm

=cut

#-----------------------------------------------------------------------

sub raw_cookie {
	my ($self) = @_;

	return $self->cgi->raw_cookie;
}

#**************************************************************************

=item B - User-Agent request header

	my $ua_info = $self->user_agent();

=cut

#-----------------------------------------------------------------------
sub user_agent {
	my ($self) = @_;

	return $self->cgi->user_agent;
}

#***********************************************************************

=item B - HTTP request method

	if ($self->request_method eq 'POST') {
		$self->log("info", "Something POST'ed from client");
	}

=cut

#-----------------------------------------------------------------------

sub request_method {
	my ($self) = @_;

	return $self->cgi->request_method;
}

#***********************************************************************

=item B - CGI script name

Returns: script name from CGI.pm

=cut

#-----------------------------------------------------------------------

sub script_name {

	my ($self) = @_;

	return $self->cgi->script_name();
}

#***********************************************************************

=item B - get PATH_INFO value

	if ($self->path_info eq '/help') {
		$self->data('Help yourself');
	}

=cut

#-----------------------------------------------------------------------

sub path_info {

	my ($self) = @_;

	return $self->cgi->path_info();
}

#***********************************************************************

=item B - remote (client) host name

	warn "Client from: " . $self->remote_host();

=cut

#-----------------------------------------------------------------------

sub remote_host {

	my ($self) = @_;

	return $self->cgi->remote_host();

}

#***********************************************************************

=item B - remote (client) IP address

Returns: IP address of client from REMOTE_ADDR environment

	if ($self->remote_addr eq '10.0.0.1') {
		$self->data('Welcome people from our gateway!');
	}

=cut

#-----------------------------------------------------------------------

sub remote_addr {

	my ($self) = @_;

	return $ENV{REMOTE_ADDR};
}

#***********************************************************************

=item B<_set_req_cookies()> - fetching request cookies (internal method)

Fetching cookies from HTTP request to object C variable.

=cut

#-----------------------------------------------------------------------

sub _set_req_cookies {
	my ($self) = @_;

	my %cookies = CGI::Cookie->fetch();
	$self->{req_cookies} = \%cookies;

	return 1;
}

1;

__END__