Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse code

initial commit

  • Loading branch information...
commit 3739932dbb85b71036273f189bbb39e998a6087c 0 parents
Tatsuhiko Miyagawa authored
5 .gitignore
... ... @@ -0,0 +1,5 @@
  1 +META.yml
  2 +Makefile
  3 +inc/
  4 +pm_to_blib
  5 +*~
2  .shipit
... ... @@ -0,0 +1,2 @@
  1 +steps = FindVersion, ChangeVersion, CheckChangeLog, DistTest, Commit, Tag, MakeDist, UploadCPAN
  2 +git.push_to = origin
4 Changes
... ... @@ -0,0 +1,4 @@
  1 +Revision history for Perl extension Maypole::PSGI
  2 +
  3 +0.01 Thu Oct 1 00:47:58 2009
  4 + - original version
31 MANIFEST
... ... @@ -0,0 +1,31 @@
  1 +.gitignore
  2 +Changes
  3 +inc/Module/Install.pm
  4 +inc/Module/Install/AuthorTests.pm
  5 +inc/Module/Install/Base.pm
  6 +inc/Module/Install/Can.pm
  7 +inc/Module/Install/Fetch.pm
  8 +inc/Module/Install/Include.pm
  9 +inc/Module/Install/Makefile.pm
  10 +inc/Module/Install/Metadata.pm
  11 +inc/Module/Install/ReadmeFromPod.pm
  12 +inc/Module/Install/Repository.pm
  13 +inc/Module/Install/TestBase.pm
  14 +inc/Module/Install/Win32.pm
  15 +inc/Module/Install/WriteAll.pm
  16 +inc/Spiffy.pm
  17 +inc/Test/Base.pm
  18 +inc/Test/Base/Filter.pm
  19 +inc/Test/Builder.pm
  20 +inc/Test/Builder/Module.pm
  21 +inc/Test/More.pm
  22 +lib/Maypole/PSGI.pm
  23 +Makefile.PL
  24 +MANIFEST This list of files
  25 +META.yml
  26 +README
  27 +t/00_compile.t
  28 +xt/perlcritic.t
  29 +xt/pod.t
  30 +xt/podspell.t
  31 +xt/synopsis.t
14 MANIFEST.SKIP
... ... @@ -0,0 +1,14 @@
  1 +\bRCS\b
  2 +\bCVS\b
  3 +\.svn/
  4 +\.git/
  5 +^MANIFEST\.
  6 +^Makefile$
  7 +~$
  8 +\.old$
  9 +^blib/
  10 +^pm_to_blib
  11 +^MakeMaker-\d
  12 +\.gz$
  13 +\.cvsignore
  14 +\.shipit
10 Makefile.PL
... ... @@ -0,0 +1,10 @@
  1 +use inc::Module::Install;
  2 +name 'Maypole-PSGI';
  3 +all_from 'lib/Maypole/PSGI.pm';
  4 +readme_from 'lib/Maypole/PSGI.pm';
  5 +build_requires 'Test::More';
  6 +use_test_base;
  7 +auto_include_deps;
  8 +author_tests('xt');
  9 +auto_set_repository;
  10 +WriteAll;
17 README
... ... @@ -0,0 +1,17 @@
  1 +NAME
  2 + Maypole::PSGI -
  3 +
  4 +SYNOPSIS
  5 + use Maypole::PSGI;
  6 +
  7 +DESCRIPTION
  8 + Maypole::PSGI is
  9 +
  10 +AUTHOR
  11 + Tatsuhiko Miyagawa <miyagawa@bulknews.net>
  12 +
  13 +LICENSE
  14 + This library is free software; you can redistribute it and/or modify it
  15 + under the same terms as Perl itself.
  16 +
  17 +SEE ALSO
