lib/HTTP/Response.pm

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