package HTTP::Response;
require HTTP::Message;
@ISA = qw(HTTP::Message);
$VERSION = "5.824";
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 redirects {
my $self = shift;
my @r;
my $r = $self;
while (my $p = $r->previous) {
push(@r, $p);
$r = $p;
}
return @r unless wantarray;
return reverse @r;
}
sub filename
{
my $self = shift;
my $file;
my $cd = $self->header('Content-Disposition');
if ($cd) {
require HTTP::Headers::Util;
if (my @cd = HTTP::Headers::Util::split_header_words($cd)) {
my ($disposition, undef, %cd_param) = @{$cd[-1]};
$file = $cd_param{filename};
# RFC 2047 encoded?
if ($file && $file =~ /^=\?(.+?)\?(.+?)\?(.+)\?=$/) {
my $charset = $1;
my $encoding = uc($2);
my $encfile = $3;
if ($encoding eq 'Q' || $encoding eq 'B') {
local($SIG{__DIE__});
eval {
if ($encoding eq 'Q') {
$encfile =~ s/_/ /g;
require MIME::QuotedPrint;
$encfile = MIME::QuotedPrint::decode($encfile);
}
else { # $encoding eq 'B'
require MIME::Base64;
$encfile = MIME::Base64::decode($encfile);
}
require Encode;
require encoding;
# This is ugly use of non-public API, but is there
# a better way to accomplish what we want (locally
# as-is usable filename string)?
my $locale_charset = encoding::_get_locale_encoding();
Encode::from_to($encfile, $charset, $locale_charset);
};
$file = $encfile unless $@;
}
}
}
}
my $uri;
unless (defined($file) && length($file)) {
if (my $cl = $self->header('Content-Location')) {
$uri = URI->new($cl);
}
elsif (my $request = $self->request) {
$uri = $request->uri;
}
if ($uri) {
$file = ($uri->path_segments)[-1];
}
}
if ($file) {
$file =~ s,.*[\\/],,; # basename
}
if ($file && !length($file)) {
$file = undef;
}
$file;
}
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 dump
{
my $self = shift;
my $status_line = $self->status_line;
my $proto = $self->protocol;
$status_line = "$proto $status_line" if $proto;
return $self->SUPER::dump(
preheader => $status_line,
@_,
);
}
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
{
require HTML::Entities;
my $self = shift;
my $title = 'An Error Occurred';
my $body = HTML::Entities::encode($self->status_line);
return <
$title
$title
$body