Mercurial > pub > Impl

use strict;
package IMPL::Web::HttpResponse;

use CGI();
use IMPL::lang qw(:declare :hash);
use IMPL::declare {
	require => {
		Exception => 'IMPL::Exception',
		ArgumentException => '-IMPL::InvalidArgumentException'
	},
	base => [
		'IMPL::Object' => undef,
		'IMPL::Object::Autofill' => '@_'
	],
	props => [
	   status => PROP_ALL,
	   type => PROP_ALL,
	   charset => PROP_ALL,
	   cookies => PROP_ALL,
	   headers => PROP_ALL,
	   body => PROP_ALL
	]
};

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

	$this->headers({}) unless $this->headers();
	$this->cookies({}) unless $this->cookies();
}

sub PrintResponse {
	my ($this,$out) = @_;

	my $q = CGI->new({});

	my %headers = %{$this->headers};

	if(my $cookies = $this->cookies) {
		$headers{-cookie} = [map _createCookie($_,$cookies->{$_}), keys %$cookies] if $cookies;
	}

	$headers{'-status'} = $this->status || '200 OK';
	$headers{'-type'} = $this->type || 'text/html';

	if(my $charset = $this->charset) {
	   $q->charset($charset);
	   binmode $out, ":encoding($charset)";
	} else {
	   $q->charset('');
	   binmode $out;
	}

	print $out $q->header(\%headers);

	if(my $body = $this->body) {
		if(ref $body eq 'CODE') {
			$body->($out);
		} else {
			print $out $body;
		}
	}
}

#used to map a pair name valie to a valid cookie object
sub _createCookie {
    return UNIVERSAL::isa($_[1], 'CGI::Cookie')
        ? $_[1]
        : ( defined $_[1]
            ? CGI::Cookie->new(-name => $_[0], -value => $_[1] )
            : CGI::Cookie->new(-name => $_[0], -expires => '-1d', -value => '')
        );
}

sub InternalError {
    my ($self,%args) = @_;

    $args{status} ||= '500 Internal Server Error';

    return $self->new(%args);
}

sub Redirect {
    my ($self,%args) = @_;

    return $self->new(
        status => $args{status} || '303 See other',
        headers => {
            location => $args{location}
        }
    );
}

sub NoContent {
    my ($self,%args) = @_;

    return $self->new(
        status => $args{status} || '204 No Content'
    );
}

1;

__END__

=pod

=head1 NAME

C<IMPL::Web::HttpResponse> - Результат обработки C<HTTP> запроса.

=head1 SYNOPSIS

=head1 DESCRIPTION

Базовый класс для ответов приложения на C<HTTP> запрос. Каждый вид ответа,
например

Данный объект используется для формирования и передачи данных C<HTTP> ответа
напрямую. Основными полями являются C<body> и C<status>.

Кроме свойств относящихся непосредственно к самому C<HTTP> ответу, данный объект
может содержать свойства относящиеся к процессу обработки запроса, например
механизму формирования представления.

=head1 MEMBERS

=head2 C<[get,set]status>

Статус который будет отправлен сервером клиенту, например, C<200 OK> или
C<204 No response>. Если не указан, то будет C<200 OK>.

=head2 C<[get,set]type>

Тип содержимого, которое будет передано клиенту, если не указано, будет
C<text/html>.

=head2 C<[get,set]charset>

Кодировка в которой будут переданны данные. Следует задавать если и только, если
передается текстовая информация. Если указана кодировка, то она будет
автоматически применена к потоку, который будет передан методу C<PrintResponse>.

=head2 C<[get,set]cookies>

Опционально. Ссылка на хеш с печеньками.

=head2 C<[get,set]headers>

Опционально. Ссылка на хеш с дополнительными полями заголовка ответа. Формат
имен полей как у модуля C<CGI>.

=begin code

$response->header->{custom_header} = "my value";

#will produce the following header

Custom-header: my value

=end code

=head2 C<[get,set]body>

Тело ответа. Может быть как простой скаляр, который будет приведен к строке и
выдан в поток вывода метода C<PrintResponse>. Также может быть ссылкой на
процедуру, в таком случае будет вызвана эта процедура и ей будет передан
первым параметром поток для вывода тела ответа.

=head2 C<PrintResponse($outStream)>

Формирует заголовок и выводит ответ сервера в указанный параметром поток.

=cut
author	sergey
date	Mon, 25 Nov 2013 02:19:31 +0400
parents	32aceba4ee6d
children