📄 response.pm
字号:
package HTTP::Response;# $Id: Response.pm,v 1.53 2005/12/06 13:19:09 gisle Exp $require HTTP::Message;@ISA = qw(HTTP::Message);$VERSION = sprintf("%d.%02d", q$Revision: 1.53 $ =~ /(\d+)\.(\d+)/);use strict;use HTTP::Status ();sub new{ my($class, $rc, $msg, $header, $content) = @_; my $self = $class->SUPER::new($header, $content); $self->code($rc); $self->message($msg); $self;}sub parse{ my($class, $str) = @_; my $status_line; if ($str =~ s/^(.*)\n//) { $status_line = $1; } else { $status_line = $str; $str = ""; } my $self = $class->SUPER::parse($str); my($protocol, $code, $message); if ($status_line =~ /^\d{3} /) { # Looks like a response created by HTTP::Response->new ($code, $message) = split(' ', $status_line, 2); } else { ($protocol, $code, $message) = split(' ', $status_line, 3); } $self->protocol($protocol) if $protocol; $self->code($code) if defined($code); $self->message($message) if defined($message); $self;}sub clone{ my $self = shift; my $clone = bless $self->SUPER::clone, ref($self); $clone->code($self->code); $clone->message($self->message); $clone->request($self->request->clone) if $self->request; # we don't clone previous $clone;}sub code { shift->_elem('_rc', @_); }sub message { shift->_elem('_msg', @_); }sub previous { shift->_elem('_previous',@_); }sub request { shift->_elem('_request', @_); }sub status_line{ my $self = shift; my $code = $self->{'_rc'} || "000"; my $mess = $self->{'_msg'} || HTTP::Status::status_message($code) || "Unknown code"; return "$code $mess";}sub base{ my $self = shift; my $base = $self->header('Content-Base') || # used to be HTTP/1.1 $self->header('Content-Location') || # HTTP/1.1 $self->header('Base'); # HTTP/1.0 if ($base && $base =~ /^$URI::scheme_re:/o) { # already absolute return $HTTP::URI_CLASS->new($base); } my $req = $self->request; if ($req) { # if $base is undef here, the return value is effectively # just a copy of $self->request->uri. return $HTTP::URI_CLASS->new_abs($base, $req->uri); } # can't find an absolute base return undef;}sub as_string{ require HTTP::Status; my $self = shift; my($eol) = @_; $eol = "\n" unless defined $eol; my $status_line = $self->status_line; my $proto = $self->protocol; $status_line = "$proto $status_line" if $proto; return join($eol, $status_line, $self->SUPER::as_string(@_));}sub is_info { HTTP::Status::is_info (shift->{'_rc'}); }sub is_success { HTTP::Status::is_success (shift->{'_rc'}); }sub is_redirect { HTTP::Status::is_redirect (shift->{'_rc'}); }sub is_error { HTTP::Status::is_error (shift->{'_rc'}); }sub error_as_HTML{ my $self = shift; my $title = 'An Error Occurred'; my $body = $self->status_line; return <<EOM;<HTML><HEAD><TITLE>$title</TITLE></HEAD><BODY><H1>$title</H1>$body</BODY></HTML>EOM}sub current_age{ my $self = shift; # Implementation of RFC 2616 section 13.2.3 # (age calculations) my $response_time = $self->client_date; my $date = $self->date; my $age = 0; if ($response_time && $date) { $age = $response_time - $date; # apparent_age $age = 0 if $age < 0; } my $age_v = $self->header('Age'); if ($age_v && $age_v > $age) { $age = $age_v; # corrected_received_age } my $request = $self->request; if ($request) { my $request_time = $request->date; if ($request_time) { # Add response_delay to age to get 'corrected_initial_age' $age += $response_time - $request_time; } } if ($response_time) { $age += time - $response_time; } return $age;}sub freshness_lifetime{ my $self = shift; # First look for the Cache-Control: max-age=n header my @cc = $self->header('Cache-Control'); if (@cc) { my $cc; for $cc (@cc) { my $cc_dir; for $cc_dir (split(/\s*,\s*/, $cc)) { if ($cc_dir =~ /max-age\s*=\s*(\d+)/i) { return $1; } } } } # Next possibility is to look at the "Expires" header my $date = $self->date || $self->client_date || time; my $expires = $self->expires; unless ($expires) { # Must apply heuristic expiration my $last_modified = $self->last_modified; if ($last_modified) { my $h_exp = ($date - $last_modified) * 0.10; # 10% since last-mod if ($h_exp < 60) { return 60; # minimum } elsif ($h_exp > 24 * 3600) { # Should give a warning if more than 24 hours according to # RFC 2616 section 13.2.4, but I don't know how to do it # from this function interface, so I just make this the # maximum value. return 24 * 3600; } return $h_exp; } else { return 3600; # 1 hour is fallback when all else fails } } return $expires - $date;}sub is_fresh{ my $self = shift; $self->freshness_lifetime > $self->current_age;}sub fresh_until{ my $self = shift; return $self->freshness_lifetime - $self->current_age + time;}1;__END__=head1 NAMEHTTP::Response - HTTP style response message=head1 SYNOPSISResponse objects are returned by the request() method of the C<LWP::UserAgent>: # ... $response = $ua->request($request) if ($response->is_success) { print $response->content; } else { print STDERR $response->status_line, "\n"; }=head1 DESCRIPTIONThe C<HTTP::Response> class encapsulates HTTP style responses. Aresponse consists of a response line, some headers, and a contentbody. Note that the LWP library uses HTTP style responses even fornon-HTTP protocol schemes. Instances of this class are usuallycreated and returned by the request() method of an C<LWP::UserAgent>object.C<HTTP::Response> is a subclass of C<HTTP::Message> and thereforeinherits its methods. The following additional methods are available:=over 4=item $r = HTTP::Response->new( $code )=item $r = HTTP::Response->new( $code, $msg )=item $r = HTTP::Response->new( $code, $msg, $header )=item $r = HTTP::Response->new( $code, $msg, $header, $content )Constructs a new C<HTTP::Response> object describing a response withresponse code $code and optional message $msg. The optional $headerargument should be a reference to an C<HTTP::Headers> object or aplain array reference of key/value pairs. The optional $contentargument should be a string of bytes. The meaning these arguments aredescribed below.=item $r = HTTP::Response->parse( $str )This constructs a new response object by parsing the given string.=item $r->code=item $r->code( $code )This is used to get/set the code attribute. The code is a 3 digitnumber that encode the overall outcome of a HTTP response. TheC<HTTP::Status> module provide constants that provide mnemonic namesfor the code attribute.=item $r->message=item $r->message( $message )This is used to get/set the message attribute. The message is a shorthuman readable single line string that explains the response code.=item $r->header( $field )=item $r->header( $field => $value )This is used to get/set header values and it is inherited fromC<HTTP::Headers> via C<HTTP::Message>. See L<HTTP::Headers> fordetails and other similar methods that can be used to access theheaders.=item $r->content=item $r->content( $content )This is used to get/set the raw content and it is inherited from theC<HTTP::Message> base class. See L<HTTP::Message> for details andother methods that can be used to access the content.=item $r->decoded_content( %options )This will return the content after any C<Content-Encoding> andcharsets has been decoded. See L<HTTP::Message> for details.=item $r->request=item $r->request( $request )This is used to get/set the request attribute. The request attributeis a reference to the the request that caused this response. It doesnot have to be the same request passed to the $ua->request() method,because there might have been redirects and authorization retries inbetween.=item $r->previous=item $r->previous( $response )This is used to get/set the previous attribute. The previousattribute is used to link together chains of responses. You getchains of responses if the first response is redirect or unauthorized.The value is C<undef> if this is the first response in a chain.=item $r->status_lineReturns the string "E<lt>code> E<lt>message>". If the message attributeis not set then the official name of E<lt>code> (see L<HTTP::Status>)is substituted.=item $r->baseReturns the base URI for this response. The return value will be areference to a URI object.The base URI is obtained from one the following sources (in priorityorder):=over 4=item 1.Embedded in the document content, for instance <BASE HREF="...">in HTML documents.=item 2.A "Content-Base:" or a "Content-Location:" header in the response.For backwards compatibility with older HTTP implementations we willalso look for the "Base:" header.=item 3.The URI used to request this response. This might not be the originalURI that was passed to $ua->request() method, because we might havereceived some redirect responses first.=backIf neither of these sources provide an absolute URI, undef isreturned.When the LWP protocol modules produce the HTTP::Response object, thenany base URI embedded in the document (step 1) will already haveinitialized the "Content-Base:" header. This means that this methodonly performs the last 2 steps (the content is not always availableeither).=item $r->as_string=item $r->as_string( $eol )Returns a textual representation of the response.=item $r->is_info=item $r->is_success=item $r->is_redirect=item $r->is_errorThese methods indicate if the response was informational, successful, aredirection, or an error. See L<HTTP::Status> for the meaning of these.=item $r->error_as_HTMLReturns a string containing a complete HTML document indicating whaterror occurred. This method should only be called when $r->is_erroris TRUE.=item $r->current_ageCalculates the "current age" of the response as specified by RFC 2616section 13.2.3. The age of a response is the time since it was sentby the origin server. The returned value is a number representing theage in seconds.=item $r->freshness_lifetimeCalculates the "freshness lifetime" of the response as specified byRFC 2616 section 13.2.4. The "freshness lifetime" is the length oftime between the generation of a response and its expiration time.The returned value is a number representing the freshness lifetime inseconds.If the response does not contain an "Expires" or a "Cache-Control"header, then this function will apply some simple heuristic based on'Last-Modified' to determine a suitable lifetime.=item $r->is_freshReturns TRUE if the response is fresh, based on the values offreshness_lifetime() and current_age(). If the response is no longerfresh, then it has to be refetched or revalidated by the originserver.=item $r->fresh_untilReturns the time when this entity is no longer fresh.=back=head1 SEE ALSOL<HTTP::Headers>, L<HTTP::Message>, L<HTTP::Status>, L<HTTP::Request>=head1 COPYRIGHTCopyright 1995-2004 Gisle Aas.This library is free software; you can redistribute it and/ormodify it under the same terms as Perl itself.⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -