Skip to content

Commit

Permalink
Browse files Browse the repository at this point in the history
added native PSGI support
  • Loading branch information
kraih committed Dec 16, 2009
1 parent b9c9035 commit 3e569a7
Show file tree
Hide file tree
Showing 3 changed files with 181 additions and 0 deletions.
1 change: 1 addition & 0 deletions Changes
Expand Up @@ -3,6 +3,7 @@ This file documents the revision history for Perl extension Mojo.
0.999915 2009-12-10 00:00:00
- Added routes captures to params in Mojolicious.
- Added charset plugin to Mojolicious. (charsbar)
- Added native PSGI support.
- Made param decoding more defensive and allow malformed data to pass
through for debugging.
- Fixed a case where an ending tag would be interpreted as a line
Expand Down
127 changes: 127 additions & 0 deletions lib/Mojo/Server/PSGI.pm
@@ -0,0 +1,127 @@
# Copyright (C) 2008-2009, Sebastian Riedel.

package Mojo::Server::PSGI;

use strict;
use warnings;

use base 'Mojo::Server';
use bytes;

use constant CHUNK_SIZE => $ENV{MOJO_CHUNK_SIZE} || 4096;

# Things aren't as happy as they used to be down here at the unemployment
# office.
# Joblessness is no longer just for philosophy majors.
# Useful people are starting to feel the pinch.
sub run {
my ($self, $env) = @_;

my $tx = $self->build_tx_cb->($self);
my $req = $tx->req;

# Environment
$req->parse($env);

# Store connection information
$tx->remote_address($env->{REMOTE_ADDR});
$tx->local_port($env->{SERVER_PORT});

# Request body
while (!$req->is_finished) {
my $read = $env->{'psgi.input'}->read(my $buffer, CHUNK_SIZE, 0);
last if $read == 0;
$req->parse($buffer);
}

# Handle
$self->handler_cb->($self, $tx);

my $res = $tx->res;

# Status
my $status = $res->code;

# Response headers
$res->fix_headers;
my $headers = $res->content->headers;
my @headers;
for my $name (@{$headers->names}) {
for my $value ($headers->header($name)) {
push @headers, $name => $value;
}
}

# Response body
my $body = Mojo::Server::PSGI::Handle->new(res => $res);

return [$status, \@headers, $body];
}

package Mojo::Server::PSGI::Handle;

use strict;
use warnings;

use base 'Mojo::Base';

__PACKAGE__->attr(offset => 0);
__PACKAGE__->attr('res');

sub close { }

sub getline {
my $self = shift;

# Blocking read
my $offset = $self->offset;
while (1) {
my $chunk = $self->res->get_body_chunk($offset);

# No content yet, try again
unless (defined $chunk) {
sleep 1;
next;
}

# End of content
last unless length $chunk;

# Content
$offset += length $chunk;
$self->offset($offset);
return $chunk;
}

return;
}

1;
__END__
=head1 NAME
Mojo::Server::PSGI - PSGI Server
=head1 SYNOPSIS
# myapp.psgi
use Mojo::Server::PSGI;
my $psgi = Mojo::Server::PSGI->new->app_class('MyApp');
my $app = sub { $psgi->run(@_) };
=head1 DESCRIPTION
L<Mojo::Server::PSGI> allows L<Mojo> applications to run on all PSGI
compatible servers.
=head1 METHODS
L<Mojo::Server::PSGI> inherits all methods from L<Mojo::Server> and
implements the following new ones.
=head2 C<run>
$psgi->run;
=cut
53 changes: 53 additions & 0 deletions t/mojo/psgi.t
@@ -0,0 +1,53 @@
#!/usr/bin/env perl

# Copyright (C) 2008-2009, Sebastian Riedel.

use strict;
use warnings;

use Test::More tests => 11;

use_ok('Mojo::Server::PSGI');

# We need some more secret sauce. Put the mayonnaise in the sun.
my $psgi = Mojo::Server::PSGI->new;
my $app = sub { $psgi->run(@_) };

# Request
my $content = 'hello=world';
open my $body, '<', \$content;
my $env = {
CONTENT_LENGTH => 11,
CONTENT_TYPE => 'application/x-www-form-urlencoded',
PATH_INFO => '/diag/dump_params',
QUERY_STRING => 'lalala=23&bar=baz',
REQUEST_METHOD => 'POST',
SCRIPT_NAME => '/',
HTTP_HOST => 'localhost:8080',
SERVER_PROTOCOL => 'HTTP/1.0',
'psgi.version' => [1, 0],
'psgi.url_scheme' => 'http',
'psgi.input' => $body,
'psgi.errors' => *STDERR,
'psgi.multithread' => 0,
'psgi.multiprocess' => 1,
'psgi.run_once' => 0
};

# Process
my $res = $app->($env);

# Response
is($res->[0], 200);
is($res->[1]->[0], 'Date');
ok($res->[1]->[1]->[0]);
is($res->[1]->[2], 'Content-Length');
is($res->[1]->[3]->[0], 104);
is($res->[1]->[4], 'Content-Type');
is($res->[1]->[5]->[0], 'text/plain');
is($res->[1]->[6], 'X-Powered-By');
is($res->[1]->[7]->[0], 'Mojo (Perl)');
my $params = '';
while (defined(my $chunk = $res->[2]->getline)) { $params .= $chunk }
$params = eval "my $params";
is_deeply($params, {bar => 'baz', hello => 'world', lalala => 23});

0 comments on commit 3e569a7

Please sign in to comment.