initial commit

.gitignore

@@ -0,0 +1,5 @@
+META.yml
+Makefile
+inc/
+pm_to_blib
+*~

.shipit

@@ -0,0 +1,2 @@
+steps = FindVersion, ChangeVersion, CheckChangeLog, DistTest, Commit, Tag, MakeDist, UploadCPAN
+git.push_to = origin

Changes

@@ -0,0 +1,4 @@
+Revision history for Perl extension Plack::Middleware::Deflater
+
+0.01  Sun Nov 29 13:31:48 2009
+        - original version

MANIFEST

@@ -0,0 +1,32 @@
+.gitignore
+Changes
+inc/Module/Install.pm
+inc/Module/Install/AuthorTests.pm
+inc/Module/Install/Base.pm
+inc/Module/Install/Can.pm
+inc/Module/Install/Fetch.pm
+inc/Module/Install/Include.pm
+inc/Module/Install/Makefile.pm
+inc/Module/Install/Metadata.pm
+inc/Module/Install/ReadmeFromPod.pm
+inc/Module/Install/Repository.pm
+inc/Module/Install/TestBase.pm
+inc/Module/Install/Win32.pm
+inc/Module/Install/WriteAll.pm
+inc/Spiffy.pm
+inc/Test/Base.pm
+inc/Test/Base/Filter.pm
+inc/Test/Builder.pm
+inc/Test/Builder/Module.pm
+inc/Test/More.pm
+lib/Plack/Middleware/Deflater.pm
+Makefile.PL
+MANIFEST			This list of files
+META.yml
+README
+t/00_compile.t
+t/deflater.t
+xt/perlcritic.t
+xt/pod.t
+xt/podspell.t
+xt/synopsis.t

MANIFEST.SKIP

@@ -0,0 +1,14 @@
+\bRCS\b
+\bCVS\b
+\.svn/
+\.git/
+^MANIFEST\.
+^Makefile$
+~$
+\.old$
+^blib/
+^pm_to_blib
+^MakeMaker-\d
+\.gz$
+\.cvsignore
+\.shipit

Makefile.PL

@@ -0,0 +1,13 @@
+use inc::Module::Install;
+name 'Plack-Middleware-Deflater';
+all_from 'lib/Plack/Middleware/Deflater.pm';
+readme_from 'lib/Plack/Middleware/Deflater.pm';
+build_requires 'Test::More';
+requires 'Plack';
+requires 'IO::Compress::Gzip';
+requires 'IO::Compress::Deflate';
+use_test_base;
+auto_include_deps;
+author_tests('xt');
+auto_set_repository;
+WriteAll;

README

@@ -0,0 +1,27 @@
+NAME
+    Plack::Middleware::Deflater - Compress response body with Gzip or
+    Deflate
+
+SYNOPSIS
+      enable "Deflater";
+
+DESCRIPTION
+    Plack::Middleware::Deflater is a middleware to encode your response body
+    in gzip or deflate, based on "Accept-Encoding" HTTP request header. It
+    would save the bandwidth a little bit but should increase the Plack
+    server load, so ideally you should handle this on the frontend reverse
+    proxy servers.
+
+    This middleware removes "Content-Length" and streams encoded content,
+    which means the server should support HTTP/1.1 chunked response or
+    downgrade to HTTP/1.0 and closes the connection.
+
+LICENSE
+    This software is licensed under the same terms as Perl itself.
+
+AUTHOR
+    Tatsuhiko Miyagawa
+
+SEE ALSO
+    Plack
+

lib/Plack/Middleware/Deflater.pm

