package IMPL::Web::Application;
use strict;
use warnings;

use CGI;
use Carp qw(carp);
use IMPL::Const qw(:prop);

use IMPL::declare {
	require => {
		TAction                   => 'IMPL::Web::Application::Action',
		HttpResponse              => 'IMPL::Web::HttpResponse',
		TFactory                  => '-IMPL::Object::Factory',
		Exception                 => 'IMPL::Exception',
		InvalidOperationException => '-IMPL::InvalidOperationException',
		Loader                    => 'IMPL::Code::Loader'
	  },
	  base => [
		'IMPL::Config'            => '@_',
		'IMPL::Object::Singleton' => '@_'
	  ],
	  props => [
		actionFactory      => PROP_RW,
		handlers           => PROP_RW | PROP_LIST,
		security           => PROP_RW,
		options            => PROP_RW,
		fetchRequestMethod => PROP_RW,
		output             => PROP_RW
	  ]
};

sub CTOR {
	my ($this) = @_;

	die IMPL::InvalidArgumentException->new( "handlers",
		"At least one handler should be supplied" )
	  unless $this->handlers->Count;

	$this->actionFactory(TAction) unless $this->actionFactory;
	$this->fetchRequestMethod( \&defaultFetchRequest )
	  unless $this->fetchRequestMethod;
}

sub Run {
	my ($this) = @_;

	my $handler;

	$handler = _ChainHandler( $_, $handler ) foreach $this->handlers;

	while ( my $query = $this->FetchRequest() ) {

		my $action = $this->actionFactory->new(
			query       => $query,
			application => $this,
		);

		eval {
			my $result = $handler->($action);

			die InvalidOperationException->new(
"Invalid handlers result. A reference to IMPL::Web::HttpResponse is expexted."
			) unless eval { $result->isa(HttpResponse) };

			$result->PrintResponse( $this->output );
		};
		if ($@) {
			my $e = $@;

			HttpResponse->InternalError(
				type    => 'text/plain',
				charset => 'utf-8',
				body    => $e
			)->PrintResponse( $this->output );

		}
	}
}

sub _ChainHandler {
	my ( $handler, $next ) = @_;

	if ( ref $handler eq 'CODE' ) {
		return sub {
			my ($action) = @_;
			return $handler->( $action, $next );
		};
	}
	elsif ( eval { $handler->can('Invoke') } ) {
		return sub {
			my ($action) = @_;
			return $handler->Invoke( $action, $next );
		};
	}
	elsif ( eval { $handler->isa(TFactory) } ) {
		return sub {
			my ($action) = @_;
			my $inst = $handler->new();
			return $inst->Invoke( $action, $next );
		  }
	}
	elsif ( $handler
		and not ref $handler
		and $handler =~ m/^(-)?(\w+(?:::\w+)*)$/ )
	{
		my $class = $2;
		if ( not $1 ) {
			Loader->safe->Require($class);
			die IMPL::InvalidArgumentException->(
				"An invalid handler supplied", $handler
			) unless $class->can('Invoke');
		}

		return sub {
			my ($action) = @_;
			my $inst = $class->new();
			return $inst->Invoke( $action, $next );
		};
	}
	else {
		die new IMPL::InvalidArgumentException( "An invalid handler supplied",
			$handler );
	}
}

sub FetchRequest {
	my ($this) = @_;

	if ( ref $this->fetchRequestMethod eq 'CODE' ) {
		return $this->fetchRequestMethod->($this);
	}
	else {
		die new IMPL::Exception(
			"Unknown fetchRequestMethod type",
			ref $this->fetchRequestMethod
		);
	}
}

{
	my $hasFetched = 0;

	sub defaultFetchRequest {
		my ($this) = @_;
		return undef if $hasFetched;
		$hasFetched = 1;
		$this->output(*STDOUT);
		my $query = CGIWrapper->new();
		return $query;
	}
}

sub defaultErrorHandler {
	my ( $this, $action, $e ) = @_;
	warn $e;
	if ( eval { $action->ReinitResponse(); 1; } ) {
		$action->response->contentType('text/plain');
		$action->response->charset( $this->responseCharset );
		$action->response->status(500);
		my $hout = $action->response->streamBody;
		print $hout $e;
		$action->response->Complete();
	}
}

package CGIWrapper;
use parent qw(CGI);

use Encode;

our $NO_DECODE = 0;

sub param {
	my $this = shift;

	return $this->SUPER::param(@_) if $NO_DECODE;

	if (wantarray) {
		my @result = $this->SUPER::param(@_);

		return map Encode::is_utf8($_)
		  ? $_
		  : Encode::decode( $this->charset, $_, Encode::LEAVE_SRC ), @result;
	}
	else {
		my $result = $this->SUPER::param(@_);

		return Encode::is_utf8($result)
		  ? $result
		  : Encode::decode( $this->charset, $result, Encode::LEAVE_SRC );
	}

}

sub upload {
	my $this = shift;

	local $NO_DECODE = 1;
	my $oldCharset = $this->charset();
	$this->charset('ISO-8859-1');

	my $fh = $this->SUPER::upload(@_);

	$this->charset($oldCharset);
	return $fh;
}

1;

__END__

=pod

=head1 NAME

C<IMPL::Web::Application> Класс для создания экземпляров приложения

=head1 SYNOPSIS

=begin code

use IMPL::require {
	App => 'IMPL::Web::Application' 
};

my $instance = App->spawn(); # will use ./IMPL/Web/Application.xml as configuration

$instance->Run;

=end code

=head1 DESCRIPTION

Создает экземпляр объекта, который получает и обрабатывает C<HTTP> запрос.
Приложение можно загрузить из C<xml> файла в котором описано состояние свойств,
для этого используется механизм C<IMPL::Serialization>.

Приложение представлет собой модульную конструкцию, которая состоит из цепочки
обработчиков. Цепочка обработчиков вызывается снизу вверх, при этом каждый
обработчик самостоятельно рекурсивно вызывает следующий (более высокого уровня).

=cut