136 lib/Maypole/PSGI.pm
... ... @@ -0,0 +1,136 @@
  1 +package Maypole::PSGI;
  2 +
  3 +use strict;
  4 +use 5.008_001;
  5 +our $VERSION = '0.01';
  6 +
  7 +package Maypole::PSGI;
  8 +use UNIVERSAL::require;
  9 +
  10 +sub run {
  11 + my($class, $module, $env) = @_;
  12 +
  13 + $module->require or die "Couldn't load $module: $@";
  14 +
  15 + # Horrible HACK: Maypole::Application doesn't allow me to hook
  16 + # which class to inherit from: Change that here.
  17 + no strict 'refs';
  18 + for (@{"$module\::ISA"}) {
  19 + $_ = "Maypole::PSGI::Application" if $_ eq 'CGI::Maypole';
  20 + }
  21 +
  22 + $module->run_psgi($env);
  23 +}
  24 +
  25 +package Maypole::PSGI::Application;
  26 +use base qw( CGI::Maypole );
  27 +
  28 +use CGI::PSGI;
  29 +use Maypole::Constants;
  30 +
  31 +sub get_request {
  32 + my($self, $env) = @_;
  33 + $self->cgi(CGI::PSGI->new($env));
  34 +}
  35 +
  36 +sub run_psgi {
  37 + my $class = shift;
  38 + my($status, $res) = $class->handler(@_);
  39 +
  40 + if ($status != OK) {
  41 + return [ 500, [ 'Content-Type' => 'text/html' ], [ 'Maypole Application Error' ] ];
  42 + }
  43 +
  44 + return $res;
  45 +}
  46 +
  47 +# Maypole doesn't allow me to get headers and content separately.
  48 +# HTTPD::Frontend's way to use package vars is not thread/event-loop safe
  49 +# So, just copy that :/
  50 +sub handler : method {
  51 + my ($class, $req) = @_;
  52 + $class->init unless $class->init_done;
  53 +
  54 + my $self = $class->new;
  55 +
  56 + # initialise the request
  57 + $self->headers_out(Maypole::Headers->new);
  58 + $self->get_request($req);
  59 +
  60 + $self->parse_location;
  61 +
  62 + # hook useful for declining static requests e.g. images, or perhaps for
  63 + # sanitizing request parameters
  64 + $self->status(Maypole::Constants::OK());
  65 + # set the default
  66 + $self->__call_hook('start_request_hook');
  67 + return $self->status unless $self->status == Maypole::Constants::OK();
  68 + die "status undefined after start_request_hook()" unless defined
  69 + $self->status;
  70 +
  71 + my $session = $self->get_session;
  72 + $self->session($self->{session} || $session);
  73 + my $user = $self->get_user;
  74 + $self->user($self->{user} || $user);
  75 +
  76 + my $status = $self->handler_guts;
  77 + return $status unless $status == OK;
  78 +
  79 + # copied from collect_output()
  80 + my %headers = (
  81 + -type => $self->content_type,
  82 + -charset => $self->document_encoding,
  83 + -content_length => do { use bytes;
  84 + length $self->output },
  85 + );
  86 +
  87 + foreach ($self->headers_out->field_names) {
  88 + next if /^Content-(Type|Length)/;
  89 + $headers{"-$_"} = $self->headers_out->get($_);
  90 + }
  91 +
  92 + return $status, [ $self->cgi->psgi_header(%headers), [ $self->output ] ];
  93 +}
  94 +
  95 +package Maypole::PSGI;
  96 +
  97 +1;
  98 +__END__
  99 +
  100 +=encoding utf-8
  101 +
  102 +=for stopwords
  103 +
  104 +=head1 NAME
  105 +
  106 +Maypole::PSGI - Runs Maypole application as PSGI application
  107 +
  108 +=head1 SYNOPSIS
  109 +
  110 + # in app.psgi
  111 + use BeerDB;
  112 + use Maypole::PSGI;
  113 +
  114 + my $handler = sub { Maypole::PSGI->run('BeerDB', @_) };
  115 +
  116 +=head1 DESCRIPTION
  117 +
  118 +Maypole::PSGI is an Maypole adapter to run Maypole application on any
  119 +PSGI server. It uses L<CGI::PSGI> and then wrap CGI::Maypole and does
  120 +some really wacky hack to adapt Maypole's hardcoded dispatcher list,
  121 +but it works :)
  122 +
  123 +=head1 AUTHOR
  124 +
  125 +Tatsuhiko Miyagawa E<lt>miyagawa@bulknews.netE<gt>
  126 +
  127 +=head1 LICENSE
  128 +
  129 +This library is free software; you can redistribute it and/or modify
  130 +it under the same terms as Perl itself.
  131 +
  132 +=head1 SEE ALSO
  133 +
  134 +L<Maypole> L<CGI::PSGI>
  135 +
  136 +=cut
4 t/00_compile.t
... ... @@ -0,0 +1,4 @@
  1 +use strict;
  2 +use Test::More tests => 1;
  3 +
  4 +BEGIN { use_ok 'Maypole::PSGI' }
5 xt/perlcritic.t
... ... @@ -0,0 +1,5 @@
  1 +use strict;
  2 +use Test::More;
  3 +eval q{ use Test::Perl::Critic };
  4 +plan skip_all => "Test::Perl::Critic is not installed." if $@;
  5 +all_critic_ok("lib");
4 xt/pod.t
... ... @@ -0,0 +1,4 @@
  1 +use Test::More;
  2 +eval "use Test::Pod 1.00";
  3 +plan skip_all => "Test::Pod 1.00 required for testing POD" if $@;
  4 +all_pod_files_ok();
9 xt/podspell.t
... ... @@ -0,0 +1,9 @@
  1 +use Test::More;
  2 +eval q{ use Test::Spelling };
  3 +plan skip_all => "Test::Spelling is not installed." if $@;
  4 +add_stopwords(<DATA>);
  5 +set_spell_cmd("aspell -l en list");
  6 +all_pod_files_spelling_ok('lib');
  7 +__DATA__
  8 +Tatsuhiko
  9 +Miyagawa
4 xt/synopsis.t
... ... @@ -0,0 +1,4 @@
  1 +use Test::More;
  2 +eval "use Test::Synopsis";
  3 +plan skip_all => "Test::Synopsis required" if $@;
  4 +all_synopsis_ok();

0 comments on commit 3739932

Please sign in to comment.
Something went wrong with that request. Please try again.