@@ -0,0 +1,113 @@
+package Plack::Middleware::Deflater;
+use strict;
+use 5.008001;
+use parent qw(Plack::Middleware);
+
+use IO::Compress::Deflate;
+use IO::Compress::Gzip;
+use Plack::Util;
+
+sub call {
+    my($self, $env) = @_;
+
+    my $res = $self->app->($env);
+
+    $self->response_cb($res, sub {
+        my $res = shift;
+
+        # do not support streaming response
+        return unless defined $res->[2];
+
+        my $h = Plack::Util::headers($res->[1]);
+        if (Plack::Util::status_with_no_entity_body($res->[0]) or
+            $h->exists('Cache-Control') && $h->get('Cache-Control') =~ /\bno-transform\b/) {
+            return;
+        }
+
+        # TODO check quality
+        my $encoding = 'identity';
+        for my $enc (qw(gzip deflate identity)) {
+            if ($env->{HTTP_ACCEPT_ENCODING} =~ /\b$enc\b/) {
+                $encoding = $enc;
+                last;
+            }
+        }
+
+        my @vary = split /\s*,\s*/, ($h->get('Vary') || '');
+        push @vary, 'Accept-Encoding';
+        $h->set('Vary' => join(",", @vary));
+
+        my $encoder;
+        if ($encoding eq 'gzip') {
+            $encoder = sub { IO::Compress::Gzip->new($_[0]) };
+        } elsif ($encoding eq 'deflate') {
+            $encoder = sub { IO::Compress::Deflate->new($_[0]) };
+        } elsif ($encoding ne 'identity') {
+            my $msg = "An acceptable encoding for the requested resource is not found.";
+            @$res = (406, ['Content-Type' => 'text/plain'], [ $msg ]);
+            return;
+        }
+
+        if ($encoder) {
+            $h->set('Content-Encoding' => $encoding);
+            $h->remove('Content-Length');
+            my($done, $buf);
+            my $compress = $encoder->(\$buf);
+            return sub {
+                my $chunk = shift;
+                return if $done;
+                unless (defined $chunk) {
+                    $done = 1;
+                    $compress->flush;
+                    return $buf;
+                }
+                $compress->print($chunk);
+                if (defined $buf) {
+                    my $body = $buf;
+                    $buf = undef;
+                    return $body;
+                } else {
+                    return '';
+                }
+            };
+        }
+    });
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Plack::Middleware::Deflater - Compress response body with Gzip or Deflate
+
+=head1 SYNOPSIS
+
+  enable "Deflater";
+
+=head1 DESCRIPTION
+
+Plack::Middleware::Deflater is a middleware to encode your response
+body in gzip or deflate, based on C<Accept-Encoding> HTTP request
+header. It would save the bandwidth a little bit but should increase
+the Plack server load, so ideally you should handle this on the
+frontend reverse proxy servers.
+
+This middleware removes C<Content-Length> and streams encoded content,
+which means the server should support HTTP/1.1 chunked response or
+downgrade to HTTP/1.0 and closes the connection.
+
+=head1 LICENSE
+
+This software is licensed under the same terms as Perl itself.
+
+=head1 AUTHOR
+
+Tatsuhiko Miyagawa
+
+=head1 SEE ALSO
+
+L<Plack>
+
+=cut

t/00_compile.t

@@ -0,0 +1,4 @@
+use strict;
+use Test::More tests => 1;
+
+BEGIN { use_ok 'Plack::Middleware::Deflater' }

t/deflater.t

@@ -0,0 +1,35 @@
+use strict;
+use Test::More;
+use Test::Requires qw(IO::Handle::Util);
+use IO::Handle::Util qw(:io_from);
+use HTTP::Request::Common;
+use Plack::Test;
+use Plack::Middleware::Deflater;
+$Plack::Test::Impl = "Server";
+
+my @app = (
+    sub { [ 200, [], [ 'Hello World' ] ] },
+    sub { [ 200, [], [ 'Hello ', 'World' ] ] },
+    sub { [ 200, [], [ 'Hello ', '', 'World' ] ] },
+    sub { [ 200, [], io_from_array [ 'Hello World' ] ] },
+    sub { [ 200, [], io_from_array [ 'Hello', ' World' ] ] },
+    sub { [ 200, [], io_from_array [ 'Hello', '', ' World' ] ] },
+);
+
+my $app = sub { (shift @app)->(@_) };
+
+test_psgi app => Plack::Middleware::Deflater->wrap($app), client => sub {
+    my $cb = shift;
+
+    no warnings;
+    local *HTTP::Request::decodable = sub { wantarray ? ('gzip') : 'gzip' };
+    for (0..$#app) {
+        my $req = GET "http://localhost/";
+        $req->accept_decodable;
+        my $res = $cb->($req);
+        is $res->decoded_content, 'Hello World';
+        is $res->content_encoding, 'gzip';
+    }
+};
+
+done_testing;

xt/perlcritic.t

@@ -0,0 +1,5 @@
+use strict;
+use Test::More;
+eval q{ use Test::Perl::Critic };
+plan skip_all => "Test::Perl::Critic is not installed." if $@;
+all_critic_ok("lib");

xt/pod.t

@@ -0,0 +1,4 @@
+use Test::More;
+eval "use Test::Pod 1.00";
+plan skip_all => "Test::Pod 1.00 required for testing POD" if $@;
+all_pod_files_ok();

xt/podspell.t

@@ -0,0 +1,9 @@
+use Test::More;
+eval q{ use Test::Spelling };
+plan skip_all => "Test::Spelling is not installed." if $@;
+add_stopwords(<DATA>);
+set_spell_cmd("aspell -l en list");
+all_pod_files_spelling_ok('lib');
+__DATA__
+Tatsuhiko
+Miyagawa

xt/synopsis.t

@@ -0,0 +1,4 @@
+use Test::More;
+eval "use Test::Synopsis";
+plan skip_all => "Test::Synopsis required" if $@;
+all_synopsis_ok();