use strict;
use File::Spec;
use Text::MultiMarkdown 'markdown';
sub {
my $env = shift;
my $file = File::Spec->catfile(
File::Spec->curdir, $env->{PATH_INFO});
open my $fh, '<', $file or die "Failed to open $file: $!";
[
200,
[ "Content-Type" => 'text/html; charset=utf-8' ],
[
<<EOM,
<html>
<head>
<style type="text/css">
<!--
body {
font-family: Halvetica, sans-serif;
padding-left: 2em;
}
pre { padding-left: 2em }
-->
</style>
</head>
<body>
EOM
markdown(do { local $/; <$fh> }),
<<EOM,
</body>
</html>
EOM
]
]
};
use strict;
use Test::More;
local $ENV{ANY_MOOSE} = 'Moose';
my @files = ;
plan tests => scalar @files + 1;
while (my $file = shift @files) {
subtest $file => sub { do $file };
}
ok( Any::Moose::moose_is_preferred() );
package Lyra::Server::Worker;
use Moose;
use Router::Simple;
use JSON::XS;
use namespace::autoclean;
use constant NO_SUCH_WORKER =>
[ 404, [ "Content-Type" => "application/json" ],
[ q|{ "status" => 0, "message" => "no such worker" }| ] ];
use constant BAD_PAYLOAD =>
[ 500, [ "Content-Type" => "application/json" ],
[ q|{ "status" => 0, "message" => "bad payload" }| ] ];
use constant WORKER_ERROR =>
[ 500, [ "Content-Type" => "application/json" ],
[ q|{ "status" => 0, "message" => "worker error" }| ] ];
use constant WORKER_SUCCESS =>
[ 200, [ "Content-Type" => "application/json" ],
[ q|{ "status" => 1 }| ] ];
has router => (
is => 'ro',
isa => 'Router::Simple',
default => sub { Router::Simple->new() }
);
sub register {
my ($self, $path, $worker, $method) = @_;
$method ||= 'process';
$self->router->connect( $path, { controller => $worker, action => $method } );
}
sub psgi_app {
my $self = shift;
return sub {
$self->process(@_);
}
}
sub process {
my ($self, $env) = @_;
my $matched = $self->router->match( $env );
if (! $matched) {
return NO_SUCH_WORKER;
}
my $payload;
eval {
$payload = $self->fetch_payload( $env );
};
if ($@) {
warn $@;
return BAD_PAYLOAD;
}
my $response;
eval {
my $worker = $matched->{controller};
my $method = $matched->{action};
$response = $worker->$method( $payload );
};
if ($@) {
warn $@;
return WORKER_ERROR;
}
if (! $response ) {
$response = WORKER_SUCCESS;
}
return $response;
}
sub fetch_payload {
my ($self, $env) = @_;
if ($env->{REQUEST_METHOD} ne 'POST') {
return;
}
my $cl = $env->{ CONTENT_LENGTH };
my $ct = $env->{ CONTENT_TYPE };
# $ct should be application/json, but we're not checking this right now
my $input = $env->{ 'psgi.input' };
# Just in case if input is read by middleware/apps beforehand
$input->seek(0, 0);
my $buffer = '';
my $spin = 0;
while ($cl > 0) {
$input->read(my $chunk, $cl < 8192 ? $cl : 8192);
my $read = length $chunk;
$cl -= $read;
$buffer .= $chunk;
if ($read == 0 && $spin++ > 2000) {
Carp::croak "Bad Content-Length: maybe client disconnect? ($cl bytes remaining)";
}
}
decode_json $buffer;
}
__PACKAGE__->meta->make_immutable();
1;
Comparing with buffer size 10...
Rate normal aio
normal 80.0/s -- -19%
aio 99.0/s 24% --
Comparing with buffer size 100...
Rate normal aio
normal 80.0/s -- -18%
aio 97.1/s 21% --
Comparing with buffer size 1000...
Rate normal aio
normal 76.9/s -- -13%
aio 88.5/s 15% --
Comparing with buffer size 10000...
Rate normal aio
normal 52.4/s -- -27%
aio 71.9/s 37% --
Comparing with buffer size 100000...
Rate normal aio
normal 15.9/s -- -63%
aio 42.7/s 169% --
http://twitter.com/miyagawa/status/10271128928
plackup \
-L Shotgun
-MPlack::App::WrapCGI
-e 'Plack::App::WrapCGI->new(script => "/path/to/cgiscript.cgi")'
だそうです！これなら全ての要件を満たせるもよう！そしてapp.psgiを作る必要ありません。
use strict;
use CGI::Emulate::PSGI;
return CGI::Emulate::PSGI->handler(sub {
CGI::initialize_globals(); # 重要
# ここから
#!/usr/bin/env perl
use strict;
use warnings;
use CGI;
use CGI::Carp qw(fatalsToBrowser);
sub main {
my $q = CGI->new();
....
}
main();
# ここまでがCGIのコード
});
plackup -r -a app.psgi
use strict;
use LWP::UserAgent;
my $base = 110764722;
my $ua = LWP::UserAgent->new();
my $i = $base;
while(1) {
my $res = $ua->head("http://twitter.com/lestrrat/statuses/$i");
if ($res->is_success) {
print "http://twitter.com/lestrrat/statuses/$i\n";
}
$i++;
}
sub r{@_?(pop,r(@_)):()};
sub myreverse {
if (@_ > 0) {
return (pop @_, myreverse(@_));
} else {
return ();
}
}
