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