Mercurial > pub > Impl
annotate Lib/IMPL/Web/Application/Response.pm @ 63:76b878ad6596
Added serialization support for the IMPL::Object::List
More intelligent Exception message
Fixed encoding support in the actions
Improoved tests
Minor fixes
| author | wizard |
|---|---|
| date | Mon, 15 Mar 2010 02:38:09 +0300 |
| parents | 0f3e369553bd |
| children | 2840c4c85db8 |
| 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 { |
| 17 public property query => prop_get | owner_set; # cgi query | |
| 18 public property status => prop_all, { validator => \&_checkHeaderPrinted }; | |
| 19 public property contentType => prop_all, { validator => \&_checkHeaderPrinted }; # String | |
| 58 | 20 public property charset => { get => \&_charset, set => \&_charset }, { validator => \&_checkHeaderPrinted }; |
| 57 | 21 public property expires => prop_all, { validator => \&_checkHeaderPrinted }; |
| 22 public property cookies => prop_all, { validator => \&_checkHeaderPrinted }; # Hash | |
| 23 | |
| 58 | 24 public property buffered => prop_all, { validator => \&_canChangeBuffer }; # Boolean |
| 57 | 25 public property streamOut => prop_get | owner_set; # stream |
| 26 public property streamBody => {get => \&getStreamBody }; # stream | |
| 58 | 27 public property isHeaderPrinted => prop_get | owner_set; # Boolean |
| 57 | 28 |
| 29 private property _bufferBody => prop_all; | |
| 30 private property _streamBody => prop_all; | |
| 31 } | |
| 32 | |
| 33 __PACKAGE__->PassThroughArgs; | |
| 34 | |
| 35 sub CTOR { | |
| 36 my ($this,%args) = @_; | |
| 37 | |
| 58 | 38 $this->query(CGI->new($this->query() | {})) unless $this->query; |
| 57 | 39 |
| 58 | 40 $this->streamOut(*STDOUT) unless $this->streamOut; |
|
63
76b878ad6596
Added serialization support for the IMPL::Object::List
wizard
parents:
59
diff
changeset
|
41 $this->buffered(1) unless defined $this->buffered; |
|
76b878ad6596
Added serialization support for the IMPL::Object::List
wizard
parents:
59
diff
changeset
|
42 binmode $this->streamOut, ":encoding(".$this->charset.")"; |
| 57 | 43 } |
| 44 | |
| 45 sub _checkHeaderPrinted { | |
| 46 my ($this,$value) = @_; | |
| 47 | |
| 48 die new IMPL::InvalidOperationException() if $this->isHeaderPrinted; | |
| 49 } | |
| 50 | |
| 58 | 51 sub _canChangeBuffer { |
| 52 my ($this,$value) = @_; | |
| 53 | |
| 54 die new IMPL::InvalidOperationException() if $this->isHeaderPrinted or $this->_streamBody; | |
| 55 } | |
| 56 | |
| 57 sub _charset { | |
| 58 my $this = shift; | |
| 59 | |
|
63
76b878ad6596
Added serialization support for the IMPL::Object::List
wizard
parents:
59
diff
changeset
|
60 if (@_) { |
|
76b878ad6596
Added serialization support for the IMPL::Object::List
wizard
parents:
59
diff
changeset
|
61 my $charset = $this->query->charset(@_); |
|
76b878ad6596
Added serialization support for the IMPL::Object::List
wizard
parents:
59
diff
changeset
|
62 |
|
76b878ad6596
Added serialization support for the IMPL::Object::List
wizard
parents:
59
diff
changeset
|
63 my $hout = $this->streamOut; |
|
76b878ad6596
Added serialization support for the IMPL::Object::List
wizard
parents:
59
diff
changeset
|
64 |
|
76b878ad6596
Added serialization support for the IMPL::Object::List
wizard
parents:
59
diff
changeset
|
65 binmode $hout; |
|
76b878ad6596
Added serialization support for the IMPL::Object::List
wizard
parents:
59
diff
changeset
|
66 binmode $hout, ":encoding($charset)"; |
|
76b878ad6596
Added serialization support for the IMPL::Object::List
wizard
parents:
59
diff
changeset
|
67 |
|
76b878ad6596
Added serialization support for the IMPL::Object::List
wizard
parents:
59
diff
changeset
|
68 return $charset; |
|
76b878ad6596
Added serialization support for the IMPL::Object::List
wizard
parents:
59
diff
changeset
|
69 } else { |
|
76b878ad6596
Added serialization support for the IMPL::Object::List
wizard
parents:
59
diff
changeset
|
70 return $this->query->charset; |
|
76b878ad6596
Added serialization support for the IMPL::Object::List
wizard
parents:
59
diff
changeset
|
71 } |
| 58 | 72 } |
| 73 | |
| 57 | 74 sub _PrintHeader { |
| 75 my ($this) = @_; | |
| 76 | |
| 77 unless ($this->isHeaderPrinted) { | |
| 78 $this->isHeaderPrinted(1); | |
| 79 | |
| 80 my %opt; | |
| 81 | |
| 82 $opt{-type} = $this->contentType if $this->contentType; | |
| 83 $opt{-status} = $this->status if $this->status; | |
| 84 $opt{-expires} = $this->expires if $this->expires; | |
| 85 | |
| 86 my $refCookies = $this->cookies; | |
| 87 $opt{-cookie} = [map CGI::Cookie->new(-name => $_, $refCookies->{$_} ), keys %$refCookies] if $refCookies; | |
| 88 | |
| 89 my $hOut = $this->streamOut; | |
| 90 | |
| 91 print $hOut $this->query->header( | |
| 92 %opt | |
| 93 ); | |
| 94 } | |
| 95 } | |
| 96 | |
| 97 sub getStreamBody { | |
| 98 my ($this) = @_; | |
| 99 | |
| 58 | 100 return undef unless $this->streamOut; |
| 57 | 101 |
| 58 | 102 unless ($this->_streamBody) { |
| 103 if ($this->buffered) { | |
| 104 my $buffer = ""; | |
|
63
76b878ad6596
Added serialization support for the IMPL::Object::List
wizard
parents:
59
diff
changeset
|
105 |
| 58 | 106 $this->_bufferBody(\$buffer); |
| 107 | |
|
63
76b878ad6596
Added serialization support for the IMPL::Object::List
wizard
parents:
59
diff
changeset
|
108 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
|
109 |
|
76b878ad6596
Added serialization support for the IMPL::Object::List
wizard
parents:
59
diff
changeset
|
110 Encode::_utf8_on($buffer); |
| 58 | 111 |
| 112 $this->_streamBody($hBody); | |
| 113 } else { | |
| 114 $this->_PrintHeader(); | |
| 115 $this->_streamBody($this->streamOut); | |
| 116 } | |
| 57 | 117 } |
| 58 | 118 |
| 119 return $this->_streamBody; | |
| 57 | 120 } |
| 121 | |
| 122 sub Complete { | |
| 123 my ($this) = @_; | |
| 124 | |
| 125 return 0 unless $this->streamOut; | |
| 126 | |
| 127 my $hOut = $this->streamOut; | |
| 128 | |
| 129 $this->_PrintHeader(); | |
| 130 | |
|
63
76b878ad6596
Added serialization support for the IMPL::Object::List
wizard
parents:
59
diff
changeset
|
131 $this->_streamBody(undef); |
|
76b878ad6596
Added serialization support for the IMPL::Object::List
wizard
parents:
59
diff
changeset
|
132 |
| 57 | 133 if ($this->buffered) { |
| 134 print $hOut ${$this->_bufferBody}; | |
|
63
76b878ad6596
Added serialization support for the IMPL::Object::List
wizard
parents:
59
diff
changeset
|
135 } |
| 57 | 136 |
| 137 $this->_bufferBody(undef); | |
| 138 $this->streamOut(undef); | |
| 139 | |
| 140 return 1; | |
| 141 } | |
| 142 | |
| 143 sub Discard { | |
| 144 my ($this) = @_; | |
| 145 | |
| 58 | 146 carp "Discarding sent response" if $this->isHeaderPrinted; |
| 147 | |
| 57 | 148 $this->_streamBody(undef); |
| 149 $this->_bufferBody(undef); | |
| 150 $this->streamOut(undef); | |
| 151 } | |
| 152 | |
| 153 1; | |
| 154 | |
| 155 __END__ | |
| 156 | |
| 157 =pod | |
| 158 | |
| 58 | 159 =head1 DESCRIPTION |
| 57 | 160 |
| 58 | 161 Ответ сервера на CGI запрос, позволяет сформировать основные свойства заголовка и тело запроса. |
| 162 | |
| 163 Объект позволяет буфферизировать вывод в тело ответа, что позволяет отменить или изменить | |
| 164 ответ в последний момент. | |
| 165 | |
| 166 Свойство C< isHeaderPrinted > можно использовать для определения были ли отправлены какие-нибудь | |
| 167 данные клиенту. | |
| 168 | |
| 169 =head1 PROPERTIES | |
| 170 | |
| 171 =head2 HTTP Header | |
| 172 | |
| 173 Свойства отвечающие за заголовок HTTP ответа. Эти своства могут быть изменены до тех пор пока | |
| 174 не будет отправлен заголовок. В противном случае выдается исключение C< IMPL::InvalidOperationException >. | |
| 175 | |
| 176 =over | |
| 177 | |
| 178 =item C< query > | |
| 179 | |
| 180 CGI запрос, который используется для вывода данных, заголовка и пр. Существует всегда. | |
| 181 | |
| 182 =item C< status > | |
| 183 | |
| 184 Код ошибки HTTP. Например, '200 OK'. По умолчанию не установлен, при отправке клиенту бедт отправлен '200 ОК'. | |
| 185 | |
| 186 =item C< contentType > | |
| 187 | |
| 188 Тип MIME. По умолчанию не установлен, подразумивается 'text/html'. | |
| 189 | |
| 190 =item C< charset > | |
| 191 | |
| 192 Кодировка, синоним свойства query->charset. | |
| 193 | |
| 194 =item C< expires > | |
| 195 | |
| 196 Определяет время жизни контента, например '+10m'. По умолчанию не задано и не передается. | |
| 197 | |
| 198 =item C< cookies > | |
| 199 | |
| 200 Хеш массив с cookies, например C< { cart => ['foo','bar'], display => 'list' } >. | |
| 201 | |
| 202 =back | |
| 203 | |
| 204 =head2 Response behaviour | |
| 205 | |
| 206 Свойства отвечающие за поведение ответа. | |
| 207 | |
| 208 =over | |
| 209 | |
| 210 =item C< buffered > | |
| 211 | |
| 212 C< True > - то тело ответа пишется в буффер и будет отправлено при вызове метода C< Complete >, | |
| 213 заголовок также будет отправлен после вызова метода C< Complete >. | |
| 214 | |
| 215 C< False > - тело ответа пишется непосредственно в поток к клиенту, при этом заголовок | |
| 216 будет отправлен при первом обращении к свойству C< streamBody > | |
| 217 | |
| 218 Это свойство можно менять до первого обращения к потоку для записи в тело ответа. | |
| 219 | |
| 220 =item C< streamOut > | |
| 221 | |
| 222 Стандартный вывод CGI приложения. | |
| 223 | |
| 224 =item C< streamBody > | |
| 225 | |
| 226 Поток для записи в тело ответа. | |
| 227 | |
| 228 =item C< isHeadPrinted > | |
| 229 | |
| 230 Признак того, что заголовок уже был отправлен клиенту. | |
| 231 | |
| 232 =back | |
| 233 | |
| 234 =head1 METHODS | |
| 235 | |
| 236 =over | |
| 237 | |
| 238 =item C< Complete > | |
| 239 | |
| 240 Завершает отправку ответа. | |
| 241 | |
| 242 =item C< Discard > | |
| 243 | |
| 244 Отменяет отправку ответа, при этом если часть данных (например, заголовок) | |
| 245 уже была отправлена, выдает предупреждение в STDERR. | |
| 246 | |
| 247 =back | |
| 57 | 248 |
| 249 =cut |