Mercurial > pub > Impl
annotate Lib/IMPL/Web/Application/Response.pm @ 130:06a34c197b05
Added support for utf-8 and old versions of CGI module
| author | wizard |
|---|---|
| date | Wed, 16 Jun 2010 01:50:56 +0400 |
| parents | 964587c5183c |
| children | 4267a2ac3d46 |
| rev | line source |
|---|---|
|
59
0f3e369553bd
Rewritten property implementation (probably become slower but more flexible)
wizard
parents:
58
diff
changeset
|
1 package IMPL::Web::Application::Response; |
| 57 | 2 use strict; |
| 3 | |
| 4 use base qw(IMPL::Object IMPL::Object::Autofill); | |
| 5 | |
| 6 require IMPL::Exception; | |
| 7 require CGI; | |
| 8 require CGI::Cookie; | |
| 9 | |
| 58 | 10 use Carp; |
|
63
76b878ad6596
Added serialization support for the IMPL::Object::List
wizard
parents:
59
diff
changeset
|
11 use Encode; |
| 57 | 12 use IMPL::Class::Property; |
| 13 | |
|
63
76b878ad6596
Added serialization support for the IMPL::Object::List
wizard
parents:
59
diff
changeset
|
14 #todo: add binary method to set a binary encoding, set it automatic when type isn't a text |
|
76b878ad6596
Added serialization support for the IMPL::Object::List
wizard
parents:
59
diff
changeset
|
15 |
| 57 | 16 BEGIN { |
| 67 | 17 # автозаполнение буде происходить в порядке объявления |
| 57 | 18 public property query => prop_get | owner_set; # cgi query |
| 19 public property status => prop_all, { validator => \&_checkHeaderPrinted }; | |
| 20 public property contentType => prop_all, { validator => \&_checkHeaderPrinted }; # String | |
| 58 | 21 public property charset => { get => \&_charset, set => \&_charset }, { validator => \&_checkHeaderPrinted }; |
| 57 | 22 public property expires => prop_all, { validator => \&_checkHeaderPrinted }; |
| 23 public property cookies => prop_all, { validator => \&_checkHeaderPrinted }; # Hash | |
| 24 | |
| 58 | 25 public property buffered => prop_all, { validator => \&_canChangeBuffer }; # Boolean |
| 57 | 26 public property streamOut => prop_get | owner_set; # stream |
| 27 public property streamBody => {get => \&getStreamBody }; # stream | |
| 58 | 28 public property isHeaderPrinted => prop_get | owner_set; # Boolean |
| 57 | 29 |
| 30 private property _bufferBody => prop_all; | |
| 31 private property _streamBody => prop_all; | |
| 32 } | |
| 33 | |
| 34 __PACKAGE__->PassThroughArgs; | |
| 35 | |
| 67 | 36 our %CTOR = ( |
| 37 'IMPL::Object::Autofill' => sub { | |
| 38 my %args = @_; | |
| 39 | |
| 40 $args{query} = CGI->new($args{query} || {}); | |
| 41 | |
| 42 %args; | |
| 43 } | |
| 44 ); | |
| 45 | |
| 57 | 46 sub CTOR { |
| 47 my ($this,%args) = @_; | |
| 48 | |
| 65 | 49 if (lc $this->streamOut eq 'memory') { |
| 50 my $dummy = ''; | |
| 51 open my $hout, '>:encoding(utf8)', \$dummy or die new IMPL::Exception("Failed to create memory stream",$!); | |
| 52 $this->streamOut($hout); | |
| 53 } elsif (not $this->streamOut) { | |
| 54 $this->streamOut(*STDOUT); | |
| 55 } else { | |
| 56 die new IMPL::InvalidArgumentException("Invalid parameter value",$this->streamOut); | |
| 57 } | |
| 58 | |
|
63
76b878ad6596
Added serialization support for the IMPL::Object::List
wizard
parents:
59
diff
changeset
|
59 $this->buffered(1) unless defined $this->buffered; |
|
76b878ad6596
Added serialization support for the IMPL::Object::List
wizard
parents:
59
diff
changeset
|
60 binmode $this->streamOut, ":encoding(".$this->charset.")"; |
| 57 | 61 } |
| 62 | |
| 63 sub _checkHeaderPrinted { | |
| 64 my ($this,$value) = @_; | |
| 65 | |
| 66 die new IMPL::InvalidOperationException() if $this->isHeaderPrinted; | |
| 67 } | |
| 68 | |
| 58 | 69 sub _canChangeBuffer { |
| 70 my ($this,$value) = @_; | |
| 71 | |
| 72 die new IMPL::InvalidOperationException() if $this->isHeaderPrinted or $this->_streamBody; | |
| 73 } | |
| 74 | |
| 75 sub _charset { | |
| 76 my $this = shift; | |
| 77 | |
|
63
76b878ad6596
Added serialization support for the IMPL::Object::List
wizard
parents:
59
diff
changeset
|
78 if (@_) { |
|
76b878ad6596
Added serialization support for the IMPL::Object::List
wizard
parents:
59
diff
changeset
|
79 my $charset = $this->query->charset(@_); |
|
76b878ad6596
Added serialization support for the IMPL::Object::List
wizard
parents:
59
diff
changeset
|
80 |
|
76b878ad6596
Added serialization support for the IMPL::Object::List
wizard
parents:
59
diff
changeset
|
81 my $hout = $this->streamOut; |
|
76b878ad6596
Added serialization support for the IMPL::Object::List
wizard
parents:
59
diff
changeset
|
82 |
|
76b878ad6596
Added serialization support for the IMPL::Object::List
wizard
parents:
59
diff
changeset
|
83 binmode $hout; |
|
76b878ad6596
Added serialization support for the IMPL::Object::List
wizard
parents:
59
diff
changeset
|
84 binmode $hout, ":encoding($charset)"; |
|
76b878ad6596
Added serialization support for the IMPL::Object::List
wizard
parents:
59
diff
changeset
|
85 |
|
76b878ad6596
Added serialization support for the IMPL::Object::List
wizard
parents:
59
diff
changeset
|
86 return $charset; |
|
76b878ad6596
Added serialization support for the IMPL::Object::List
wizard
parents:
59
diff
changeset
|
87 } else { |
|
76b878ad6596
Added serialization support for the IMPL::Object::List
wizard
parents:
59
diff
changeset
|
88 return $this->query->charset; |
|
76b878ad6596
Added serialization support for the IMPL::Object::List
wizard
parents:
59
diff
changeset
|
89 } |
| 58 | 90 } |
| 91 | |
| 57 | 92 sub _PrintHeader { |
| 93 my ($this) = @_; | |
| 94 | |
| 95 unless ($this->isHeaderPrinted) { | |
| 96 $this->isHeaderPrinted(1); | |
| 97 | |
| 98 my %opt; | |
| 99 | |
| 100 $opt{-type} = $this->contentType if $this->contentType; | |
| 101 $opt{-status} = $this->status if $this->status; | |
| 102 $opt{-expires} = $this->expires if $this->expires; | |
| 103 | |
| 104 my $refCookies = $this->cookies; | |
| 97 | 105 $opt{-cookie} = [map _createCookie($_,$refCookies->{$_}), keys %$refCookies] if $refCookies; |
| 57 | 106 |
| 107 my $hOut = $this->streamOut; | |
| 108 | |
| 109 print $hOut $this->query->header( | |
| 110 %opt | |
| 111 ); | |
| 112 } | |
| 113 } | |
| 114 | |
| 97 | 115 sub _createCookie { |
| 116 return UNIVERSAL::isa($_[1], 'CGI::Cookie') ? $_[1] : CGI::Cookie->new(-name => $_[0], -value => $_[1] ); | |
| 117 } | |
| 118 | |
|
95
67eb8eaec3d4
Added a security authority property to the Context and Security classes
wizard
parents:
67
diff
changeset
|
119 sub setCookie { |
|
67eb8eaec3d4
Added a security authority property to the Context and Security classes
wizard
parents:
67
diff
changeset
|
120 my ($this,$name,$value) = @_; |
|
67eb8eaec3d4
Added a security authority property to the Context and Security classes
wizard
parents:
67
diff
changeset
|
121 |
|
67eb8eaec3d4
Added a security authority property to the Context and Security classes
wizard
parents:
67
diff
changeset
|
122 unless ($this->cookies) { |
|
67eb8eaec3d4
Added a security authority property to the Context and Security classes
wizard
parents:
67
diff
changeset
|
123 $this->cookies({$name,$value}); |
|
67eb8eaec3d4
Added a security authority property to the Context and Security classes
wizard
parents:
67
diff
changeset
|
124 } else { |
|
67eb8eaec3d4
Added a security authority property to the Context and Security classes
wizard
parents:
67
diff
changeset
|
125 $this->_checkHeaderPrinted(); |
|
67eb8eaec3d4
Added a security authority property to the Context and Security classes
wizard
parents:
67
diff
changeset
|
126 $this->cookies->{$name} = $value; |
|
67eb8eaec3d4
Added a security authority property to the Context and Security classes
wizard
parents:
67
diff
changeset
|
127 } |
|
67eb8eaec3d4
Added a security authority property to the Context and Security classes
wizard
parents:
67
diff
changeset
|
128 return $value; |
|
67eb8eaec3d4
Added a security authority property to the Context and Security classes
wizard
parents:
67
diff
changeset
|
129 } |
|
67eb8eaec3d4
Added a security authority property to the Context and Security classes
wizard
parents:
67
diff
changeset
|
130 |
| 57 | 131 sub getStreamBody { |
| 132 my ($this) = @_; | |
| 133 | |
| 58 | 134 return undef unless $this->streamOut; |
| 57 | 135 |
| 58 | 136 unless ($this->_streamBody) { |
| 137 if ($this->buffered) { | |
| 138 my $buffer = ""; | |
|
63
76b878ad6596
Added serialization support for the IMPL::Object::List
wizard
parents:
59
diff
changeset
|
139 |
| 58 | 140 $this->_bufferBody(\$buffer); |
| 141 | |
|
63
76b878ad6596
Added serialization support for the IMPL::Object::List
wizard
parents:
59
diff
changeset
|
142 open my $hBody, ">:encoding(utf-8)", \$buffer or die new IMPL::Exception("Failed to create buffer",$!); |
|
76b878ad6596
Added serialization support for the IMPL::Object::List
wizard
parents:
59
diff
changeset
|
143 |
|
76b878ad6596
Added serialization support for the IMPL::Object::List
wizard
parents:
59
diff
changeset
|
144 Encode::_utf8_on($buffer); |
| 58 | 145 |
| 146 $this->_streamBody($hBody); | |
| 147 } else { | |
| 148 $this->_PrintHeader(); | |
| 149 $this->_streamBody($this->streamOut); | |
| 150 } | |
| 57 | 151 } |
| 58 | 152 |
| 153 return $this->_streamBody; | |
| 57 | 154 } |
| 155 | |
| 156 sub Complete { | |
| 157 my ($this) = @_; | |
| 158 | |
| 159 return 0 unless $this->streamOut; | |
| 160 | |
| 161 my $hOut = $this->streamOut; | |
| 162 | |
| 163 $this->_PrintHeader(); | |
| 97 | 164 |
| 165 close $this->_streamBody(); | |
|
63
76b878ad6596
Added serialization support for the IMPL::Object::List
wizard
parents:
59
diff
changeset
|
166 |
| 57 | 167 if ($this->buffered) { |
| 168 print $hOut ${$this->_bufferBody}; | |
|
63
76b878ad6596
Added serialization support for the IMPL::Object::List
wizard
parents:
59
diff
changeset
|
169 } |
| 57 | 170 |
| 171 $this->_bufferBody(undef); | |
| 172 $this->streamOut(undef); | |
| 173 | |
| 174 return 1; | |
| 175 } | |
| 176 | |
| 177 sub Discard { | |
| 178 my ($this) = @_; | |
| 179 | |
| 58 | 180 carp "Discarding sent response" if $this->isHeaderPrinted; |
| 181 | |
| 57 | 182 $this->_streamBody(undef); |
| 183 $this->_bufferBody(undef); | |
| 184 $this->streamOut(undef); | |
| 185 } | |
| 186 | |
| 187 1; | |
| 188 | |
| 189 __END__ | |
| 190 | |
| 191 =pod | |
| 192 | |
| 67 | 193 =head1 NAME |
| 194 | |
| 195 C<IMPL::Web::Application::Response> - Ответ веб сервера непосредственно клиенту. | |
| 196 | |
| 58 | 197 =head1 DESCRIPTION |
| 57 | 198 |
| 67 | 199 C<[Infrastructure]> |
| 200 | |
| 201 Позволяет сформировать основные свойства заголовка и тело ответа. | |
| 202 | |
| 203 Создается объектом C<IMPL::Web::Application::Action> в процессе обработки запроса. | |
| 204 | |
| 205 Может использоваться обработчиками C<IMPL::Web::QueryHandler> в процессе выполнения запроса. | |
| 58 | 206 |
| 207 Объект позволяет буфферизировать вывод в тело ответа, что позволяет отменить или изменить | |
| 67 | 208 ответ в последний момент. Свойство C< isHeaderPrinted > используется для определения факта |
| 209 отправлки данных клиенту. | |
| 58 | 210 |
| 211 =head1 PROPERTIES | |
| 212 | |
| 213 =head2 HTTP Header | |
| 214 | |
| 215 Свойства отвечающие за заголовок HTTP ответа. Эти своства могут быть изменены до тех пор пока | |
| 216 не будет отправлен заголовок. В противном случае выдается исключение C< IMPL::InvalidOperationException >. | |
| 217 | |
| 218 =over | |
| 219 | |
| 67 | 220 =item C< [get] query > |
| 58 | 221 |
| 222 CGI запрос, который используется для вывода данных, заголовка и пр. Существует всегда. | |
| 223 | |
| 67 | 224 =item C< [get,set] status > |
| 58 | 225 |
| 226 Код ошибки HTTP. Например, '200 OK'. По умолчанию не установлен, при отправке клиенту бедт отправлен '200 ОК'. | |
| 227 | |
| 67 | 228 =item C< [get,set] contentType > |
| 58 | 229 |
| 230 Тип MIME. По умолчанию не установлен, подразумивается 'text/html'. | |
| 231 | |
| 67 | 232 =item C< [get,set] charset > |
| 58 | 233 |
| 234 Кодировка, синоним свойства query->charset. | |
| 235 | |
| 67 | 236 =item C< [get,set] expires > |
| 58 | 237 |
| 238 Определяет время жизни контента, например '+10m'. По умолчанию не задано и не передается. | |
| 239 | |
| 67 | 240 =item C< [get,set] cookies > |
| 58 | 241 |
| 242 Хеш массив с cookies, например C< { cart => ['foo','bar'], display => 'list' } >. | |
| 243 | |
| 244 =back | |
| 245 | |
| 246 =head2 Response behaviour | |
| 247 | |
| 248 Свойства отвечающие за поведение ответа. | |
| 249 | |
| 250 =over | |
| 251 | |
| 67 | 252 =item C< [get,set] buffered > |
| 58 | 253 |
| 254 C< True > - то тело ответа пишется в буффер и будет отправлено при вызове метода C< Complete >, | |
| 255 заголовок также будет отправлен после вызова метода C< Complete >. | |
| 256 | |
| 257 C< False > - тело ответа пишется непосредственно в поток к клиенту, при этом заголовок | |
| 258 будет отправлен при первом обращении к свойству C< streamBody > | |
| 259 | |
| 260 Это свойство можно менять до первого обращения к потоку для записи в тело ответа. | |
| 261 | |
| 67 | 262 =item C< [get] streamOut > |
| 58 | 263 |
| 264 Стандартный вывод CGI приложения. | |
| 265 | |
| 67 | 266 =item C< [get] streamBody > |
| 58 | 267 |
| 268 Поток для записи в тело ответа. | |
| 269 | |
| 67 | 270 =item C< [get] isHeadPrinted > |
| 58 | 271 |
| 272 Признак того, что заголовок уже был отправлен клиенту. | |
| 273 | |
| 274 =back | |
| 275 | |
| 276 =head1 METHODS | |
| 277 | |
| 278 =over | |
| 279 | |
| 280 =item C< Complete > | |
| 281 | |
| 282 Завершает отправку ответа. | |
| 283 | |
| 284 =item C< Discard > | |
| 285 | |
| 286 Отменяет отправку ответа, при этом если часть данных (например, заголовок) | |
| 287 уже была отправлена, выдает предупреждение в STDERR. | |
| 288 | |
| 289 =back | |
| 57 | 290 |
| 67 | 291 =head1 REMARKS |
| 292 | |
| 293 Данный объект является автозаполняемым, т.е. все его свойства можно задать через | |
| 294 именованные параметры конструктора. | |
| 295 | |
| 57 | 296 =cut |