local-lib5/lib/perl5/HTTP/Response.pm

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