Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

initial commit

  • Loading branch information...
commit 3739932dbb85b71036273f189bbb39e998a6087c 0 parents
@miyagawa authored
5 .gitignore
@@ -0,0 +1,5 @@
+META.yml
+Makefile
+inc/
+pm_to_blib
+*~
2  .shipit
@@ -0,0 +1,2 @@
+steps = FindVersion, ChangeVersion, CheckChangeLog, DistTest, Commit, Tag, MakeDist, UploadCPAN
+git.push_to = origin
4 Changes
@@ -0,0 +1,4 @@
+Revision history for Perl extension Maypole::PSGI
+
+0.01 Thu Oct 1 00:47:58 2009
+ - original version
31 MANIFEST
@@ -0,0 +1,31 @@
+.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/Maypole/PSGI.pm
+Makefile.PL
+MANIFEST This list of files
+META.yml
+README
+t/00_compile.t
+xt/perlcritic.t
+xt/pod.t
+xt/podspell.t
+xt/synopsis.t
14 MANIFEST.SKIP
@@ -0,0 +1,14 @@
+\bRCS\b
+\bCVS\b
+\.svn/
+\.git/
+^MANIFEST\.
+^Makefile$
+~$
+\.old$
+^blib/
+^pm_to_blib
+^MakeMaker-\d
+\.gz$
+\.cvsignore
+\.shipit
10 Makefile.PL
@@ -0,0 +1,10 @@
+use inc::Module::Install;
+name 'Maypole-PSGI';
+all_from 'lib/Maypole/PSGI.pm';
+readme_from 'lib/Maypole/PSGI.pm';
+build_requires 'Test::More';
+use_test_base;
+auto_include_deps;
+author_tests('xt');
+auto_set_repository;
+WriteAll;
17 README
@@ -0,0 +1,17 @@
+NAME
+ Maypole::PSGI -
+
+SYNOPSIS
+ use Maypole::PSGI;
+
+DESCRIPTION
+ Maypole::PSGI is
+
+AUTHOR
+ Tatsuhiko Miyagawa <miyagawa@bulknews.net>
+
+LICENSE
+ This library is free software; you can redistribute it and/or modify it
+ under the same terms as Perl itself.
+
+SEE ALSO
136 lib/Maypole/PSGI.pm
@@ -0,0 +1,136 @@
+package Maypole::PSGI;
+
+use strict;
+use 5.008_001;
+our $VERSION = '0.01';
+
+package Maypole::PSGI;
+use UNIVERSAL::require;
+
+sub run {
+ my($class, $module, $env) = @_;
+
+ $module->require or die "Couldn't load $module: $@";
+
+ # Horrible HACK: Maypole::Application doesn't allow me to hook
+ # which class to inherit from: Change that here.
+ no strict 'refs';
+ for (@{"$module\::ISA"}) {
+ $_ = "Maypole::PSGI::Application" if $_ eq 'CGI::Maypole';
+ }
+
+ $module->run_psgi($env);
+}
+
+package Maypole::PSGI::Application;
+use base qw( CGI::Maypole );
+
+use CGI::PSGI;
+use Maypole::Constants;
+
+sub get_request {
+ my($self, $env) = @_;
+ $self->cgi(CGI::PSGI->new($env));
+}
+
+sub run_psgi {
+ my $class = shift;
+ my($status, $res) = $class->handler(@_);
+
+ if ($status != OK) {
+ return [ 500, [ 'Content-Type' => 'text/html' ], [ 'Maypole Application Error' ] ];
+ }
+
+ return $res;
+}
+
+# Maypole doesn't allow me to get headers and content separately.
+# HTTPD::Frontend's way to use package vars is not thread/event-loop safe
+# So, just copy that :/
+sub handler : method {
+ my ($class, $req) = @_;
+ $class->init unless $class->init_done;
+
+ my $self = $class->new;
+
+ # initialise the request
+ $self->headers_out(Maypole::Headers->new);
+ $self->get_request($req);
+
+ $self->parse_location;
+
+ # hook useful for declining static requests e.g. images, or perhaps for
+ # sanitizing request parameters
+ $self->status(Maypole::Constants::OK());
+ # set the default
+ $self->__call_hook('start_request_hook');
+ return $self->status unless $self->status == Maypole::Constants::OK();
+ die "status undefined after start_request_hook()" unless defined
+ $self->status;
+
+ my $session = $self->get_session;
+ $self->session($self->{session} || $session);
+ my $user = $self->get_user;
+ $self->user($self->{user} || $user);
+
+ my $status = $self->handler_guts;
+ return $status unless $status == OK;
+
+ # copied from collect_output()
+ my %headers = (
+ -type => $self->content_type,
+ -charset => $self->document_encoding,
+ -content_length => do { use bytes;
+ length $self->output },
+ );
+
+ foreach ($self->headers_out->field_names) {
+ next if /^Content-(Type|Length)/;
+ $headers{"-$_"} = $self->headers_out->get($_);
+ }
+
+ return $status, [ $self->cgi->psgi_header(%headers), [ $self->output ] ];
+}
+
+package Maypole::PSGI;
+
+1;
+__END__
+
+=encoding utf-8
+
+=for stopwords
+
+=head1 NAME
+
+Maypole::PSGI - Runs Maypole application as PSGI application
+
+=head1 SYNOPSIS
+
+ # in app.psgi
+ use BeerDB;
+ use Maypole::PSGI;
+
+ my $handler = sub { Maypole::PSGI->run('BeerDB', @_) };
+
+=head1 DESCRIPTION
+
+Maypole::PSGI is an Maypole adapter to run Maypole application on any
+PSGI server. It uses L<CGI::PSGI> and then wrap CGI::Maypole and does
+some really wacky hack to adapt Maypole's hardcoded dispatcher list,
+but it works :)
+
+=head1 AUTHOR
+
+Tatsuhiko Miyagawa E<lt>miyagawa@bulknews.netE<gt>
+
+=head1 LICENSE
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=head1 SEE ALSO
+
+L<Maypole> L<CGI::PSGI>
+
+=cut
4 t/00_compile.t
@@ -0,0 +1,4 @@
+use strict;
+use Test::More tests => 1;
+
+BEGIN { use_ok 'Maypole::PSGI' }
5 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");
4 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();
9 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
4 xt/synopsis.t
@@ -0,0 +1,4 @@
+use Test::More;
+eval "use Test::Synopsis";
+plan skip_all => "Test::Synopsis required" if $@;
+all_synopsis_ok();
Please sign in to comment.
Something went wrong with that request. Please try again.