|
407
|
1 use strict;
|
|
|
2 package IMPL::Web::HttpResponse;
|
|
|
3
|
|
|
4 use CGI();
|
|
|
5 use IMPL::lang qw(:declare :hash);
|
|
|
6 use IMPL::declare {
|
|
|
7 require => {
|
|
|
8 Exception => 'IMPL::Exception',
|
|
|
9 ArgumentException => '-IMPL::InvalidArgumentException'
|
|
|
10 },
|
|
|
11 base => [
|
|
|
12 'IMPL::Object' => undef,
|
|
|
13 'IMPL::Object::Autofill' => '@_'
|
|
|
14 ],
|
|
|
15 props => [
|
|
|
16 status => PROP_ALL,
|
|
|
17 type => PROP_ALL,
|
|
|
18 charset => PROP_ALL,
|
|
|
19 cookies => PROP_ALL,
|
|
|
20 headers => PROP_ALL,
|
|
|
21 body => PROP_ALL
|
|
|
22 ]
|
|
|
23 };
|
|
|
24
|
|
|
25 sub CTOR {
|
|
|
26 my ($this) = @_;
|
|
|
27
|
|
|
28 $this->headers({}) unless $this->headers();
|
|
|
29 $this->cookies({}) unless $this->cookies();
|
|
|
30 }
|
|
|
31
|
|
|
32 sub PrintResponse {
|
|
|
33 my ($this,$out) = @_;
|
|
|
34
|
|
|
35 my $q = CGI->new({});
|
|
|
36
|
|
|
37 my %headers = %{$this->headers};
|
|
|
38
|
|
|
39 if(my $cookies = $this->cookies) {
|
|
|
40 $headers{-cookie} = [map _createCookie($_,$cookies->{$_}), keys %$cookies] if $cookies;
|
|
|
41 }
|
|
|
42
|
|
|
43 $headers{'-status'} = $this->status || '200 OK';
|
|
|
44 $headers{'-type'} = $this->type || 'text/html';
|
|
|
45
|
|
|
46 if(my $charset = $this->charset) {
|
|
|
47 $q->charset($charset);
|
|
|
48 binmode $out, ":encoding($charset)";
|
|
|
49 } else {
|
|
|
50 $q->charset('');
|
|
|
51 binmode $out;
|
|
|
52 }
|
|
|
53
|
|
|
54 print $out $q->header(\%headers);
|
|
|
55
|
|
|
56 if(my $body = $this->body) {
|
|
|
57 if(ref $body eq 'CODE') {
|
|
|
58 $body->($out);
|
|
|
59 } else {
|
|
|
60 print $out $body;
|
|
|
61 }
|
|
|
62 }
|
|
|
63 }
|
|
|
64
|
|
|
65 #used to map a pair name valie to a valid cookie object
|
|
|
66 sub _createCookie {
|
|
|
67 return UNIVERSAL::isa($_[1], 'CGI::Cookie')
|
|
|
68 ? $_[1]
|
|
|
69 : ( defined $_[1]
|
|
|
70 ? CGI::Cookie->new(-name => $_[0], -value => $_[1] )
|
|
|
71 : CGI::Cookie->new(-name => $_[0], -expires => '-1d', -value => '')
|
|
|
72 );
|
|
|
73 }
|
|
|
74
|
|
|
75 sub InternalError {
|
|
|
76 my ($self,%args) = @_;
|
|
|
77
|
|
|
78 $args{status} ||= '500 Internal Server Error';
|
|
|
79
|
|
|
80 return $self->new(%args);
|
|
|
81 }
|
|
|
82
|
|
|
83 sub Redirect {
|
|
|
84 my ($self,%args) = @_;
|
|
|
85
|
|
|
86 return $self->new(
|
|
|
87 status => $args{status} || '303 See other',
|
|
|
88 headers => {
|
|
|
89 location => $args{location}
|
|
|
90 }
|
|
|
91 );
|
|
|
92 }
|
|
|
93
|
|
|
94 sub NoContent {
|
|
|
95 my ($self,%args) = @_;
|
|
|
96
|
|
|
97 return $self->new(
|
|
|
98 status => $args{status} || '204 No Content'
|
|
|
99 );
|
|
|
100 }
|
|
|
101
|
|
|
102 1;
|
|
|
103
|
|
|
104 __END__
|
|
|
105
|
|
|
106 =pod
|
|
|
107
|
|
|
108 =head1 NAME
|
|
|
109
|
|
|
110 C<IMPL::Web::HttpResponse> - Результат обработки C<HTTP> запроса.
|
|
|
111
|
|
|
112 =head1 SYNOPSIS
|
|
|
113
|
|
|
114 =head1 DESCRIPTION
|
|
|
115
|
|
|
116 Базовый класс для ответов приложения на C<HTTP> запрос. Каждый вид ответа,
|
|
|
117 например
|
|
|
118
|
|
|
119 Данный объект используется для формирования и передачи данных C<HTTP> ответа
|
|
|
120 напрямую. Основными полями являются C<body> и C<status>.
|
|
|
121
|
|
|
122 Кроме свойств относящихся непосредственно к самому C<HTTP> ответу, данный объект
|
|
|
123 может содержать свойства относящиеся к процессу обработки запроса, например
|
|
|
124 механизму формирования представления.
|
|
|
125
|
|
|
126 =head1 MEMBERS
|
|
|
127
|
|
|
128 =head2 C<[get,set]status>
|
|
|
129
|
|
|
130 Статус который будет отправлен сервером клиенту, например, C<200 OK> или
|
|
|
131 C<204 No response>. Если не указан, то будет C<200 OK>.
|
|
|
132
|
|
|
133 =head2 C<[get,set]type>
|
|
|
134
|
|
|
135 Тип содержимого, которое будет передано клиенту, если не указано, будет
|
|
|
136 C<text/html>.
|
|
|
137
|
|
|
138 =head2 C<[get,set]charset>
|
|
|
139
|
|
|
140 Кодировка в которой будут переданны данные. Следует задавать если и только, если
|
|
|
141 передается текстовая информация. Если указана кодировка, то она будет
|
|
|
142 автоматически применена к потоку, который будет передан методу C<PrintResponse>.
|
|
|
143
|
|
|
144 =head2 C<[get,set]cookies>
|
|
|
145
|
|
|
146 Опционально. Ссылка на хеш с печеньками.
|
|
|
147
|
|
|
148 =head2 C<[get,set]headers>
|
|
|
149
|
|
|
150 Опционально. Ссылка на хеш с дополнительными полями заголовка ответа. Формат
|
|
|
151 имен полей как у модуля C<CGI>.
|
|
|
152
|
|
|
153 =begin code
|
|
|
154
|
|
|
155 $response->header->{custom_header} = "my value";
|
|
|
156
|
|
|
157 #will produce the following header
|
|
|
158
|
|
|
159 Custom-header: my value
|
|
|
160
|
|
|
161 =end code
|
|
|
162
|
|
|
163 =head2 C<[get,set]body>
|
|
|
164
|
|
|
165 Тело ответа. Может быть как простой скаляр, который будет приведен к строке и
|
|
|
166 выдан в поток вывода метода C<PrintResponse>. Также может быть ссылкой на
|
|
|
167 процедуру, в таком случае будет вызвана эта процедура и ей будет передан
|
|
|
168 первым параметром поток для вывода тела ответа.
|
|
|
169
|
|
|
170 =head2 C<PrintResponse($outStream)>
|
|
|
171
|
|
|
172 Формирует заголовок и выводит ответ сервера в указанный параметром поток.
|
|
|
173
|
|
|
174 =cut |
