Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

Switch compression/decompression to use the IO::Compress/IO::Uncompre…

…ss and Compress::Raw::Zlib family of modules.

Related error messages now provide more information for diagnosing
occurred compression/decompression problems.
  • Loading branch information...
commit 4157e9f0ced80abb0f72c25f557cc055c9cb23ad 1 parent 6dc00de
@scop scop authored gisle committed
View
7 Makefile.PL
@@ -46,7 +46,12 @@ WriteMakefile(
'HTML::Tagset' => 0,
'HTML::Parser' => "3.33",
'Digest::MD5' => 0,
- 'Compress::Zlib' => "1.10",
+ 'Compress::Raw::Zlib' => 0,
+ 'IO::Compress::Gzip' => 0,
+ 'IO::Compress::Deflate' => 0,
+ 'IO::Uncompress::Gunzip' => 0,
+ 'IO::Uncompress::Inflate' => 0,
+ 'IO::Uncompress::RawInflate' => 0,
},
META_MERGE => {
recommends => {
View
138 lib/HTTP/Message.pm
@@ -301,83 +301,41 @@ sub decoded_content
next unless $ce;
next if $ce eq "identity";
if ($ce eq "gzip" || $ce eq "x-gzip") {
- require Compress::Zlib;
- unless ($content_ref_iscopy) {
- # memGunzip is documented to destroy its buffer argument
- my $copy = $$content_ref;
- $content_ref = \$copy;
- $content_ref_iscopy++;
- }
- $content_ref = \Compress::Zlib::memGunzip($$content_ref);
- die "Can't gunzip content" unless defined $$content_ref;
+ require IO::Uncompress::Gunzip;
+ my $output;
+ IO::Uncompress::Gunzip::gunzip($content_ref, \$output, Transparent => 0)
+ or die "Can't gunzip content: $IO::Uncompress::Gunzip::GunzipError";
+ $content_ref = \$output;
+ $content_ref_iscopy++;
}
elsif ($ce eq "x-bzip2") {
- require Compress::Bzip2;
- my $i = Compress::Bzip2::bzinflateInit() or
- die "Can't init bzip2 inflater: $Compress::Bzip2::bzerrno";
- unless ($content_ref_iscopy) {
- # the $i->bzinflate method is documented to destroy its
- # buffer argument
- my $copy = $$content_ref;
- $content_ref = \$copy;
- $content_ref_iscopy++;
- }
- # TODO: operate on the ref when rt#48124 is fixed
- my ($out, $status) = $i->bzinflate($$content_ref);
- my $bzerr = "";
- # TODO: drop $out definedness part when rt#48124 is fixed
- if (!defined($out) &&
- $status != Compress::Bzip2::BZ_STREAM_END()) {
- if ($status == Compress::Bzip2::BZ_OK()) {
- $self->push_header("Client-Warning" =>
- "Content might be truncated; incomplete bzip2 stream");
- }
- else {
- # something went bad, can't trust $out any more
- $out = undef;
- # $bzerrno has more info than $i->bzerror or $status
- $bzerr = ": $Compress::Bzip2::bzerrno";
- }
- }
- die "Can't bunzip content$bzerr" unless defined $out;
- $content_ref = \$out;
+ require IO::Uncompress::Bunzip2;
+ my $output;
+ IO::Uncompress::Bunzip2::bunzip2($content_ref, \$output, Transparent => 0)
+ or die "Can't bunzip content: $IO::Uncompress::Bunzip2::Bunzip2Error";
+ $content_ref = \$output;
$content_ref_iscopy++;
}
elsif ($ce eq "deflate") {
- require Compress::Zlib;
- my $out = Compress::Zlib::uncompress($$content_ref);
- unless (defined $out) {
- # "Content-Encoding: deflate" is supposed to mean the "zlib"
- # format of RFC 1950, but Microsoft got that wrong, so some
- # servers sends the raw compressed "deflate" data. This
- # tries to inflate this format.
- unless ($content_ref_iscopy) {
- # the $i->inflate method is documented to destroy its
- # buffer argument
- my $copy = $$content_ref;
- $content_ref = \$copy;
- $content_ref_iscopy++;
- }
-
- my($i, $status) = Compress::Zlib::inflateInit(
- WindowBits => -Compress::Zlib::MAX_WBITS(),
- );
- my $OK = Compress::Zlib::Z_OK();
- die "Can't init inflate object" unless $i && $status == $OK;
- ($out, $status) = $i->inflate($content_ref);
- if ($status != Compress::Zlib::Z_STREAM_END()) {
- if ($status == $OK) {
- $self->push_header("Client-Warning" =>
- "Content might be truncated; incomplete deflate stream");
- }
- else {
- # something went bad, can't trust $out any more
- $out = undef;
- }
+ require IO::Uncompress::Inflate;
+ my $output;
+ my $status = IO::Uncompress::Inflate::inflate($content_ref, \$output, Transparent => 0);
+ my $error = $IO::Uncompress::Inflate::InflateError;
+ unless ($status) {
+ # "Content-Encoding: deflate" is supposed to mean the
+ # "zlib" format of RFC 1950, but Microsoft got that
+ # wrong, so some servers sends the raw compressed
+ # "deflate" data. This tries to inflate this format.
+ $output = undef;
+ require IO::Uncompress::RawInflate;
+ unless (IO::Uncompress::RawInflate::rawinflate($content_ref, \$output)) {
+ $self->push_header("Client-Warning" =>
+ "Could not raw inflate content: $IO::Uncompress::RawInflate::RawInflateError");
+ $output = undef;
}
}
- die "Can't inflate content" unless defined $out;
- $content_ref = \$out;
+ die "Can't inflate content: $error" unless defined $output;
+ $content_ref = \$output;
$content_ref_iscopy++;
}
elsif ($ce eq "compress" || $ce eq "x-compress") {
@@ -440,11 +398,16 @@ sub decodable
# XXX preferably we should determine if the modules are available without loading
# them here
eval {
- require Compress::Zlib;
- push(@enc, "gzip", "x-gzip", "deflate");
+ require IO::Uncompress::Gunzip;
+ push(@enc, "gzip", "x-gzip");
+ };
+ eval {
+ require IO::Uncompress::Inflate;
+ require IO::Uncompress::RawInflate;
+ push(@enc, "deflate");
};
eval {
- require Compress::Bzip2;
+ require IO::Uncompress::Bunzip2;
push(@enc, "x-bzip2");
};
# we don't care about announcing the 'identity', 'base64' and
@@ -485,24 +448,25 @@ sub encode
$content = MIME::Base64::encode($content);
}
elsif ($encoding eq "gzip" || $encoding eq "x-gzip") {
- require Compress::Zlib;
- $content = Compress::Zlib::memGzip($content);
+ require IO::Compress::Gzip;
+ my $output;
+ IO::Compress::Gzip::gzip(\$content, \$output, Minimal => 1)
+ or die "Can't gzip content: $IO::Compress::Gzip::GzipError";
+ $content = $output;
}
elsif ($encoding eq "deflate") {
- require Compress::Zlib;
- $content = Compress::Zlib::compress($content);
+ require IO::Compress::Deflate;
+ my $output;
+ IO::Compress::Deflate::deflate(\$content, \$output)
+ or die "Can't deflate content: $IO::Compress::Deflate::DeflateError";
+ $content = $output;
}
elsif ($encoding eq "x-bzip2") {
- require Compress::Bzip2;
- my $d = Compress::Bzip2::bzdeflateInit() or
- die "Can't init bzip2 deflater: $Compress::Bzip2::bzerrno";
- ($content, my $status) = $d->bzdeflate($content);
- die "Can't bzip content: $Compress::Bzip2::bzerrno"
- unless $status == Compress::Bzip2::BZ_OK();
- (my $rest, $status) = $d->bzclose;
- die "Can't bzip content: $Compress::Bzip2::bzerrno"
- unless $status == Compress::Bzip2::BZ_OK();
- $content .= $rest if defined $rest;
+ require IO::Compress::Bzip2;
+ my $output;
+ IO::Compress::Bzip2::bzip2(\$content, \$output)
+ or die "Can't bzip2 content: $IO::Compress::Bzip2::Bzip2Error";
+ $content = $output;
}
elsif ($encoding eq "rot13") { # for the fun of it
$content =~ tr/A-Za-z/N-ZA-Mn-za-m/;
View
6 lib/Net/HTTP.pm
@@ -110,9 +110,9 @@ and C<peer_http_version> attributes.
Get/set the a value indicating if the request will be sent with a "TE"
header to indicate the transfer encodings that the server can choose to
-use. If the C<Compress::Zlib> module is installed then this will
-announce that this client accepts both the I<deflate> and I<gzip>
-encodings.
+use. The list of encodings announced as accepted by this client depends
+on availability of the following modules: C<Compress::Raw::Zlib> for
+I<deflate>, and C<IO::Compress::Gunzip> for I<gzip>.
=item $s->http_version
View
60 lib/Net/HTTP/Methods.pm
@@ -162,8 +162,8 @@ sub format_request {
if ($given{te}) {
push(@connection, "TE") unless grep lc($_) eq "te", @connection;
}
- elsif ($self->send_te && zlib_ok()) {
- # gzip is less wanted since the Compress::Zlib interface for
+ elsif ($self->send_te && gunzip_ok()) {
+ # gzip is less wanted since the IO::Uncompress::Gunzip interface for
# it does not really allow chunked decoding to take place easily.
push(@h2, "TE: deflate,gzip;q=0.3");
push(@connection, "TE");
@@ -417,19 +417,23 @@ sub read_entity_body {
unless pop(@te) eq "chunked";
for (@te) {
- if ($_ eq "deflate" && zlib_ok()) {
- #require Compress::Zlib;
- my $i = Compress::Zlib::inflateInit();
- die "Can't make inflator" unless $i;
- $_ = sub { scalar($i->inflate($_[0])) }
+ if ($_ eq "deflate" && inflate_ok()) {
+ #require Compress::Raw::Zlib;
+ my ($i, $status) = Compress::Raw::Zlib::Inflate->new();
+ die "Can't make inflator: $status" unless $i;
+ $_ = sub { my $out; $i->inflate($_[0], \$out); $out }
}
- elsif ($_ eq "gzip" && zlib_ok()) {
- #require Compress::Zlib;
+ elsif ($_ eq "gzip" && gunzip_ok()) {
+ #require IO::Uncompress::Gunzip;
my @buf;
$_ = sub {
push(@buf, $_[0]);
- return Compress::Zlib::memGunzip(join("", @buf)) if $_[1];
- return "";
+ return "" unless $_[1];
+ my $input = join("", @buf);
+ my $output;
+ IO::Uncompress::Gunzip::gunzip(\$input, \$output, Transparent => 0)
+ or die "Can't gunzip content: $IO::Uncompress::Gunzip::GunzipError";
+ return \$output;
};
}
elsif ($_ eq "identity") {
@@ -549,23 +553,39 @@ sub get_trailers {
}
BEGIN {
-my $zlib_ok;
+my $gunzip_ok;
+my $inflate_ok;
-sub zlib_ok {
- return $zlib_ok if defined $zlib_ok;
+sub gunzip_ok {
+ return $gunzip_ok if defined $gunzip_ok;
- # Try to load Compress::Zlib.
+ # Try to load IO::Uncompress::Gunzip.
local $@;
local $SIG{__DIE__};
- $zlib_ok = 0;
+ $gunzip_ok = 0;
eval {
- require Compress::Zlib;
- Compress::Zlib->VERSION(1.10);
- $zlib_ok++;
+ require IO::Uncompress::Gunzip;
+ $gunzip_ok++;
};
- return $zlib_ok;
+ return $gunzip_ok;
+}
+
+sub inflate_ok {
+ return $inflate_ok if defined $inflate_ok;
+
+ # Try to load Compress::Raw::Zlib.
+ local $@;
+ local $SIG{__DIE__};
+ $inflate_ok = 0;
+
+ eval {
+ require Compress::Raw::Zlib;
+ $inflate_ok++;
+ };
+
+ return $inflate_ok;
}
} # BEGIN
View
32 t/base/message.t
@@ -469,19 +469,8 @@ $m = HTTP::Message->new([
ok($m->decoded_content, "Hello World!");
ok(!$m->header("Client-Warning"));
-if (eval "require Compress::Bzip2") {
- $m = HTTP::Message->new([
- "Content-Type" => "text/plain",
- ],
- "Hello world!"
- );
- ok($m->encode("x-bzip2"));
- ok($m->header("Content-Encoding"), "x-bzip2");
- ok($m->content =~ /^BZh.*\0/);
- ok($m->decoded_content, "Hello world!");
- ok($m->decode);
- ok($m->content, "Hello world!");
+if (eval "require IO::Uncompress::Bunzip2") {
$m = HTTP::Message->new([
"Content-Type" => "text/plain",
"Content-Encoding" => "x-bzip2, base64",
@@ -491,7 +480,24 @@ if (eval "require Compress::Bzip2") {
ok($m->decoded_content, "Hello world!\n");
ok($m->decode);
ok($m->content, "Hello world!\n");
+
+ if (eval "require IO::Compress::Bzip2") {
+ $m = HTTP::Message->new([
+ "Content-Type" => "text/plain",
+ ],
+ "Hello world!"
+ );
+ ok($m->encode("x-bzip2"));
+ ok($m->header("Content-Encoding"), "x-bzip2");
+ ok($m->content =~ /^BZh.*\0/);
+ ok($m->decoded_content, "Hello world!");
+ ok($m->decode);
+ ok($m->content, "Hello world!");
+ }
+ else {
+ skip("Need IO::Compress::Bzip2", undef) for 1..6;
+ }
}
else {
- skip("Need Compress::Bzip2", undef) for 1..9;
+ skip("Need IO::Uncompress::Bunzip2", undef) for 1..9;
}
View
2  t/base/request.t
@@ -13,7 +13,7 @@ $req->accept_decodable;
ok($req->method, "GET");
ok($req->uri, "http://www.example.com");
-ok($req->header("Accept-Encoding") =~ /\bgzip\b/); # assuming Compress::Zlib is there
+ok($req->header("Accept-Encoding") =~ /\bgzip\b/); # assuming IO::Uncompress::Gunzip is there
$req->dump(prefix => "# ");
Please sign in to comment.
Something went wrong with that request. Please try again.