1 | package HTTP::Response;
|
---|
2 |
|
---|
3 | require HTTP::Message;
|
---|
4 | @ISA = qw(HTTP::Message);
|
---|
5 | $VERSION = "6.04";
|
---|
6 |
|
---|
7 | use strict;
|
---|
8 | use HTTP::Status ();
|
---|
9 |
|
---|
10 |
|
---|
11 |
|
---|
12 | sub new
|
---|
13 | {
|
---|
14 | my($class, $rc, $msg, $header, $content) = @_;
|
---|
15 | my $self = $class->SUPER::new($header, $content);
|
---|
16 | $self->code($rc);
|
---|
17 | $self->message($msg);
|
---|
18 | $self;
|
---|
19 | }
|
---|
20 |
|
---|
21 |
|
---|
22 | sub parse
|
---|
23 | {
|
---|
24 | my($class, $str) = @_;
|
---|
25 | my $status_line;
|
---|
26 | if ($str =~ s/^(.*)\n//) {
|
---|
27 | $status_line = $1;
|
---|
28 | }
|
---|
29 | else {
|
---|
30 | $status_line = $str;
|
---|
31 | $str = "";
|
---|
32 | }
|
---|
33 |
|
---|
34 | my $self = $class->SUPER::parse($str);
|
---|
35 | my($protocol, $code, $message);
|
---|
36 | if ($status_line =~ /^\d{3} /) {
|
---|
37 | # Looks like a response created by HTTP::Response->new
|
---|
38 | ($code, $message) = split(' ', $status_line, 2);
|
---|
39 | } else {
|
---|
40 | ($protocol, $code, $message) = split(' ', $status_line, 3);
|
---|
41 | }
|
---|
42 | $self->protocol($protocol) if $protocol;
|
---|
43 | $self->code($code) if defined($code);
|
---|
44 | $self->message($message) if defined($message);
|
---|
45 | $self;
|
---|
46 | }
|
---|
47 |
|
---|
48 |
|
---|
49 | sub clone
|
---|
50 | {
|
---|
51 | my $self = shift;
|
---|
52 | my $clone = bless $self->SUPER::clone, ref($self);
|
---|
53 | $clone->code($self->code);
|
---|
54 | $clone->message($self->message);
|
---|
55 | $clone->request($self->request->clone) if $self->request;
|
---|
56 | # we don't clone previous
|
---|
57 | $clone;
|
---|
58 | }
|
---|
59 |
|
---|
60 |
|
---|
61 | sub code { shift->_elem('_rc', @_); }
|
---|
62 | sub message { shift->_elem('_msg', @_); }
|
---|
63 | sub previous { shift->_elem('_previous',@_); }
|
---|
64 | sub request { shift->_elem('_request', @_); }
|
---|
65 |
|
---|
66 |
|
---|
67 | sub status_line
|
---|
68 | {
|
---|
69 | my $self = shift;
|
---|
70 | my $code = $self->{'_rc'} || "000";
|
---|
71 | my $mess = $self->{'_msg'} || HTTP::Status::status_message($code) || "Unknown code";
|
---|
72 | return "$code $mess";
|
---|
73 | }
|
---|
74 |
|
---|
75 |
|
---|
76 | sub base
|
---|
77 | {
|
---|
78 | my $self = shift;
|
---|
79 | my $base = (
|
---|
80 | $self->header('Content-Base'), # used to be HTTP/1.1
|
---|
81 | $self->header('Content-Location'), # HTTP/1.1
|
---|
82 | $self->header('Base'), # HTTP/1.0
|
---|
83 | )[0];
|
---|
84 | if ($base && $base =~ /^$URI::scheme_re:/o) {
|
---|
85 | # already absolute
|
---|
86 | return $HTTP::URI_CLASS->new($base);
|
---|
87 | }
|
---|
88 |
|
---|
89 | my $req = $self->request;
|
---|
90 | if ($req) {
|
---|
91 | # if $base is undef here, the return value is effectively
|
---|
92 | # just a copy of $self->request->uri.
|
---|
93 | return $HTTP::URI_CLASS->new_abs($base, $req->uri);
|
---|
94 | }
|
---|
95 |
|
---|
96 | # can't find an absolute base
|
---|
97 | return undef;
|
---|
98 | }
|
---|
99 |
|
---|
100 |
|
---|
101 | sub redirects {
|
---|
102 | my $self = shift;
|
---|
103 | my @r;
|
---|
104 | my $r = $self;
|
---|
105 | while (my $p = $r->previous) {
|
---|
106 | push(@r, $p);
|
---|
107 | $r = $p;
|
---|
108 | }
|
---|
109 | return @r unless wantarray;
|
---|
110 | return reverse @r;
|
---|
111 | }
|
---|
112 |
|
---|
113 |
|
---|
114 | sub filename
|
---|
115 | {
|
---|
116 | my $self = shift;
|
---|
117 | my $file;
|
---|
118 |
|
---|
119 | my $cd = $self->header('Content-Disposition');
|
---|
120 | if ($cd) {
|
---|
121 | require HTTP::Headers::Util;
|
---|
122 | if (my @cd = HTTP::Headers::Util::split_header_words($cd)) {
|
---|
123 | my ($disposition, undef, %cd_param) = @{$cd[-1]};
|
---|
124 | $file = $cd_param{filename};
|
---|
125 |
|
---|
126 | # RFC 2047 encoded?
|
---|
127 | if ($file && $file =~ /^=\?(.+?)\?(.+?)\?(.+)\?=$/) {
|
---|
128 | my $charset = $1;
|
---|
129 | my $encoding = uc($2);
|
---|
130 | my $encfile = $3;
|
---|
131 |
|
---|
132 | if ($encoding eq 'Q' || $encoding eq 'B') {
|
---|
133 | local($SIG{__DIE__});
|
---|
134 | eval {
|
---|
135 | if ($encoding eq 'Q') {
|
---|
136 | $encfile =~ s/_/ /g;
|
---|
137 | require MIME::QuotedPrint;
|
---|
138 | $encfile = MIME::QuotedPrint::decode($encfile);
|
---|
139 | }
|
---|
140 | else { # $encoding eq 'B'
|
---|
141 | require MIME::Base64;
|
---|
142 | $encfile = MIME::Base64::decode($encfile);
|
---|
143 | }
|
---|
144 |
|
---|
145 | require Encode;
|
---|
146 | require Encode::Locale;
|
---|
147 | Encode::from_to($encfile, $charset, "locale_fs");
|
---|
148 | };
|
---|
149 |
|
---|
150 | $file = $encfile unless $@;
|
---|
151 | }
|
---|
152 | }
|
---|
153 | }
|
---|
154 | }
|
---|
155 |
|
---|
156 | unless (defined($file) && length($file)) {
|
---|
157 | my $uri;
|
---|
158 | if (my $cl = $self->header('Content-Location')) {
|
---|
159 | $uri = URI->new($cl);
|
---|
160 | }
|
---|
161 | elsif (my $request = $self->request) {
|
---|
162 | $uri = $request->uri;
|
---|
163 | }
|
---|
164 |
|
---|
165 | if ($uri) {
|
---|
166 | $file = ($uri->path_segments)[-1];
|
---|
167 | }
|
---|
168 | }
|
---|
169 |
|
---|
170 | if ($file) {
|
---|
171 | $file =~ s,.*[\\/],,; # basename
|
---|
172 | }
|
---|
173 |
|
---|
174 | if ($file && !length($file)) {
|
---|
175 | $file = undef;
|
---|
176 | }
|
---|
177 |
|
---|
178 | $file;
|
---|
179 | }
|
---|
180 |
|
---|
181 |
|
---|
182 | sub as_string
|
---|
183 | {
|
---|
184 | my $self = shift;
|
---|
185 | my($eol) = @_;
|
---|
186 | $eol = "\n" unless defined $eol;
|
---|
187 |
|
---|
188 | my $status_line = $self->status_line;
|
---|
189 | my $proto = $self->protocol;
|
---|
190 | $status_line = "$proto $status_line" if $proto;
|
---|
191 |
|
---|
192 | return join($eol, $status_line, $self->SUPER::as_string(@_));
|
---|
193 | }
|
---|
194 |
|
---|
195 |
|
---|
196 | sub dump
|
---|
197 | {
|
---|
198 | my $self = shift;
|
---|
199 |
|
---|
200 | my $status_line = $self->status_line;
|
---|
201 | my $proto = $self->protocol;
|
---|
202 | $status_line = "$proto $status_line" if $proto;
|
---|
203 |
|
---|
204 | return $self->SUPER::dump(
|
---|
205 | preheader => $status_line,
|
---|
206 | @_,
|
---|
207 | );
|
---|
208 | }
|
---|
209 |
|
---|
210 |
|
---|
211 | sub is_info { HTTP::Status::is_info (shift->{'_rc'}); }
|
---|
212 | sub is_success { HTTP::Status::is_success (shift->{'_rc'}); }
|
---|
213 | sub is_redirect { HTTP::Status::is_redirect (shift->{'_rc'}); }
|
---|
214 | sub is_error { HTTP::Status::is_error (shift->{'_rc'}); }
|
---|
215 |
|
---|
216 |
|
---|
217 | sub error_as_HTML
|
---|
218 | {
|
---|
219 | my $self = shift;
|
---|
220 | my $title = 'An Error Occurred';
|
---|
221 | my $body = $self->status_line;
|
---|
222 | $body =~ s/&/&/g;
|
---|
223 | $body =~ s/</</g;
|
---|
224 | return <<EOM;
|
---|
225 | <html>
|
---|
226 | <head><title>$title</title></head>
|
---|
227 | <body>
|
---|
228 | <h1>$title</h1>
|
---|
229 | <p>$body</p>
|
---|
230 | </body>
|
---|
231 | </html>
|
---|
232 | EOM
|
---|
233 | }
|
---|
234 |
|
---|
235 |
|
---|
236 | sub current_age
|
---|
237 | {
|
---|
238 | my $self = shift;
|
---|
239 | my $time = shift;
|
---|
240 |
|
---|
241 | # Implementation of RFC 2616 section 13.2.3
|
---|
242 | # (age calculations)
|
---|
243 | my $response_time = $self->client_date;
|
---|
244 | my $date = $self->date;
|
---|
245 |
|
---|
246 | my $age = 0;
|
---|
247 | if ($response_time && $date) {
|
---|
248 | $age = $response_time - $date; # apparent_age
|
---|
249 | $age = 0 if $age < 0;
|
---|
250 | }
|
---|
251 |
|
---|
252 | my $age_v = $self->header('Age');
|
---|
253 | if ($age_v && $age_v > $age) {
|
---|
254 | $age = $age_v; # corrected_received_age
|
---|
255 | }
|
---|
256 |
|
---|
257 | if ($response_time) {
|
---|
258 | my $request = $self->request;
|
---|
259 | if ($request) {
|
---|
260 | my $request_time = $request->date;
|
---|
261 | if ($request_time && $request_time < $response_time) {
|
---|
262 | # Add response_delay to age to get 'corrected_initial_age'
|
---|
263 | $age += $response_time - $request_time;
|
---|
264 | }
|
---|
265 | }
|
---|
266 | $age += ($time || time) - $response_time;
|
---|
267 | }
|
---|
268 | return $age;
|
---|
269 | }
|
---|
270 |
|
---|
271 |
|
---|
272 | sub freshness_lifetime
|
---|
273 | {
|
---|
274 | my($self, %opt) = @_;
|
---|
275 |
|
---|
276 | # First look for the Cache-Control: max-age=n header
|
---|
277 | for my $cc ($self->header('Cache-Control')) {
|
---|
278 | for my $cc_dir (split(/\s*,\s*/, $cc)) {
|
---|
279 | return $1 if $cc_dir =~ /^max-age\s*=\s*(\d+)/i;
|
---|
280 | }
|
---|
281 | }
|
---|
282 |
|
---|
283 | # Next possibility is to look at the "Expires" header
|
---|
284 | my $date = $self->date || $self->client_date || $opt{time} || time;
|
---|
285 | if (my $expires = $self->expires) {
|
---|
286 | return $expires - $date;
|
---|
287 | }
|
---|
288 |
|
---|
289 | # Must apply heuristic expiration
|
---|
290 | return undef if exists $opt{heuristic_expiry} && !$opt{heuristic_expiry};
|
---|
291 |
|
---|
292 | # Default heuristic expiration parameters
|
---|
293 | $opt{h_min} ||= 60;
|
---|
294 | $opt{h_max} ||= 24 * 3600;
|
---|
295 | $opt{h_lastmod_fraction} ||= 0.10; # 10% since last-mod suggested by RFC2616
|
---|
296 | $opt{h_default} ||= 3600;
|
---|
297 |
|
---|
298 | # Should give a warning if more than 24 hours according to
|
---|
299 | # RFC 2616 section 13.2.4. Here we just make this the default
|
---|
300 | # maximum value.
|
---|
301 |
|
---|
302 | if (my $last_modified = $self->last_modified) {
|
---|
303 | my $h_exp = ($date - $last_modified) * $opt{h_lastmod_fraction};
|
---|
304 | return $opt{h_min} if $h_exp < $opt{h_min};
|
---|
305 | return $opt{h_max} if $h_exp > $opt{h_max};
|
---|
306 | return $h_exp;
|
---|
307 | }
|
---|
308 |
|
---|
309 | # default when all else fails
|
---|
310 | return $opt{h_min} if $opt{h_min} > $opt{h_default};
|
---|
311 | return $opt{h_default};
|
---|
312 | }
|
---|
313 |
|
---|
314 |
|
---|
315 | sub is_fresh
|
---|
316 | {
|
---|
317 | my($self, %opt) = @_;
|
---|
318 | $opt{time} ||= time;
|
---|
319 | my $f = $self->freshness_lifetime(%opt);
|
---|
320 | return undef unless defined($f);
|
---|
321 | return $f > $self->current_age($opt{time});
|
---|
322 | }
|
---|
323 |
|
---|
324 |
|
---|
325 | sub fresh_until
|
---|
326 | {
|
---|
327 | my($self, %opt) = @_;
|
---|
328 | $opt{time} ||= time;
|
---|
329 | my $f = $self->freshness_lifetime(%opt);
|
---|
330 | return undef unless defined($f);
|
---|
331 | return $f - $self->current_age($opt{time}) + $opt{time};
|
---|
332 | }
|
---|
333 |
|
---|
334 | 1;
|
---|
335 |
|
---|
336 |
|
---|
337 | __END__
|
---|
338 |
|
---|
339 | =head1 NAME
|
---|
340 |
|
---|
341 | HTTP::Response - HTTP style response message
|
---|
342 |
|
---|
343 | =head1 SYNOPSIS
|
---|
344 |
|
---|
345 | Response objects are returned by the request() method of the C<LWP::UserAgent>:
|
---|
346 |
|
---|
347 | # ...
|
---|
348 | $response = $ua->request($request)
|
---|
349 | if ($response->is_success) {
|
---|
350 | print $response->decoded_content;
|
---|
351 | }
|
---|
352 | else {
|
---|
353 | print STDERR $response->status_line, "\n";
|
---|
354 | }
|
---|
355 |
|
---|
356 | =head1 DESCRIPTION
|
---|
357 |
|
---|
358 | The C<HTTP::Response> class encapsulates HTTP style responses. A
|
---|
359 | response consists of a response line, some headers, and a content
|
---|
360 | body. Note that the LWP library uses HTTP style responses even for
|
---|
361 | non-HTTP protocol schemes. Instances of this class are usually
|
---|
362 | created and returned by the request() method of an C<LWP::UserAgent>
|
---|
363 | object.
|
---|
364 |
|
---|
365 | C<HTTP::Response> is a subclass of C<HTTP::Message> and therefore
|
---|
366 | inherits its methods. The following additional methods are available:
|
---|
367 |
|
---|
368 | =over 4
|
---|
369 |
|
---|
370 | =item $r = HTTP::Response->new( $code )
|
---|
371 |
|
---|
372 | =item $r = HTTP::Response->new( $code, $msg )
|
---|
373 |
|
---|
374 | =item $r = HTTP::Response->new( $code, $msg, $header )
|
---|
375 |
|
---|
376 | =item $r = HTTP::Response->new( $code, $msg, $header, $content )
|
---|
377 |
|
---|
378 | Constructs a new C<HTTP::Response> object describing a response with
|
---|
379 | response code $code and optional message $msg. The optional $header
|
---|
380 | argument should be a reference to an C<HTTP::Headers> object or a
|
---|
381 | plain array reference of key/value pairs. The optional $content
|
---|
382 | argument should be a string of bytes. The meanings of these arguments are
|
---|
383 | described below.
|
---|
384 |
|
---|
385 | =item $r = HTTP::Response->parse( $str )
|
---|
386 |
|
---|
387 | This constructs a new response object by parsing the given string.
|
---|
388 |
|
---|
389 | =item $r->code
|
---|
390 |
|
---|
391 | =item $r->code( $code )
|
---|
392 |
|
---|
393 | This is used to get/set the code attribute. The code is a 3 digit
|
---|
394 | number that encode the overall outcome of an HTTP response. The
|
---|
395 | C<HTTP::Status> module provide constants that provide mnemonic names
|
---|
396 | for the code attribute.
|
---|
397 |
|
---|
398 | =item $r->message
|
---|
399 |
|
---|
400 | =item $r->message( $message )
|
---|
401 |
|
---|
402 | This is used to get/set the message attribute. The message is a short
|
---|
403 | human readable single line string that explains the response code.
|
---|
404 |
|
---|
405 | =item $r->header( $field )
|
---|
406 |
|
---|
407 | =item $r->header( $field => $value )
|
---|
408 |
|
---|
409 | This is used to get/set header values and it is inherited from
|
---|
410 | C<HTTP::Headers> via C<HTTP::Message>. See L<HTTP::Headers> for
|
---|
411 | details and other similar methods that can be used to access the
|
---|
412 | headers.
|
---|
413 |
|
---|
414 | =item $r->content
|
---|
415 |
|
---|
416 | =item $r->content( $bytes )
|
---|
417 |
|
---|
418 | This is used to get/set the raw content and it is inherited from the
|
---|
419 | C<HTTP::Message> base class. See L<HTTP::Message> for details and
|
---|
420 | other methods that can be used to access the content.
|
---|
421 |
|
---|
422 | =item $r->decoded_content( %options )
|
---|
423 |
|
---|
424 | This will return the content after any C<Content-Encoding> and
|
---|
425 | charsets have been decoded. See L<HTTP::Message> for details.
|
---|
426 |
|
---|
427 | =item $r->request
|
---|
428 |
|
---|
429 | =item $r->request( $request )
|
---|
430 |
|
---|
431 | This is used to get/set the request attribute. The request attribute
|
---|
432 | is a reference to the the request that caused this response. It does
|
---|
433 | not have to be the same request passed to the $ua->request() method,
|
---|
434 | because there might have been redirects and authorization retries in
|
---|
435 | between.
|
---|
436 |
|
---|
437 | =item $r->previous
|
---|
438 |
|
---|
439 | =item $r->previous( $response )
|
---|
440 |
|
---|
441 | This is used to get/set the previous attribute. The previous
|
---|
442 | attribute is used to link together chains of responses. You get
|
---|
443 | chains of responses if the first response is redirect or unauthorized.
|
---|
444 | The value is C<undef> if this is the first response in a chain.
|
---|
445 |
|
---|
446 | Note that the method $r->redirects is provided as a more convenient
|
---|
447 | way to access the response chain.
|
---|
448 |
|
---|
449 | =item $r->status_line
|
---|
450 |
|
---|
451 | Returns the string "E<lt>code> E<lt>message>". If the message attribute
|
---|
452 | is not set then the official name of E<lt>code> (see L<HTTP::Status>)
|
---|
453 | is substituted.
|
---|
454 |
|
---|
455 | =item $r->base
|
---|
456 |
|
---|
457 | Returns the base URI for this response. The return value will be a
|
---|
458 | reference to a URI object.
|
---|
459 |
|
---|
460 | The base URI is obtained from one the following sources (in priority
|
---|
461 | order):
|
---|
462 |
|
---|
463 | =over 4
|
---|
464 |
|
---|
465 | =item 1.
|
---|
466 |
|
---|
467 | Embedded in the document content, for instance <BASE HREF="...">
|
---|
468 | in HTML documents.
|
---|
469 |
|
---|
470 | =item 2.
|
---|
471 |
|
---|
472 | A "Content-Base:" or a "Content-Location:" header in the response.
|
---|
473 |
|
---|
474 | For backwards compatibility with older HTTP implementations we will
|
---|
475 | also look for the "Base:" header.
|
---|
476 |
|
---|
477 | =item 3.
|
---|
478 |
|
---|
479 | The URI used to request this response. This might not be the original
|
---|
480 | URI that was passed to $ua->request() method, because we might have
|
---|
481 | received some redirect responses first.
|
---|
482 |
|
---|
483 | =back
|
---|
484 |
|
---|
485 | If none of these sources provide an absolute URI, undef is returned.
|
---|
486 |
|
---|
487 | When the LWP protocol modules produce the HTTP::Response object, then
|
---|
488 | any base URI embedded in the document (step 1) will already have
|
---|
489 | initialized the "Content-Base:" header. This means that this method
|
---|
490 | only performs the last 2 steps (the content is not always available
|
---|
491 | either).
|
---|
492 |
|
---|
493 | =item $r->filename
|
---|
494 |
|
---|
495 | Returns a filename for this response. Note that doing sanity checks
|
---|
496 | on the returned filename (eg. removing characters that cannot be used
|
---|
497 | on the target filesystem where the filename would be used, and
|
---|
498 | laundering it for security purposes) are the caller's responsibility;
|
---|
499 | the only related thing done by this method is that it makes a simple
|
---|
500 | attempt to return a plain filename with no preceding path segments.
|
---|
501 |
|
---|
502 | The filename is obtained from one the following sources (in priority
|
---|
503 | order):
|
---|
504 |
|
---|
505 | =over 4
|
---|
506 |
|
---|
507 | =item 1.
|
---|
508 |
|
---|
509 | A "Content-Disposition:" header in the response. Proper decoding of
|
---|
510 | RFC 2047 encoded filenames requires the C<MIME::QuotedPrint> (for "Q"
|
---|
511 | encoding), C<MIME::Base64> (for "B" encoding), and C<Encode> modules.
|
---|
512 |
|
---|
513 | =item 2.
|
---|
514 |
|
---|
515 | A "Content-Location:" header in the response.
|
---|
516 |
|
---|
517 | =item 3.
|
---|
518 |
|
---|
519 | The URI used to request this response. This might not be the original
|
---|
520 | URI that was passed to $ua->request() method, because we might have
|
---|
521 | received some redirect responses first.
|
---|
522 |
|
---|
523 | =back
|
---|
524 |
|
---|
525 | If a filename cannot be derived from any of these sources, undef is
|
---|
526 | returned.
|
---|
527 |
|
---|
528 | =item $r->as_string
|
---|
529 |
|
---|
530 | =item $r->as_string( $eol )
|
---|
531 |
|
---|
532 | Returns a textual representation of the response.
|
---|
533 |
|
---|
534 | =item $r->is_info
|
---|
535 |
|
---|
536 | =item $r->is_success
|
---|
537 |
|
---|
538 | =item $r->is_redirect
|
---|
539 |
|
---|
540 | =item $r->is_error
|
---|
541 |
|
---|
542 | These methods indicate if the response was informational, successful, a
|
---|
543 | redirection, or an error. See L<HTTP::Status> for the meaning of these.
|
---|
544 |
|
---|
545 | =item $r->error_as_HTML
|
---|
546 |
|
---|
547 | Returns a string containing a complete HTML document indicating what
|
---|
548 | error occurred. This method should only be called when $r->is_error
|
---|
549 | is TRUE.
|
---|
550 |
|
---|
551 | =item $r->redirects
|
---|
552 |
|
---|
553 | Returns the list of redirect responses that lead up to this response
|
---|
554 | by following the $r->previous chain. The list order is oldest first.
|
---|
555 |
|
---|
556 | In scalar context return the number of redirect responses leading up
|
---|
557 | to this one.
|
---|
558 |
|
---|
559 | =item $r->current_age
|
---|
560 |
|
---|
561 | Calculates the "current age" of the response as specified by RFC 2616
|
---|
562 | section 13.2.3. The age of a response is the time since it was sent
|
---|
563 | by the origin server. The returned value is a number representing the
|
---|
564 | age in seconds.
|
---|
565 |
|
---|
566 | =item $r->freshness_lifetime( %opt )
|
---|
567 |
|
---|
568 | Calculates the "freshness lifetime" of the response as specified by
|
---|
569 | RFC 2616 section 13.2.4. The "freshness lifetime" is the length of
|
---|
570 | time between the generation of a response and its expiration time.
|
---|
571 | The returned value is the number of seconds until expiry.
|
---|
572 |
|
---|
573 | If the response does not contain an "Expires" or a "Cache-Control"
|
---|
574 | header, then this function will apply some simple heuristic based on
|
---|
575 | the "Last-Modified" header to determine a suitable lifetime. The
|
---|
576 | following options might be passed to control the heuristics:
|
---|
577 |
|
---|
578 | =over
|
---|
579 |
|
---|
580 | =item heuristic_expiry => $bool
|
---|
581 |
|
---|
582 | If passed as a FALSE value, don't apply heuristics and just return
|
---|
583 | C<undef> when "Expires" or "Cache-Control" is lacking.
|
---|
584 |
|
---|
585 | =item h_lastmod_fraction => $num
|
---|
586 |
|
---|
587 | This number represent the fraction of the difference since the
|
---|
588 | "Last-Modified" timestamp to make the expiry time. The default is
|
---|
589 | C<0.10>, the suggested typical setting of 10% in RFC 2616.
|
---|
590 |
|
---|
591 | =item h_min => $sec
|
---|
592 |
|
---|
593 | This is the lower limit of the heuristic expiry age to use. The
|
---|
594 | default is C<60> (1 minute).
|
---|
595 |
|
---|
596 | =item h_max => $sec
|
---|
597 |
|
---|
598 | This is the upper limit of the heuristic expiry age to use. The
|
---|
599 | default is C<86400> (24 hours).
|
---|
600 |
|
---|
601 | =item h_default => $sec
|
---|
602 |
|
---|
603 | This is the expiry age to use when nothing else applies. The default
|
---|
604 | is C<3600> (1 hour) or "h_min" if greater.
|
---|
605 |
|
---|
606 | =back
|
---|
607 |
|
---|
608 | =item $r->is_fresh( %opt )
|
---|
609 |
|
---|
610 | Returns TRUE if the response is fresh, based on the values of
|
---|
611 | freshness_lifetime() and current_age(). If the response is no longer
|
---|
612 | fresh, then it has to be re-fetched or re-validated by the origin
|
---|
613 | server.
|
---|
614 |
|
---|
615 | Options might be passed to control expiry heuristics, see the
|
---|
616 | description of freshness_lifetime().
|
---|
617 |
|
---|
618 | =item $r->fresh_until( %opt )
|
---|
619 |
|
---|
620 | Returns the time (seconds since epoch) when this entity is no longer fresh.
|
---|
621 |
|
---|
622 | Options might be passed to control expiry heuristics, see the
|
---|
623 | description of freshness_lifetime().
|
---|
624 |
|
---|
625 | =back
|
---|
626 |
|
---|
627 | =head1 SEE ALSO
|
---|
628 |
|
---|
629 | L<HTTP::Headers>, L<HTTP::Message>, L<HTTP::Status>, L<HTTP::Request>
|
---|
630 |
|
---|
631 | =head1 COPYRIGHT
|
---|
632 |
|
---|
633 | Copyright 1995-2004 Gisle Aas.
|
---|
634 |
|
---|
635 | This library is free software; you can redistribute it and/or
|
---|
636 | modify it under the same terms as Perl itself.
|
---|
637 |
|
---|