vcs.maemo.org Git - pkg-perl/blob - deb-src/libwww-perl/libwww-perl-5.813/lib/HTTP/Response.pm

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