home *** CD-ROM | disk | FTP | other *** search
/ Acorn User 10 / AU_CD10.iso / Updates / Perl / Perl_Libs / site_perl / HTTP / Response.pm < prev    next >
Text File  |  1997-12-03  |  10KB  |  396 lines
  1. #
  2. # $Id: Response.pm,v 1.30 1997/12/03 21:05:47 aas Exp $
  3.  
  4. package HTTP::Response;
  5.  
  6.  
  7. =head1 NAME
  8.  
  9. HTTP::Response - Class encapsulating HTTP Responses
  10.  
  11. =head1 SYNOPSIS
  12.  
  13.  require HTTP::Response;
  14.  
  15. =head1 DESCRIPTION
  16.  
  17. The C<HTTP::Response> class encapsulate HTTP style responses.  A
  18. response consist of a response line, some headers, and a (potential
  19. empty) content. Note that the LWP library will use HTTP style
  20. responses also for non-HTTP protocol schemes.
  21.  
  22. Instances of this class are usually created and returned by the
  23. C<request()> method of an C<LWP::UserAgent> object:
  24.  
  25.  #...
  26.  $response = $ua->request($request)
  27.  if ($response->is_success) {
  28.      print $response->content;
  29.  } else {
  30.      print $response->error_as_HTML;
  31.  }
  32.  
  33. C<HTTP::Response> is a subclass of C<HTTP::Message> and therefore
  34. inherits its methods.  The inherited methods often used are header(),
  35. push_header(), remove_header(), headers_as_string(), and content().
  36. The header convenience methods are also available.  See
  37. L<HTTP::Message> for details.
  38.  
  39. The following additional methods are available:
  40.  
  41. =over 4
  42.  
  43. =cut
  44.  
  45.  
  46. require HTTP::Message;
  47. @ISA = qw(HTTP::Message);
  48.  
  49. use HTTP::Status ();
  50. use URI::URL ();
  51. use strict;
  52.  
  53.  
  54. =item $r = HTTP::Response->new($rc, [$msg, [$header, [$content]]])
  55.  
  56. Constructs a new C<HTTP::Response> object describing a response with
  57. response code C<$rc> and optional message C<$msg>.  The message is a
  58. short human readable single line string that explains the response
  59. code.
  60.  
  61. =cut
  62.  
  63. sub new
  64. {
  65.     my($class, $rc, $msg, $header, $content) = @_;
  66.     my $self = $class->SUPER::new($header, $content);
  67.     $self->code($rc);
  68.     $self->message($msg);
  69.     $self;
  70. }
  71.  
  72.  
  73. sub clone
  74. {
  75.     my $self = shift;
  76.     my $clone = bless $self->SUPER::clone, ref($self);
  77.     $clone->code($self->code);
  78.     $clone->message($self->message);
  79.     $clone->request($self->request->clone) if $self->request;
  80.     # we don't clone previous
  81.     $clone;
  82. }
  83.  
  84. =item $r->code([$code])
  85.  
  86. =item $r->message([$message])
  87.  
  88. =item $r->request([$request])
  89.  
  90. =item $r->previous([$previousResponse])
  91.  
  92. These methods provide public access to the member variables.  The
  93. first two containing respectively the response code and the message
  94. of the response.
  95.  
  96. The request attribute is a reference the request that gave this
  97. response.  It does not have to be the same request as passed to the
  98. $ua->request() method, because there might have been redirects and
  99. authorization retries in between.
  100.  
  101. The previous attribute is used to link together chains of responses.
  102. You get chains of responses if the first response is redirect or
  103. unauthorized.
  104.  
  105. =cut
  106.  
  107. sub code      { shift->_elem('_rc',      @_); }
  108. sub message   { shift->_elem('_msg',     @_); }
  109. sub previous  { shift->_elem('_previous',@_); }
  110. sub request   { shift->_elem('_request', @_); }
  111.  
  112. =item $r->status_line
  113.  
  114. Returns the string "E<lt>code> E<lt>message>".  If the message attribute
  115. is not set then the official name of E<lt>code> (see L<HTTP::Status>)
  116. is substituted.
  117.  
  118. =cut
  119.  
  120. sub status_line
  121. {
  122.     my $self = shift;
  123.     my $code = $self->{'_rc'}  || "000";
  124.     my $mess = $self->{'_msg'} || HTTP::Status::status_message($code) || "?";
  125.     return "$code $mess";
  126. }
  127.  
  128. =item $r->base
  129.  
  130. Returns the base URL for this response.  The return value will be a
  131. reference to a URI::URL object.
  132.  
  133. The base URL is obtained from one the following sources (in priority
  134. order):
  135.  
  136. =over 4
  137.  
  138. =item 1.
  139.  
  140. Embedded in the document content, for instance <BASE HREF="...">
  141. in HTML documents.
  142.  
  143. =item 2.
  144.  
  145. A "Content-Base:" or a "Content-Location:" header in the response.
  146.  
  147. For backwards compatability with older HTTP implementations we will
  148. also look for the "Base:" header.
  149.  
  150.  
  151. =item 3.
  152.  
  153. The URL used to request this response. This might not be the original
  154. URL that was passed to $ua->request() method, because we might have
  155. received some redirect responses first.
  156.  
  157. =back
  158.  
  159. When the LWP protocol modules produce the HTTP::Response object, then
  160. any base URL embedded in the document (step 1) will already have
  161. initialized the "Content-Base:" header. This means that this method
  162. only perform the last 2 steps (the content is not always available
  163. either).
  164.  
  165. =cut
  166.  
  167. sub base
  168. {
  169.     my $self = shift;
  170.     my $base = $self->header('Content-Base')     ||  # HTTP/1.1
  171.                $self->header('Content-Location') ||  # HTTP/1.1
  172.                $self->header('Base')             ||  # backwards compatability HTTP/1.0
  173.                $self->request->url;
  174.     $base = URI::URL->new($base) unless ref $base;
  175.     $base;
  176. }
  177.  
  178.  
  179. =item $r->as_string
  180.  
  181. Method returning a textual representation of the response.  Mainly
  182. useful for debugging purposes. It takes no arguments.
  183.  
  184. =cut
  185.  
  186. sub as_string
  187. {
  188.     require HTTP::Status;
  189.     my $self = shift;
  190.     my @result;
  191.     #push(@result, "---- $self ----");
  192.     my $code = $self->code;
  193.     my $status_message = HTTP::Status::status_message($code) || "Unknown code";
  194.     my $message = $self->message || "";
  195.  
  196.     my $status_line = "$code";
  197.     my $proto = $self->protocol;
  198.     $status_line = "$proto $status_line" if $proto;
  199.     $status_line .= " ($status_message)" if $status_message ne $message;
  200.     $status_line .= " $message";
  201.     push(@result, $status_line);
  202.     push(@result, $self->headers_as_string);
  203.     my $content = $self->content;
  204.     if (defined $content) {
  205.     push(@result, $content);
  206.     }
  207.     #push(@result, ("-" x 40));
  208.     join("\n", @result, "");
  209. }
  210.  
  211. =item $r->is_info
  212.  
  213. =item $r->is_success
  214.  
  215. =item $r->is_redirect
  216.  
  217. =item $r->is_error
  218.  
  219. These methods indicate if the response was informational, sucessful, a
  220. redirection, or an error.
  221.  
  222. =cut
  223.  
  224. sub is_info     { HTTP::Status::is_info     (shift->{'_rc'}); }
  225. sub is_success  { HTTP::Status::is_success  (shift->{'_rc'}); }
  226. sub is_redirect { HTTP::Status::is_redirect (shift->{'_rc'}); }
  227. sub is_error    { HTTP::Status::is_error    (shift->{'_rc'}); }
  228.  
  229.  
  230. =item $r->error_as_HTML()
  231.  
  232. Return a string containing a complete HTML document indicating what
  233. error occurred.  This method should only be called when $r->is_error
  234. is TRUE.
  235.  
  236. =cut
  237.  
  238. sub error_as_HTML
  239. {
  240.     my $self = shift;
  241.     my $title = 'An Error Occurred';
  242.     my $body  = $self->status_line;
  243.     return <<EOM;
  244. <HTML>
  245. <HEAD><TITLE>$title</TITLE></HEAD>
  246. <BODY>
  247. <H1>$title</h1>
  248. $body
  249. </BODY>
  250. </HTML>
  251. EOM
  252. }
  253.  
  254.  
  255. =item $r->current_age
  256.  
  257. This function will calculate the "current age" of the response as
  258. specified by E<lt>draft-ietf-http-v11-spec-07> section 13.2.3.  The
  259. age of a response is the time since it was sent by the origin server.
  260. The returned value is a number representing the age in seconds.
  261.  
  262. =cut
  263.  
  264. sub current_age
  265. {
  266.     my $self = shift;
  267.     # Implementation of <draft-ietf-http-v11-spec-07> section 13.2.3
  268.     # (age calculations)
  269.     my $response_time = $self->client_date;
  270.     my $date = $self->date;
  271.  
  272.     my $age = 0;
  273.     if ($response_time && $date) {
  274.     $age = $response_time - $date;  # apparent_age
  275.     $age = 0 if $age < 0;
  276.     }
  277.  
  278.     my $age_v = $self->header('Age');
  279.     if ($age_v && $age_v > $age) {
  280.     $age = $age_v;   # corrected_received_age
  281.     }
  282.  
  283.     my $request = $self->request;
  284.     if ($request) {
  285.     my $request_time = $request->date;
  286.     if ($request_time) {
  287.         # Add response_delay to age to get 'corrected_initial_age'
  288.         $age += $response_time - $request_time;
  289.     }
  290.     }
  291.     if ($response_time) {
  292.     $age += time - $response_time;
  293.     }
  294.     return $age;
  295. }
  296.  
  297.  
  298. =item $r->freshness_lifetime
  299.  
  300. This function will calculate the "freshness lifetime" of the response
  301. as specified by E<lt>draft-ietf-http-v11-spec-07> section 13.2.4.  The
  302. "freshness lifetime" is the length of time between the generation of a
  303. response and its expiration time.  The returned value is a number
  304. representing the freshness lifetime in seconds.
  305.  
  306. If the response does not contain an "Expires" or a "Cache-Control"
  307. header, then this function will apply some simple heuristic based on
  308. 'Last-Modified' to determine a suitable lifetime.
  309.  
  310. =cut
  311.  
  312. sub freshness_lifetime
  313. {
  314.     my $self = shift;
  315.  
  316.     # First look for the Cache-Control: max-age=n header
  317.     my @cc = $self->header('Cache-Control');
  318.     if (@cc) {
  319.     my $cc;
  320.     for $cc (@cc) {
  321.         my $cc_dir;
  322.         for $cc_dir (split(/\s*,\s*/, $cc)) {
  323.         if ($cc_dir =~ /max-age\s*=\s*(\d+)/i) {
  324.             return $1;
  325.         }
  326.         }
  327.     }
  328.     }
  329.  
  330.     # Next possibility is to look at the "Expires" header
  331.     my $date = $self->date || $self->client_date || time;      
  332.     my $expires = $self->expires;
  333.     unless ($expires) {
  334.     # Must apply heuristic expiration
  335.     my $last_modified = $self->last_modified;
  336.     if ($last_modified) {
  337.         my $h_exp = ($date - $last_modified) * 0.10;  # 10% since last-mod
  338.         if ($h_exp < 60) {
  339.         return 60;  # minimum
  340.         } elsif ($h_exp > 24 * 3600) {
  341.         # Should give a warning if more than 24 hours according to
  342.         # <draft-ietf-http-v11-spec-07> section 13.2.4, but I don't
  343.         # know how to do it from this function interface, so I just
  344.         # make this the maximum value.
  345.         return 24 * 3600;
  346.         }
  347.         return $h_exp;
  348.     } else {
  349.         return 3600;  # 1 hour is fallback when all else fails
  350.     }
  351.     }
  352.     return $expires - $date;
  353. }
  354.  
  355.  
  356. =item $r->is_fresh
  357.  
  358. Returns TRUE if the response is fresh, based on the values of
  359. freshness_lifetime() and current_age().  If the response is not longer
  360. fresh, then it has to be refetched or revalidated by the origin
  361. server.
  362.  
  363. =cut
  364.  
  365. sub is_fresh
  366. {
  367.     my $self = shift;
  368.     $self->freshness_lifetime > $self->current_age;
  369. }
  370.  
  371.  
  372. =item $r->fresh_until
  373.  
  374. Returns the time when this entiy is no longer fresh.
  375.  
  376. =cut
  377.  
  378. sub fresh_until
  379. {
  380.     my $self = shift;
  381.     return $self->freshness_lifetime - $self->current_age + time;
  382. }
  383.  
  384. 1;
  385.  
  386. =back 
  387.  
  388. =head1 COPYRIGHT
  389.  
  390. Copyright 1995-1997 Gisle Aas.
  391.  
  392. This library is free software; you can redistribute it and/or
  393. modify it under the same terms as Perl itself.
  394.  
  395. =cut
  396.