Filename | /var/www/foswiki11/lib/Foswiki/Response.pm |
Statements | Executed 47 statements in 2.17ms |
Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
---|---|---|---|---|---|
2 | 2 | 2 | 140µs | 142µs | body | Foswiki::Response::
1 | 1 | 1 | 46µs | 46µs | setDefaultHeaders | Foswiki::Response::
1 | 1 | 1 | 42µs | 90µs | |
1 | 1 | 1 | 15µs | 32µs | BEGIN@19 | Foswiki::Response::
1 | 1 | 1 | 13µs | 13µs | new | Foswiki::Response::
1 | 1 | 1 | 10µs | 16µs | BEGIN@20 | Foswiki::Response::
1 | 1 | 1 | 9µs | 23µs | BEGIN@21 | Foswiki::Response::
1 | 1 | 1 | 7µs | 7µs | status | Foswiki::Response::
1 | 1 | 1 | 4µs | 4µs | outputHasStarted | Foswiki::Response::
1 | 1 | 1 | 4µs | 4µs | BEGIN@23 | Foswiki::Response::
0 | 0 | 0 | 0s | 0s | charset | Foswiki::Response::
0 | 0 | 0 | 0s | 0s | cookies | Foswiki::Response::
0 | 0 | 0 | 0s | 0s | deleteHeader | Foswiki::Response::
0 | 0 | 0 | 0s | 0s | getHeader | Foswiki::Response::
0 | 0 | 0 | 0s | 0s | header | Foswiki::Response::
0 | 0 | 0 | 0s | 0s | headers | Foswiki::Response::
0 | 0 | 0 | 0s | 0s | printHeaders | Foswiki::Response::
0 | 0 | 0 | 0s | 0s | pushHeader | Foswiki::Response::
0 | 0 | 0 | 0s | 0s | redirect | Foswiki::Response::
Line | State ments |
Time on line |
Calls | Time in subs |
Code |
---|---|---|---|---|---|
1 | # See bottom of file for license and copyright information | ||||
2 | |||||
3 | =begin TML | ||||
4 | |||||
5 | ---+!! package Foswiki::Response | ||||
6 | |||||
7 | Class to encapsulate response data. | ||||
8 | |||||
9 | Fields: | ||||
10 | * =status= - response status | ||||
11 | * =headers= - hashref to response headers | ||||
12 | * =body= - response body | ||||
13 | * =cookies= - hashref to response cookies | ||||
14 | |||||
15 | =cut | ||||
16 | |||||
17 | package Foswiki::Response; | ||||
18 | |||||
19 | 2 | 32µs | 2 | 49µs | # spent 32µs (15+17) within Foswiki::Response::BEGIN@19 which was called:
# once (15µs+17µs) by Foswiki::Engine::CLI::BEGIN@25 at line 19 # spent 32µs making 1 call to Foswiki::Response::BEGIN@19
# spent 17µs making 1 call to strict::import |
20 | 2 | 28µs | 2 | 23µs | # spent 16µs (10+6) within Foswiki::Response::BEGIN@20 which was called:
# once (10µs+6µs) by Foswiki::Engine::CLI::BEGIN@25 at line 20 # spent 16µs making 1 call to Foswiki::Response::BEGIN@20
# spent 6µs making 1 call to warnings::import |
21 | 2 | 26µs | 2 | 38µs | # spent 23µs (9+14) within Foswiki::Response::BEGIN@21 which was called:
# once (9µs+14µs) by Foswiki::Engine::CLI::BEGIN@25 at line 21 # spent 23µs making 1 call to Foswiki::Response::BEGIN@21
# spent 14µs making 1 call to Assert::import |
22 | |||||
23 | 2 | 1.81ms | 1 | 4µs | # spent 4µs within Foswiki::Response::BEGIN@23 which was called:
# once (4µs+0s) by Foswiki::Engine::CLI::BEGIN@25 at line 23 # spent 4µs making 1 call to Foswiki::Response::BEGIN@23 |
24 | |||||
25 | =begin TML | ||||
26 | |||||
27 | ---++ ClassMethod new() -> $response | ||||
28 | |||||
29 | Constructs a Foswiki::Response object. | ||||
30 | |||||
31 | =cut | ||||
32 | |||||
33 | # spent 13µs within Foswiki::Response::new which was called:
# once (13µs+0s) by Foswiki::new at line 1724 of /var/www/foswiki11/lib/Foswiki.pm | ||||
34 | 1 | 600ns | my $proto = shift; | ||
35 | 1 | 700ns | my $class = ref($proto) || $proto; | ||
36 | 1 | 3µs | my $this = { | ||
37 | |||||
38 | #status needs to default to 'unset' to the web server can set the status to whatever it needs (think basic auth, or other magics) | ||||
39 | status => undef, | ||||
40 | headers => {}, | ||||
41 | body => undef, | ||||
42 | charset => 'ISO-8859-1', | ||||
43 | cookies => [], | ||||
44 | outputHasStarted => 0, | ||||
45 | }; | ||||
46 | |||||
47 | 1 | 11µs | return bless $this, $class; | ||
48 | } | ||||
49 | |||||
50 | =begin TML | ||||
51 | |||||
52 | ---++ ObjectMethod status( $status ) -> $status | ||||
53 | |||||
54 | Gets/Sets response status. | ||||
55 | * =$status= is a three digit code, optionally followed by a status string | ||||
56 | |||||
57 | =cut | ||||
58 | |||||
59 | # spent 7µs within Foswiki::Response::status which was called:
# once (7µs+0s) by Foswiki::UI::__ANON__[/var/www/foswiki11/lib/Foswiki/UI.pm:318] at line 314 of /var/www/foswiki11/lib/Foswiki/UI.pm | ||||
60 | 1 | 900ns | my ( $this, $status ) = @_; | ||
61 | 1 | 400ns | if ($status) { | ||
62 | ASSERT( !$this->{outputHasStarted}, 'Too late to change status' ) | ||||
63 | if DEBUG; | ||||
64 | $this->{status} = $status =~ /^\d{3}/ ? $status : undef; | ||||
65 | } | ||||
66 | 1 | 6µs | return $this->{status}; | ||
67 | } | ||||
68 | |||||
69 | =begin TML | ||||
70 | |||||
71 | ---++ ObjectMethod charset([$charset]) -> $charset | ||||
72 | |||||
73 | Gets/Sets response charset. If not defined, defaults to ISO-8859-1, | ||||
74 | just like CGI.pm | ||||
75 | |||||
76 | =cut | ||||
77 | |||||
78 | sub charset { | ||||
79 | return @_ == 1 ? $_[0]->{charset} : ( $_[0]->{charset} = $_[1] ); | ||||
80 | } | ||||
81 | |||||
82 | =begin TML | ||||
83 | |||||
84 | ---++ ObjectMethod header(-type => $type, | ||||
85 | -status => $status, | ||||
86 | -cookie => $cookie || \@cookies, | ||||
87 | -attachment => $attachName, | ||||
88 | -charset => $charset, | ||||
89 | -expires => $expires, | ||||
90 | -HeaderN => ValueN ) | ||||
91 | |||||
92 | Sets response header. Resonably compatible with CGI. | ||||
93 | Doesn't support -nph, -target and -p3p. | ||||
94 | |||||
95 | =cut | ||||
96 | |||||
97 | sub header { | ||||
98 | my ( $this, @p ) = @_; | ||||
99 | my (@header); | ||||
100 | |||||
101 | ASSERT( !$this->{outputHasStarted}, 'Too late to change headers' ) if DEBUG; | ||||
102 | |||||
103 | # Ugly hack to avoid html escape in CGI::Util::rearrange | ||||
104 | local $CGI::Q = { escape => 0 }; | ||||
105 | my ( $type, $status, $cookie, $charset, $expires, @other ) = | ||||
106 | CGI::Util::rearrange( | ||||
107 | [ | ||||
108 | [ 'TYPE', 'CONTENT_TYPE', 'CONTENT-TYPE' ], 'STATUS', | ||||
109 | [ 'COOKIE', 'COOKIES' ], 'CHARSET', | ||||
110 | 'EXPIRES', | ||||
111 | ], | ||||
112 | @p | ||||
113 | ); | ||||
114 | |||||
115 | if ( defined $charset ) { | ||||
116 | $this->charset($charset); | ||||
117 | } | ||||
118 | else { | ||||
119 | $charset = $this->charset; | ||||
120 | } | ||||
121 | |||||
122 | foreach (@other) { | ||||
123 | |||||
124 | # Don't use \s because of perl bug 21951 | ||||
125 | next unless my ( $header, $value ) = /([^ \r\n\t=]+)=\"?(.+?)\"?$/; | ||||
126 | |||||
127 | $header = lc($header); | ||||
128 | $header =~ s/\b(\w)/\u$1/g; | ||||
129 | if ( exists $this->{headers}->{$header} ) { | ||||
130 | if ( ref $this->{headers}->{$header} ) { | ||||
131 | push @{ $this->{headers}->{$header} }, $value; | ||||
132 | } | ||||
133 | else { | ||||
134 | $this->{headers}->{$header} = | ||||
135 | [ $this->{headers}->{$header}, $value ]; | ||||
136 | } | ||||
137 | } | ||||
138 | else { | ||||
139 | $this->{headers}->{$header} = $value; | ||||
140 | } | ||||
141 | } | ||||
142 | |||||
143 | $type ||= 'text/html' unless defined($type); | ||||
144 | $type .= "; charset=$charset" | ||||
145 | if $type ne '' | ||||
146 | and $type =~ m!^text/! | ||||
147 | and $type !~ /\bcharset\b/ | ||||
148 | and $charset ne ''; | ||||
149 | |||||
150 | if ($status) { | ||||
151 | $this->{headers}->{Status} = $status; | ||||
152 | $this->status($status); | ||||
153 | } | ||||
154 | |||||
155 | # push all the cookies -- there may be several | ||||
156 | if ($cookie) { | ||||
157 | my @cookies = ref($cookie) eq 'ARRAY' ? @$cookie : ($cookie); | ||||
158 | $this->cookies( \@cookies ); | ||||
159 | } | ||||
160 | $this->{headers}->{Expires} = CGI::Util::expires( $expires, 'http' ) | ||||
161 | if ( defined $expires ); | ||||
162 | $this->{headers}->{Date} = CGI::Util::expires( 0, 'http' ) | ||||
163 | if defined $expires || $cookie; | ||||
164 | |||||
165 | $this->{headers}->{'Content-Type'} = $type if $type ne ''; | ||||
166 | } | ||||
167 | |||||
168 | =begin TML | ||||
169 | |||||
170 | ---++ ObjectMethod headers( { ... } ) -> $headersHashRef | ||||
171 | |||||
172 | Gets/Sets all response headers. Keys are headers name and values | ||||
173 | are scalars for single-valued headers or arrayref for multivalued ones. | ||||
174 | |||||
175 | =cut | ||||
176 | |||||
177 | sub headers { | ||||
178 | my ( $this, $hdr ) = @_; | ||||
179 | if ($hdr) { | ||||
180 | ASSERT( !$this->{outputHasStarted}, 'Too late to change headers' ) | ||||
181 | if DEBUG; | ||||
182 | my %headers = (); | ||||
183 | while ( my ( $key, $value ) = each %$hdr ) { | ||||
184 | $key =~ s/(?:^|(?<=-))(.)([^-]*)/\u$1\L$2\E/g; | ||||
185 | $headers{$key} = $value; | ||||
186 | } | ||||
187 | $headers{Expires} = CGI::Util::expires( $headers{Expires}, 'http' ) | ||||
188 | if defined $headers{Expires}; | ||||
189 | $headers{Date} = CGI::Util::expires( 0, 'http' ) | ||||
190 | if defined $headers{'Set-Cookie'} || defined $headers{Expires}; | ||||
191 | if ( defined $headers{'Set-Cookie'} ) { | ||||
192 | my @cookies = | ||||
193 | ref( $headers{'Set-Cookie'} ) eq 'ARRAY' | ||||
194 | ? @{ $headers{'Set-Cookie'} } | ||||
195 | : ( $headers{'Set-Cookie'} ); | ||||
196 | $this->cookies( \@cookies ); | ||||
197 | } | ||||
198 | $this->status( $headers{Status} ) if defined $headers{Status}; | ||||
199 | $this->{headers} = \%headers; | ||||
200 | } | ||||
201 | return $this->{headers}; | ||||
202 | } | ||||
203 | |||||
204 | =begin TML | ||||
205 | |||||
206 | ---++ ObjectMethod getHeader( [ $name ] ) -> $value | ||||
207 | |||||
208 | If called without parameters returns all present header names, | ||||
209 | otherwise returns a list (maybe with a single element) of values | ||||
210 | associated with $name. | ||||
211 | |||||
212 | =cut | ||||
213 | |||||
214 | sub getHeader { | ||||
215 | my ( $this, $hdr ) = @_; | ||||
216 | return keys %{ $this->{headers} } unless $hdr; | ||||
217 | $hdr =~ s/(?:^|(?<=-))(.)([^-]*)/\u$1\L$2\E/g; | ||||
218 | if ( exists $this->{headers}->{$hdr} ) { | ||||
219 | my $value = $this->{headers}->{$hdr}; | ||||
220 | return ref $value ? @$value : ($value); | ||||
221 | } | ||||
222 | else { | ||||
223 | return; | ||||
224 | } | ||||
225 | } | ||||
226 | |||||
227 | =begin TML | ||||
228 | |||||
229 | ---++ ObjectMethod setDefaultHeaders( { $name => $value, ... } ) | ||||
230 | |||||
231 | Sets the header corresponding to the key => value pairs passed in the | ||||
232 | hash, if the key doesn't already exist, otherwise does nothing. | ||||
233 | This ensures some default values are entered, but they can be overridden | ||||
234 | by plugins or other parts in the code. | ||||
235 | |||||
236 | =cut | ||||
237 | |||||
238 | # spent 46µs within Foswiki::Response::setDefaultHeaders which was called:
# once (46µs+0s) by Foswiki::generateHTTPHeaders at line 1038 of /var/www/foswiki11/lib/Foswiki.pm | ||||
239 | 1 | 1µs | my ( $this, $hopt ) = @_; | ||
240 | 1 | 1µs | return unless $hopt && keys %$hopt; | ||
241 | 1 | 6µs | while ( my ( $hdr, $value ) = each %$hopt ) { | ||
242 | 3 | 20µs | $hdr =~ s/(?:^|(?<=-))(.)([^-]*)/\u$1\L$2\E/g; | ||
243 | 3 | 4µs | unless ( exists $this->{headers}->{$hdr} ) { | ||
244 | 3 | 2µs | if ( $hdr eq 'Status' ) { | ||
245 | $this->status($hdr); | ||||
246 | } | ||||
247 | elsif ( $hdr eq 'Expires' ) { | ||||
248 | $value = CGI::Util::expires( $value, 'http' ); | ||||
249 | } | ||||
250 | elsif ( $hdr eq 'Set-Cookie' ) { | ||||
251 | my @cookies = ref($value) eq 'ARRAY' ? @$value : ($value); | ||||
252 | $this->cookies( \@cookies ); | ||||
253 | } | ||||
254 | 3 | 4µs | $this->{headers}->{$hdr} = $value; | ||
255 | } | ||||
256 | } | ||||
257 | 1 | 8µs | $this->{headers}{Date} = CGI::Util::expires( 0, 'http' ) | ||
258 | if !exists $this->{headers}{Date} | ||||
259 | && ( defined $this->{headers}{Expires} | ||||
260 | || defined $this->{headers}{'Set-Cookie'} ); | ||||
261 | } | ||||
262 | |||||
263 | =begin TML | ||||
264 | |||||
265 | ---++ ObjectMethod printHeaders() | ||||
266 | |||||
267 | Return a string of all headers, separated by CRLF | ||||
268 | |||||
269 | =cut | ||||
270 | |||||
271 | sub printHeaders { | ||||
272 | my ($this) = shift; | ||||
273 | my $CRLF = "\x0D\x0A"; | ||||
274 | my $hdr = ''; | ||||
275 | |||||
276 | # make sure we always generate a status for the response | ||||
277 | $this->{headers}->{Status} = $this->status() | ||||
278 | if ( $this->status() && !defined( $this->headers->{Status} ) ); | ||||
279 | foreach my $header ( keys %{ $this->{headers} } ) { | ||||
280 | $hdr .= $header . ': ' . $_ . $CRLF foreach $this->getHeader($header); | ||||
281 | } | ||||
282 | $hdr .= $CRLF; | ||||
283 | return $hdr; | ||||
284 | } | ||||
285 | |||||
286 | =begin TML | ||||
287 | |||||
288 | ---++ ObjectMethod deleteHeader($h1, $h2, ...) | ||||
289 | |||||
290 | Deletes headers whose names are passed. | ||||
291 | |||||
292 | =cut | ||||
293 | |||||
294 | sub deleteHeader { | ||||
295 | my $this = shift; | ||||
296 | |||||
297 | ASSERT( !$this->{outputHasStarted}, 'Too late to change headers' ) if DEBUG; | ||||
298 | |||||
299 | foreach (@_) { | ||||
300 | ( my $hdr = $_ ) =~ s/(?:^|(?<=-))(.)([^-]*)/\u$1\L$2\E/g; | ||||
301 | delete $this->{headers}->{$hdr}; | ||||
302 | } | ||||
303 | } | ||||
304 | |||||
305 | =begin TML | ||||
306 | |||||
307 | ---++ ObjectMethod pushHeader( $name, $value ) | ||||
308 | |||||
309 | Adds $value to list of values associated with header $name. | ||||
310 | |||||
311 | =cut | ||||
312 | |||||
313 | sub pushHeader { | ||||
314 | my ( $this, $hdr, $value ) = @_; | ||||
315 | |||||
316 | ASSERT( !$this->{outputHasStarted}, 'Too late to change headers' ) if DEBUG; | ||||
317 | |||||
318 | $hdr =~ s/(?:^|(?<=-))(.)([^-]*)/\u$1\L$2\E/g; | ||||
319 | my $cur = $this->{headers}->{$hdr}; | ||||
320 | if ($cur) { | ||||
321 | if ( ref $cur ) { | ||||
322 | push @{ $this->{headers}->{$hdr} }, $value; | ||||
323 | } | ||||
324 | else { | ||||
325 | $this->{headers}->{$hdr} = [ $cur, $value ]; | ||||
326 | } | ||||
327 | } | ||||
328 | else { | ||||
329 | $this->{headers}->{$hdr} = $value; | ||||
330 | } | ||||
331 | } | ||||
332 | |||||
333 | =begin TML | ||||
334 | |||||
335 | ---++ ObjectMethod cookies( [ \@cookies ] ) -> @cookies | ||||
336 | |||||
337 | Gets/Sets response cookies. Parameter, if passed, *must* be an arrayref. | ||||
338 | |||||
339 | Elements may be CGI::Cookie objects or raw cookie strings. | ||||
340 | |||||
341 | WARNING: cookies set this way are *not* passed in redirects. | ||||
342 | |||||
343 | =cut | ||||
344 | |||||
345 | sub cookies { | ||||
346 | return @_ == 1 ? @{ $_[0]->{cookies} } : @{ $_[0]->{cookies} = $_[1] }; | ||||
347 | } | ||||
348 | |||||
349 | =begin TML | ||||
350 | |||||
351 | ---++ ObjectMethod body( [ $body ] ) -> $body | ||||
352 | |||||
353 | Gets/Sets response body. Note: do not use this method for output, use | ||||
354 | =print= instead. | ||||
355 | |||||
356 | =cut | ||||
357 | |||||
358 | # spent 142µs (140+2) within Foswiki::Response::body which was called 2 times, avg 71µs/call:
# once (93µs+0s) by Foswiki::Engine::finalizeBody at line 378 of /var/www/foswiki11/lib/Foswiki/Engine.pm
# once (46µs+2µs) by Foswiki::Response::print at line 418 | ||||
359 | 2 | 15µs | my ( $this, $body ) = @_; | ||
360 | 2 | 1µs | if ( defined $body ) { | ||
361 | |||||
362 | # There *is* a risk that a unicode string could reach this far - for | ||||
363 | # example, if it comes from a plugin. We need to force such strings | ||||
364 | # into the "Foswiki canonical" representation of a string of bytes. | ||||
365 | # The output may be crap, but at least it won't trigger a | ||||
366 | # "Wide character in print" error. | ||||
367 | 1 | 10µs | 1 | 2µs | if ( utf8::is_utf8($body) ) { # spent 2µs making 1 call to utf8::is_utf8 |
368 | require Encode; | ||||
369 | $body = Encode::encode( 'iso-8859-1', $body, 0 ); | ||||
370 | } | ||||
371 | 1 | 3µs | $this->{headers}->{'Content-Length'} = length($body); | ||
372 | 1 | 16µs | $this->{body} = $body; | ||
373 | } | ||||
374 | 2 | 102µs | return $this->{body}; | ||
375 | } | ||||
376 | |||||
377 | =begin TML | ||||
378 | |||||
379 | ---++ ObjectMethod redirect( $uri, $status, $cookies | | ||||
380 | -Location => $uri, | ||||
381 | -Status => $status, | ||||
382 | -Cookies => $cookies ) | ||||
383 | |||||
384 | Populate object with redirect response headers. | ||||
385 | |||||
386 | =$uri= *must* be passed. Others are optional. | ||||
387 | |||||
388 | CGI Compatibility Note: It doesn't support -target or -nph | ||||
389 | |||||
390 | =cut | ||||
391 | |||||
392 | sub redirect { | ||||
393 | my ( $this, @p ) = @_; | ||||
394 | ASSERT( !$this->{outputHasStarted}, 'Too late to redirect' ) if DEBUG; | ||||
395 | my ( $url, $status, $cookies ) = CGI::Util::rearrange( | ||||
396 | [ [qw(LOCATION URL URI)], 'STATUS', [qw(COOKIE COOKIES)], ], @p ); | ||||
397 | |||||
398 | return unless $url; | ||||
399 | return if ( $status && $status !~ /^\s*3\d\d.*/ ); | ||||
400 | |||||
401 | my @headers = ( -Location => $url ); | ||||
402 | push @headers, '-Status' => ( $status || 302 ); | ||||
403 | push @headers, '-Cookie' => $cookies if $cookies; | ||||
404 | $this->header(@headers); | ||||
405 | } | ||||
406 | |||||
407 | =begin TML | ||||
408 | |||||
409 | ---++ ObjectMethod print(...) | ||||
410 | |||||
411 | Add content to the end of the body. | ||||
412 | |||||
413 | =cut | ||||
414 | |||||
415 | # spent 90µs (42+48) within Foswiki::Response::print which was called:
# once (42µs+48µs) by Foswiki::writeCompletePage at line 880 of /var/www/foswiki11/lib/Foswiki.pm | ||||
416 | 1 | 500ns | my $this = shift; | ||
417 | 1 | 2µs | $this->{body} = '' unless defined $this->{body}; | ||
418 | 1 | 40µs | 1 | 48µs | $this->body( $this->{body} . join( '', @_ ) ); # spent 48µs making 1 call to Foswiki::Response::body |
419 | } | ||||
420 | |||||
421 | =begin TML | ||||
422 | |||||
423 | ---++ ObjectMethod outputHasStarted([$boolean]) | ||||
424 | |||||
425 | Get/set the output-has-started flag. This is used by the Foswiki::Engine | ||||
426 | to separate header and body output. Once output has started, the headers | ||||
427 | cannot be changed (though the body can be modified) | ||||
428 | |||||
429 | =cut | ||||
430 | |||||
431 | # spent 4µs within Foswiki::Response::outputHasStarted which was called:
# once (4µs+0s) by Foswiki::Engine::finalize at line 273 of /var/www/foswiki11/lib/Foswiki/Engine.pm | ||||
432 | 1 | 1µs | my ( $this, $flag ) = @_; | ||
433 | 1 | 200ns | $this->{outputHasStarted} = $flag if defined $flag; | ||
434 | 1 | 5µs | return $this->{outputHasStarted}; | ||
435 | } | ||||
436 | |||||
437 | 1 | 3µs | 1; | ||
438 | __END__ |