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 f61f18854c61af9b373b99a6d1f291554763efe0 0 parents
Jiro Nishiguchi authored
0  .deps
No changes.
7 .gitignore
... ... @@ -0,0 +1,7 @@
  1 +/ppport.h
  2 +/.libs
  3 +*.la
  4 +*.lo
  5 +*.o
  6 +*.slo
  7 +/t/test.conf
202 LICENSE
... ... @@ -0,0 +1,202 @@
  1 +
  2 + Apache License
  3 + Version 2.0, January 2004
  4 + http://www.apache.org/licenses/
  5 +
  6 + TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION
  7 +
  8 + 1. Definitions.
  9 +
  10 + "License" shall mean the terms and conditions for use, reproduction,
  11 + and distribution as defined by Sections 1 through 9 of this document.
  12 +
  13 + "Licensor" shall mean the copyright owner or entity authorized by
  14 + the copyright owner that is granting the License.
  15 +
  16 + "Legal Entity" shall mean the union of the acting entity and all
  17 + other entities that control, are controlled by, or are under common
  18 + control with that entity. For the purposes of this definition,
  19 + "control" means (i) the power, direct or indirect, to cause the
  20 + direction or management of such entity, whether by contract or
  21 + otherwise, or (ii) ownership of fifty percent (50%) or more of the
  22 + outstanding shares, or (iii) beneficial ownership of such entity.
  23 +
  24 + "You" (or "Your") shall mean an individual or Legal Entity
  25 + exercising permissions granted by this License.
  26 +
  27 + "Source" form shall mean the preferred form for making modifications,
  28 + including but not limited to software source code, documentation
  29 + source, and configuration files.
  30 +
  31 + "Object" form shall mean any form resulting from mechanical
  32 + transformation or translation of a Source form, including but
  33 + not limited to compiled object code, generated documentation,
  34 + and conversions to other media types.
  35 +
  36 + "Work" shall mean the work of authorship, whether in Source or
  37 + Object form, made available under the License, as indicated by a
  38 + copyright notice that is included in or attached to the work
  39 + (an example is provided in the Appendix below).
  40 +
  41 + "Derivative Works" shall mean any work, whether in Source or Object
  42 + form, that is based on (or derived from) the Work and for which the
  43 + editorial revisions, annotations, elaborations, or other modifications
  44 + represent, as a whole, an original work of authorship. For the purposes
  45 + of this License, Derivative Works shall not include works that remain
  46 + separable from, or merely link (or bind by name) to the interfaces of,
  47 + the Work and Derivative Works thereof.
  48 +
  49 + "Contribution" shall mean any work of authorship, including
  50 + the original version of the Work and any modifications or additions
  51 + to that Work or Derivative Works thereof, that is intentionally
  52 + submitted to Licensor for inclusion in the Work by the copyright owner
  53 + or by an individual or Legal Entity authorized to submit on behalf of
  54 + the copyright owner. For the purposes of this definition, "submitted"
  55 + means any form of electronic, verbal, or written communication sent
  56 + to the Licensor or its representatives, including but not limited to
  57 + communication on electronic mailing lists, source code control systems,
  58 + and issue tracking systems that are managed by, or on behalf of, the
  59 + Licensor for the purpose of discussing and improving the Work, but
  60 + excluding communication that is conspicuously marked or otherwise
  61 + designated in writing by the copyright owner as "Not a Contribution."
  62 +
  63 + "Contributor" shall mean Licensor and any individual or Legal Entity
  64 + on behalf of whom a Contribution has been received by Licensor and
  65 + subsequently incorporated within the Work.
  66 +
  67 + 2. Grant of Copyright License. Subject to the terms and conditions of
  68 + this License, each Contributor hereby grants to You a perpetual,
  69 + worldwide, non-exclusive, no-charge, royalty-free, irrevocable
  70 + copyright license to reproduce, prepare Derivative Works of,
  71 + publicly display, publicly perform, sublicense, and distribute the
  72 + Work and such Derivative Works in Source or Object form.
  73 +
  74 + 3. Grant of Patent License. Subject to the terms and conditions of
  75 + this License, each Contributor hereby grants to You a perpetual,
  76 + worldwide, non-exclusive, no-charge, royalty-free, irrevocable
  77 + (except as stated in this section) patent license to make, have made,
  78 + use, offer to sell, sell, import, and otherwise transfer the Work,
  79 + where such license applies only to those patent claims licensable
  80 + by such Contributor that are necessarily infringed by their
  81 + Contribution(s) alone or by combination of their Contribution(s)
  82 + with the Work to which such Contribution(s) was submitted. If You
  83 + institute patent litigation against any entity (including a
  84 + cross-claim or counterclaim in a lawsuit) alleging that the Work
  85 + or a Contribution incorporated within the Work constitutes direct
  86 + or contributory patent infringement, then any patent licenses
  87 + granted to You under this License for that Work shall terminate
  88 + as of the date such litigation is filed.
  89 +
  90 + 4. Redistribution. You may reproduce and distribute copies of the
  91 + Work or Derivative Works thereof in any medium, with or without
  92 + modifications, and in Source or Object form, provided that You
  93 + meet the following conditions:
  94 +
  95 + (a) You must give any other recipients of the Work or
  96 + Derivative Works a copy of this License; and
  97 +
  98 + (b) You must cause any modified files to carry prominent notices
  99 + stating that You changed the files; and
  100 +
  101 + (c) You must retain, in the Source form of any Derivative Works
  102 + that You distribute, all copyright, patent, trademark, and
  103 + attribution notices from the Source form of the Work,
  104 + excluding those notices that do not pertain to any part of
  105 + the Derivative Works; and
  106 +
  107 + (d) If the Work includes a "NOTICE" text file as part of its
  108 + distribution, then any Derivative Works that You distribute must
  109 + include a readable copy of the attribution notices contained
  110 + within such NOTICE file, excluding those notices that do not
  111 + pertain to any part of the Derivative Works, in at least one
  112 + of the following places: within a NOTICE text file distributed
  113 + as part of the Derivative Works; within the Source form or
  114 + documentation, if provided along with the Derivative Works; or,
  115 + within a display generated by the Derivative Works, if and
  116 + wherever such third-party notices normally appear. The contents
  117 + of the NOTICE file are for informational purposes only and
  118 + do not modify the License. You may add Your own attribution
  119 + notices within Derivative Works that You distribute, alongside
  120 + or as an addendum to the NOTICE text from the Work, provided
  121 + that such additional attribution notices cannot be construed
  122 + as modifying the License.
  123 +
  124 + You may add Your own copyright statement to Your modifications and
  125 + may provide additional or different license terms and conditions
  126 + for use, reproduction, or distribution of Your modifications, or
  127 + for any such Derivative Works as a whole, provided Your use,
  128 + reproduction, and distribution of the Work otherwise complies with
  129 + the conditions stated in this License.
  130 +
  131 + 5. Submission of Contributions. Unless You explicitly state otherwise,
  132 + any Contribution intentionally submitted for inclusion in the Work
  133 + by You to the Licensor shall be under the terms and conditions of
  134 + this License, without any additional terms or conditions.
  135 + Notwithstanding the above, nothing herein shall supersede or modify
  136 + the terms of any separate license agreement you may have executed
  137 + with Licensor regarding such Contributions.
  138 +
  139 + 6. Trademarks. This License does not grant permission to use the trade
  140 + names, trademarks, service marks, or product names of the Licensor,
  141 + except as required for reasonable and customary use in describing the
  142 + origin of the Work and reproducing the content of the NOTICE file.
  143 +
  144 + 7. Disclaimer of Warranty. Unless required by applicable law or
  145 + agreed to in writing, Licensor provides the Work (and each
  146 + Contributor provides its Contributions) on an "AS IS" BASIS,
  147 + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or
  148 + implied, including, without limitation, any warranties or conditions
  149 + of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A
  150 + PARTICULAR PURPOSE. You are solely responsible for determining the
  151 + appropriateness of using or redistributing the Work and assume any
  152 + risks associated with Your exercise of permissions under this License.
  153 +
  154 + 8. Limitation of Liability. In no event and under no legal theory,
  155 + whether in tort (including negligence), contract, or otherwise,
  156 + unless required by applicable law (such as deliberate and grossly
  157 + negligent acts) or agreed to in writing, shall any Contributor be
  158 + liable to You for damages, including any direct, indirect, special,
  159 + incidental, or consequential damages of any character arising as a
  160 + result of this License or out of the use or inability to use the
  161 + Work (including but not limited to damages for loss of goodwill,
  162 + work stoppage, computer failure or malfunction, or any and all
  163 + other commercial damages or losses), even if such Contributor
  164 + has been advised of the possibility of such damages.
  165 +
  166 + 9. Accepting Warranty or Additional Liability. While redistributing
  167 + the Work or Derivative Works thereof, You may choose to offer,
  168 + and charge a fee for, acceptance of support, warranty, indemnity,
  169 + or other liability obligations and/or rights consistent with this
  170 + License. However, in accepting such obligations, You may act only
  171 + on Your own behalf and on Your sole responsibility, not on behalf
  172 + of any other Contributor, and only if You agree to indemnify,
  173 + defend, and hold each Contributor harmless for any liability
  174 + incurred by, or claims asserted against, such Contributor by reason
  175 + of your accepting any such warranty or additional liability.
  176 +
  177 + END OF TERMS AND CONDITIONS
  178 +
  179 + APPENDIX: How to apply the Apache License to your work.
  180 +
  181 + To apply the Apache License to your work, attach the following
  182 + boilerplate notice, with the fields enclosed by brackets "[]"
  183 + replaced with your own identifying information. (Don't include
  184 + the brackets!) The text should be enclosed in the appropriate
  185 + comment syntax for the file format. We also recommend that a
  186 + file or class name and description of purpose be included on the
  187 + same "printed page" as the copyright notice for easier
  188 + identification within third-party archives.
  189 +
  190 + Copyright [yyyy] [name of copyright owner]
  191 +
  192 + Licensed under the Apache License, Version 2.0 (the "License");
  193 + you may not use this file except in compliance with the License.
  194 + You may obtain a copy of the License at
  195 +
  196 + http://www.apache.org/licenses/LICENSE-2.0
  197 +
  198 + Unless required by applicable law or agreed to in writing, software
  199 + distributed under the License is distributed on an "AS IS" BASIS,
  200 + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
  201 + See the License for the specific language governing permissions and
  202 + limitations under the License.
76 Makefile
... ... @@ -0,0 +1,76 @@
  1 +##
  2 +## Makefile -- Build procedure for PSGI Apache module
  3 +## Autogenerated via ``apxs -n psgi -g''.
  4 +##
  5 +
  6 +PACKAGE_NAME=mod_psgi
  7 +PACKAGE_VERSION=0.0.1
  8 +
  9 +# the used tools
  10 +APXS=apxs
  11 +APACHECTL=apachectl
  12 +PERL=perl
  13 +
  14 +builddir=.
  15 +top_srcdir=$(shell $(APXS) -q prefix)
  16 +top_builddir=$(shell $(APXS) -q prefix)
  17 +include $(shell $(APXS) -q installbuilddir)/special.mk
  18 +
  19 +# additional defines, includes and libraries
  20 +ifdef MOD_PSGI_DEBUG
  21 +DEBUG_DEFS=-DDEBUG
  22 +else
  23 +DEBUG_DEFS=
  24 +endif
  25 +DEFS=-DMOD_PSGI_VERSION=\"$(PACKAGE_VERSION)\" $(DEBUG_DEFS)
  26 +INCLUDES=$(shell $(PERL) -MExtUtils::Embed -e ccopts)
  27 +LDFLAGS=$(shell $(PERL) -MExtUtils::Embed -e ldopts)
  28 +
  29 +# the default target
  30 +all: local-shared-build
  31 +
  32 +# install the shared object file into Apache
  33 +install: install-modules-yes
  34 +
  35 +# cleanup
  36 +clean:
  37 + -rm -f mod_psgi.o mod_psgi.lo mod_psgi.slo mod_psgi.la
  38 + rm -f ppport.h
  39 + $(MAKE) -C t clean
  40 +
  41 +mod_psgi.c: ppport.h
  42 +
  43 +ppport.h:
  44 + perl -MDevel::PPPort -e 'Devel::PPPort::WriteFile'
  45 +
  46 +testconf:
  47 + $(MAKE) -C t conf
  48 +
  49 +test: reload
  50 + $(MAKE) -C t test
  51 +
  52 +# install and activate shared object by reloading Apache to
  53 +# force a reload of the shared object file
  54 +reload: install restart
  55 +
  56 +# the general Apache start/restart/stop
  57 +# procedures
  58 +start:
  59 + $(APACHECTL) start
  60 +restart:
  61 + $(APACHECTL) restart
  62 +stop:
  63 + $(APACHECTL) stop
  64 +
  65 +DIST_DIR=$(PACKAGE_NAME)-$(PACKAGE_VERSION)
  66 +DIST_FILE=$(PACKAGE_NAME)-$(PACKAGE_VERSION).tar
  67 +dist: ppport.h
  68 + rm -f $(DIST_FILE)
  69 + git archive --format=tar --prefix=$(DIST_DIR)/ HEAD > $(DIST_FILE)
  70 + mkdir $(DIST_DIR)
  71 + cp ppport.h $(DIST_DIR)
  72 + tar rf $(DIST_FILE) $(DIST_DIR)/ppport.h
  73 + rm -fr $(DIST_DIR)
  74 + gzip --best $(DIST_FILE)
  75 +
  76 +.PHONY: testconf
39 README
... ... @@ -0,0 +1,39 @@
  1 +This is Apache2 module mod_psgi.
  2 +
  3 +* Install
  4 +
  5 + % make APX=/usr/local/apache2/bin/apx PERL=/usr/local/bin/perl
  6 + % make install
  7 +
  8 +Then activate it in Apache's httpd.conf file for instance
  9 +for the URL /psgi in as follows:
  10 +
  11 + # httpd.conf
  12 + LoadModule psgi_module modules/mod_psgi.so
  13 + <Location /psgi>
  14 + SetHandler psgi
  15 + PSGIApp /path/to/app.psgi
  16 + </Location>
  17 +
  18 +Then after restarting Apache via
  19 +
  20 + $ apachectl restart
  21 +
  22 +* Spec
  23 +
  24 + * This module works on Apache2 which is configured by '--with-mpm=prefork'.
  25 +
  26 + * PSGIApp files are loaded by 'do $file'. The file must return a code reference
  27 + that is a PSGI application.
  28 +
  29 + * The input stream ($env->{'psgi.input'}) is not seekable.
  30 + $env->{'psgi.input'}->seek($pos, $whence) raises an error.
  31 +
  32 +* License
  33 +
  34 +See the 'LICENSE' file.
  35 +
  36 +* Author
  37 +
  38 +Jiro Nishiguchi <jiro@cpan.org>
  39 +
572 mod_psgi.c
... ... @@ -0,0 +1,572 @@
  1 +/*
  2 + * Copyright 2009 Jiro Nishiguchi <jiro@cpan.org>
  3 + *
  4 + * Licensed under the Apache License, Version 2.0 (the "License");
  5 + * you may not use this file except in compliance with the License.
  6 + * You may obtain a copy of the License at
  7 + *
  8 + * http://www.apache.org/licenses/LICENSE-2.0
  9 + *
  10 + * Unless required by applicable law or agreed to in writing, software
  11 + * distributed under the License is distributed on an "AS IS" BASIS,
  12 + * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
  13 + * See the License for the specific language governing permissions and
  14 + * limitations under the License.
  15 + */
  16 +#include "httpd.h"
  17 +#include "http_log.h"
  18 +#include "http_config.h"
  19 +#include "http_protocol.h"
  20 +#include "util_script.h"
  21 +#include "ap_config.h"
  22 +#include "ap_mpm.h"
  23 +#include "apr_strings.h"
  24 +
  25 +#define PERL_NO_GET_CONTEXT
  26 +#include "EXTERN.h"
  27 +#include "perl.h"
  28 +#include "XSUB.h"
  29 +#define NEED_eval_pv
  30 +#define NEED_newRV_noinc
  31 +#define NEED_sv_2pv_flags
  32 +#include "ppport.h"
  33 +
  34 +#ifdef DEBUG
  35 +#define TRACE(...) ap_log_error(APLOG_MARK, APLOG_NOERRNO|APLOG_NOTICE, 0, NULL, __VA_ARGS__)
  36 +#endif
  37 +
  38 +module AP_MODULE_DECLARE_DATA psgi_module;
  39 +
  40 +typedef struct {
  41 + char *psgi_app;
  42 +} psgi_dir_config;
  43 +
  44 +static void server_error(request_rec *r, const char *fmt, ...)
  45 +{
  46 + va_list argp;
  47 + const char *msg;
  48 + va_start(argp, fmt);
  49 + msg = apr_pvsprintf(r->pool, fmt, argp);
  50 + va_end(argp);
  51 + ap_log_error(APLOG_MARK, APLOG_NOERRNO|APLOG_ERR, 0, r->server, "%s", msg);
  52 +}
  53 +
  54 +EXTERN_C void xs_init (pTHX);
  55 +
  56 +EXTERN_C void boot_DynaLoader (pTHX_ CV* cv);
  57 +
  58 +XS(ModPSGI_exit);
  59 +XS(ModPSGI_exit)
  60 +{
  61 + dXSARGS;
  62 + croak("exit");
  63 + XSRETURN(0);
  64 +}
  65 +
  66 +XS(ModPSGI_Input_read);
  67 +XS(ModPSGI_Input_read)
  68 +{
  69 + dXSARGS;
  70 + SV *self = ST(0);
  71 + SV *buf = ST(1);
  72 + request_rec *r = (request_rec *) mg_find(SvRV(self), PERL_MAGIC_ext)->mg_obj;
  73 + apr_size_t len = SvIV(ST(2));
  74 + apr_size_t offset = items >= 4 ? SvIV(ST(3)) : 0;
  75 + apr_status_t rv;
  76 + apr_bucket_brigade *bb;
  77 + apr_bucket *bucket;
  78 + int eos = 0;
  79 + SV *ret;
  80 + dXSTARG;
  81 +
  82 + ret = newSVpv("", 0);
  83 + bb = apr_brigade_create(r->pool, r->connection->bucket_alloc);
  84 + rv = ap_get_brigade(r->input_filters, bb, AP_MODE_READBYTES, APR_BLOCK_READ, len);
  85 + if (rv != APR_SUCCESS) {
  86 + ST(0) = &PL_sv_undef;
  87 + XSRETURN(1);
  88 + }
  89 +
  90 + for (bucket = APR_BRIGADE_FIRST(bb);
  91 + bucket != APR_BRIGADE_SENTINEL(bb);
  92 + bucket = APR_BUCKET_NEXT(bucket)) {
  93 + const char *bbuf;
  94 + apr_size_t blen;
  95 + if (APR_BUCKET_IS_EOS(bucket)) {
  96 + eos = 1;
  97 + break;
  98 + }
  99 + if (APR_BUCKET_IS_METADATA(bucket)) {
  100 + continue;
  101 + }
  102 + apr_bucket_read(bucket, &bbuf, &blen, APR_BLOCK_READ);
  103 + sv_catpvn(ret, bbuf, blen);
  104 + }
  105 +
  106 + sv_setsv(buf, ret);
  107 + ST(0) = sv_2mortal(newSViv(SvCUR(buf)));
  108 + XSRETURN(1);
  109 +}
  110 +
  111 +XS(ModPSGI_Errors_print);
  112 +XS(ModPSGI_Errors_print)
  113 +{
  114 + dXSARGS;
  115 + SV *self = ST(0);
  116 + SV *msg = ST(1);
  117 + dXSTARG;
  118 + request_rec *r = (request_rec *) mg_find(SvRV(self), PERL_MAGIC_ext)->mg_obj;
  119 + ap_log_error(APLOG_MARK, APLOG_NOERRNO|APLOG_ERR, 0, r->server, "%s", SvPV_nolen(msg));
  120 + ST(0) = newSViv(1);
  121 + XSRETURN(1);
  122 +}
  123 +
  124 +EXTERN_C void
  125 +xs_init(pTHX)
  126 +{
  127 + char *file = __FILE__;
  128 + dXSUB_SYS;
  129 +
  130 + newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);
  131 + newXS("ModPSGI::exit", ModPSGI_exit, file);
  132 + newXSproto("ModPSGI::Input::read", ModPSGI_Input_read, file, "$$$;$");
  133 + newXSproto("ModPSGI::Errors::print", ModPSGI_Errors_print, file, "$$");
  134 +}
  135 +
  136 +static int copy_env(void *rec, const char *key, const char *val)
  137 +{
  138 + HV *env = (HV *) rec;
  139 + hv_store(env, key, strlen(key), newSVpv(val, 0), 0);
  140 + return 1;
  141 +}
  142 +
  143 +static SV *make_env(request_rec *r)
  144 +{
  145 + HV *env;
  146 + AV *version;
  147 + char *url_scheme;
  148 + SV *input, *errors;
  149 +
  150 + env = newHV();
  151 +
  152 + ap_add_cgi_vars(r);
  153 + ap_add_common_vars(r);
  154 + if (apr_table_get(r->subprocess_env, "PATH_INFO") == NULL) {
  155 + apr_table_set(r->subprocess_env, "PATH_INFO", "");
  156 + }
  157 + if (strcmp(apr_table_get(r->subprocess_env, "SCRIPT_NAME"), "/") == 0
  158 + && strcmp(apr_table_get(r->subprocess_env, "PATH_INFO"), "") == 0) {
  159 + apr_table_set(r->subprocess_env, "PATH_INFO", "/");
  160 + apr_table_set(r->subprocess_env, "SCRIPT_NAME", "");
  161 + }
  162 + apr_table_do(copy_env, env, r->subprocess_env, NULL);
  163 +
  164 + version = newAV();
  165 + av_push(version, newSViv(1));
  166 + av_push(version, newSViv(0));
  167 + hv_store(env, "psgi.version", 12, newRV_inc((SV *) version), 0);
  168 +
  169 + url_scheme = apr_table_get(r->subprocess_env, "HTTPS") == NULL ? "http" : "https";
  170 + hv_store(env, "psgi.url_scheme", 15, newSVpv(url_scheme, 0), 0);
  171 +
  172 + input = newRV_noinc(newSV(0));
  173 + sv_magic(SvRV(input), NULL, PERL_MAGIC_ext, NULL, 0);
  174 + mg_find(SvRV(input), PERL_MAGIC_ext)->mg_obj = (void *) r;
  175 + sv_bless(input, gv_stashpv("ModPSGI::Input", 1));
  176 + hv_store(env, "psgi.input", 10, input, 0);
  177 +
  178 + errors = newRV_noinc(newSV(0));
  179 + sv_magic(SvRV(errors), NULL, PERL_MAGIC_ext, NULL, 0);
  180 + mg_find(SvRV(errors), PERL_MAGIC_ext)->mg_obj = (void *) r;
  181 + sv_bless(errors, gv_stashpv("ModPSGI::Errors", 1));
  182 + hv_store(env, "psgi.errors", 11, errors, 0);
  183 +
  184 + hv_store(env, "psgi.multithread", 16, newSViv(0), 0);
  185 + hv_store(env, "psgi.multiprocess", 17, newSViv(1), 0);
  186 + hv_store(env, "psgi.run_once", 13, newSViv(1), 0);
  187 + hv_store(env, "psgi.async", 10, newSViv(0), 0);
  188 +
  189 + return newRV_inc((SV *) env);
  190 +}
  191 +
  192 +static SV *load_psgi(request_rec *r, const char *file)
  193 +{
  194 + SV *app;
  195 + char *code;
  196 +
  197 + code = apr_psprintf(r->pool, "do q\"%s\" or die $@",
  198 + ap_escape_quotes(r->pool, file));
  199 + app = eval_pv(code, FALSE);
  200 +
  201 + if (SvTRUE(ERRSV)) {
  202 + server_error(r, "%s", SvPV_nolen(ERRSV));
  203 + return NULL;
  204 + }
  205 + if (!SvOK(app) || !SvROK(app) || SvTYPE(SvRV(app)) != SVt_PVCV) {
  206 + server_error(r, "%s does not return an application code reference", file);
  207 + return NULL;
  208 + }
  209 + return app;
  210 +}
  211 +
  212 +static SV *run_app(request_rec *r, SV *app, SV *env)
  213 +{
  214 + int count;
  215 + SV *res;
  216 + dSP;
  217 + ENTER;
  218 + SAVETMPS;
  219 + PUSHMARK(SP) ;
  220 + XPUSHs(sv_2mortal(env));
  221 + PUTBACK;
  222 +
  223 + count = call_sv(app, G_EVAL|G_KEEPERR|G_SCALAR);
  224 + SPAGAIN;
  225 + if (SvTRUE(ERRSV)) {
  226 + res = NULL;
  227 + server_error(r, "%s", SvPV_nolen(ERRSV));
  228 + POPs;
  229 + } else if (count > 0) {
  230 + res = POPs;
  231 + SvREFCNT_inc(res);
  232 + } else {
  233 + res = NULL;
  234 + }
  235 + PUTBACK;
  236 + FREETMPS;
  237 + LEAVE;
  238 + return res;
  239 +}
  240 +
  241 +static int output_status(request_rec *r, SV *status)
  242 +{
  243 + int s = SvIV(status);
  244 + if (s < 100) {
  245 + server_error(r, "invalid response status %d", s);
  246 + return HTTP_INTERNAL_SERVER_ERROR;
  247 + }
  248 + r->status = s;
  249 + return OK;
  250 +}
  251 +
  252 +static int check_header_value(const char *value)
  253 +{
  254 + int i;
  255 + int len = strlen(value);
  256 + for (i = 0; i < len; i++) {
  257 + if (value[i] < 37) {
  258 + return 1;
  259 + }
  260 + }
  261 + return 0;
  262 +}
  263 +
  264 +static int output_headers(request_rec *r, AV *headers)
  265 +{
  266 + SV *key_sv, *val_sv;
  267 + char *key, *val;
  268 + while (av_len(headers) > -1) {
  269 + key_sv = av_shift(headers);
  270 + val_sv = av_shift(headers);
  271 + if (key_sv == NULL || val_sv == NULL) break;
  272 + key = SvPV_nolen(key_sv);
  273 + val = SvPV_nolen(val_sv);
  274 + if (check_header_value(val) != 0) {
  275 + server_error(r, "value string must not contain characters below chr(37)");
  276 + return HTTP_INTERNAL_SERVER_ERROR;
  277 + } else if (strcmp(key, "Content-Type") == 0) {
  278 + r->content_type = apr_pstrdup(r->pool, val);
  279 + } else if (strcmp(key, "Status") == 0) {
  280 + server_error(r, "headers must not contain a Status");
  281 + return HTTP_INTERNAL_SERVER_ERROR;
  282 + } else {
  283 + apr_table_add(r->headers_out, key, val);
  284 + }
  285 + }
  286 + return OK;
  287 +}
  288 +
  289 +static int respond_to(SV *obj, const char *method)
  290 +{
  291 + int res;
  292 + dSP;
  293 + ENTER;
  294 + SAVETMPS;
  295 + PUSHMARK(SP);
  296 + XPUSHs(obj);
  297 + XPUSHs(sv_2mortal(newSVpv(method, 0)));
  298 + PUTBACK;
  299 +
  300 + call_method("can", G_SCALAR);
  301 + SPAGAIN;
  302 + res = SvROK(POPs);
  303 + PUTBACK;
  304 + FREETMPS;
  305 + LEAVE;
  306 + return res;
  307 +}
  308 +
  309 +static void set_content_length(request_rec *r, apr_off_t length)
  310 +{
  311 + if (apr_table_get(r->headers_out, "Content-Length") == NULL) {
  312 + apr_table_add(r->headers_out, "Content-Length", apr_off_t_toa(r->pool, length));
  313 + }
  314 +}
  315 +
  316 +static int output_body_ary(request_rec *r, AV *bodys)
  317 +{
  318 + SV **body;
  319 + I32 i;
  320 + I32 lastidx;
  321 + char *buf;
  322 + STRLEN len;
  323 + apr_off_t clen;
  324 +
  325 + lastidx = av_len(bodys);
  326 + for (i = 0; i <= lastidx; i++) {
  327 + body = av_fetch(bodys, i, 0);
  328 + if (SvOK(*body)) {
  329 + buf = SvPV(*body, len);
  330 + ap_rwrite(buf, len, r);
  331 + clen += len;
  332 + }
  333 + }
  334 + set_content_length(r, clen);
  335 + return OK;
  336 +}
  337 +
  338 +static int output_body_obj(request_rec *r, SV *obj, int type)
  339 +{
  340 + SV *buf_sv, *rs;
  341 + apr_off_t clen = 0;
  342 + STRLEN len;
  343 + char *buf;
  344 + int count;
  345 +
  346 + if (type == SVt_PVMG && !respond_to(obj, "getline")) {
  347 + server_error(r, "response body object must be able to getline");
  348 + return HTTP_INTERNAL_SERVER_ERROR;
  349 + }
  350 +
  351 + dSP;
  352 + ENTER;
  353 + SAVETMPS;
  354 + SAVESPTR(PL_rs);
  355 + PL_rs = newRV_inc(newSViv(AP_IOBUFSIZE));
  356 + while (1) {
  357 + PUSHMARK(SP);
  358 + XPUSHs(obj);
  359 + PUTBACK;
  360 + count = call_method("getline", G_SCALAR);
  361 + if (count != 1) croak("Big trouble\n");
  362 + SPAGAIN;
  363 + buf_sv = POPs;
  364 + if (SvOK(buf_sv)) {
  365 + buf = SvPV(buf_sv, len);
  366 + clen += len;
  367 + ap_rwrite(buf, len, r);
  368 + } else {
  369 + break;
  370 + }
  371 + }
  372 + set_content_length(r, len);
  373 + PUSHMARK(SP);
  374 + XPUSHs(obj);
  375 + PUTBACK;
  376 + call_method("close", G_DISCARD);
  377 + SPAGAIN;
  378 + PUTBACK;
  379 + FREETMPS;
  380 + LEAVE;
  381 + return OK;
  382 +}
  383 +
  384 +static int output_body(request_rec *r, SV *body)
  385 +{
  386 + int rc, type;
  387 + switch (type = SvTYPE(SvRV(body))) {
  388 + case SVt_PVAV:
  389 + rc = output_body_ary(r, (AV *) SvRV(body));
  390 + break;
  391 + case SVt_PVGV:
  392 + require_pv("IO/Handle.pm");
  393 + case SVt_PVMG:
  394 + rc = output_body_obj(r, body, type);
  395 + break;
  396 + default:
  397 + server_error(r, "response body must be an array reference or object");
  398 + rc = HTTP_INTERNAL_SERVER_ERROR;
  399 + break;
  400 + }
  401 + return rc;
  402 +}
  403 +
  404 +static int output_response(request_rec *r, SV *res)
  405 +{
  406 + AV *res_av;
  407 + SV **status;
  408 + SV **headers;
  409 + AV *headers_av;
  410 + SV **body;
  411 + int rc;
  412 +
  413 + if (!SvROK(res) || SvTYPE(SvRV(res)) != SVt_PVAV) {
  414 + server_error(r, "response must be an array reference");
  415 + return HTTP_INTERNAL_SERVER_ERROR;
  416 + }
  417 + res_av = (AV *) SvRV(res);
  418 + if (av_len(res_av) != 2) {
  419 + server_error(r, "response must have 3 elements");
  420 + return HTTP_INTERNAL_SERVER_ERROR;
  421 + }
  422 +
  423 + status = av_fetch(res_av, 0, 0);
  424 + if (!SvOK(*status)) {
  425 + server_error(r, "response status must be a scalar value");
  426 + return HTTP_INTERNAL_SERVER_ERROR;
  427 + }
  428 + rc = output_status(r, *status);
  429 + if (rc != OK) return rc;
  430 +
  431 + headers = av_fetch(res_av, 1, 0);
  432 + if (!SvROK(*headers) || SvTYPE(SvRV(*headers)) != SVt_PVAV) {
  433 + server_error(r, "response headers must be an array reference");
  434 + return HTTP_INTERNAL_SERVER_ERROR;
  435 + }
  436 + headers_av = (AV *) SvRV(*headers);
  437 + if ((av_len(headers_av) + 1) % 2 != 0) {
  438 + server_error(r, "num of response headers must be even");
  439 + return HTTP_INTERNAL_SERVER_ERROR;
  440 + }
  441 + rc = output_headers(r, headers_av);
  442 + if (rc != OK) return rc;
  443 +
  444 + body = av_fetch(res_av, 2, 0);
  445 + if (!SvROK(*body)) {
  446 + server_error(r, "response body must be a reference");
  447 + return HTTP_INTERNAL_SERVER_ERROR;
  448 + }
  449 + rc = output_body(r, *body);
  450 +
  451 + return rc;
  452 +}
  453 +
  454 +static void init_perl_variables(request_rec *r)
  455 +{
  456 + GV *exit_gv = gv_fetchpv("CORE::GLOBAL::exit", TRUE, SVt_PVCV);
  457 + GvCV(exit_gv) = get_cv("ModPSGI::exit", TRUE);
  458 + GvIMPORTED_CV_on(exit_gv);
  459 + sv_setpv_mg(get_sv("0", FALSE), r->server->process->argv[0]);
  460 + hv_store(GvHV(PL_envgv), "MOD_PSGI", 8, newSVpv(MOD_PSGI_VERSION, 0), 0);
  461 +}
  462 +
  463 +static PerlInterpreter *init_perl(request_rec *r)
  464 +{
  465 + int argc = 0;
  466 + char *argv[] = { "", NULL };
  467 + char **envp = NULL;
  468 + PerlInterpreter *perlinterp;
  469 + PERL_SYS_INIT3(&argc, (char ***) argv, &envp);
  470 + perlinterp = perl_alloc();
  471 + PL_perl_destruct_level = 1;
  472 + perl_construct(perlinterp);
  473 + perl_parse(perlinterp, xs_init, argc, argv, envp);
  474 + PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
  475 + perl_run(perlinterp);
  476 + init_perl_variables(r);
  477 + return perlinterp;
  478 +}
  479 +
  480 +static void *destroy_perl(PerlInterpreter *perlinterp)
  481 +{
  482 + PL_perl_destruct_level = 1;
  483 + perl_destruct(perlinterp);
  484 + perl_free(perlinterp);
  485 + PERL_SYS_TERM();
  486 +}
  487 +
  488 +static int psgi_handler(request_rec *r)
  489 +{
  490 + SV *app, *env, *res;
  491 + PerlInterpreter *perlinterp;
  492 + psgi_dir_config *c;
  493 + int rc;
  494 +
  495 + if (strcmp(r->handler, "psgi")) {
  496 + return DECLINED;
  497 + }
  498 +
  499 + c = (psgi_dir_config *) ap_get_module_config(r->per_dir_config, &psgi_module);
  500 +
  501 + if (c->psgi_app == NULL) {
  502 + ap_log_error(APLOG_MARK, APLOG_NOERRNO|APLOG_NOTICE, 0, r->server,
  503 + "PSGIApp not configured");
  504 + return DECLINED;
  505 + }
  506 +
  507 + perlinterp = init_perl(r);
  508 + app = load_psgi(r, c->psgi_app);
  509 + if (app == NULL) {
  510 + rc = HTTP_INTERNAL_SERVER_ERROR;
  511 + goto exit;
  512 + }
  513 + env = make_env(r);
  514 + res = run_app(r, app, env);
  515 + if (res == NULL) {
  516 + server_error(r, "invalid response");
  517 + rc = HTTP_INTERNAL_SERVER_ERROR;
  518 + goto exit;
  519 + }
  520 + rc = output_response(r, res);
  521 + goto exit;
  522 +exit:
  523 + destroy_perl(perlinterp);
  524 + return rc;
  525 +}
  526 +
  527 +static int supported_mpm()
  528 +{
  529 + int result;
  530 + ap_mpm_query(AP_MPMQ_IS_FORKED, &result);
  531 + return result;
  532 +}
  533 +
  534 +static void psgi_register_hooks(apr_pool_t *p)
  535 +{
  536 + if (supported_mpm()) {
  537 + ap_hook_handler(psgi_handler, NULL, NULL, APR_HOOK_MIDDLE);
  538 + } else {
  539 + server_error(NULL, "mod_psgi only supports prefork mpm");
  540 + }
  541 +}
  542 +
  543 +static void *create_dir_config(apr_pool_t *p, char *path)
  544 +{
  545 + psgi_dir_config *c = apr_pcalloc(p, sizeof(psgi_dir_config));
  546 + c->psgi_app = NULL;
  547 + return (void *) c;
  548 +}
  549 +
  550 +static const char *cmd_psgi_app(cmd_parms *cmd, void *conf, const char *v)
  551 +{
  552 + psgi_dir_config *c = (psgi_dir_config *) conf;
  553 + c->psgi_app = (char *) apr_pstrdup(cmd->pool, v);
  554 + return NULL;
  555 +}
  556 +
  557 +static const command_rec command_table[] = {
  558 + AP_INIT_TAKE1("PSGIApp", cmd_psgi_app, NULL,
  559 + ACCESS_CONF, "set PSGI application"),
  560 + { NULL }
  561 +};
  562 +
  563 +module AP_MODULE_DECLARE_DATA psgi_module = {
  564 + STANDARD20_MODULE_STUFF,
  565 + create_dir_config, /* create per-dir config structures */
  566 + NULL, /* merge per-dir config structures */
  567 + NULL, /* create per-server config structures */
  568 + NULL, /* merge per-server config structures */
  569 + command_table, /* table of config file commands */
  570 + psgi_register_hooks /* register hooks */
  571 +};
  572 +
4 modules.mk
... ... @@ -0,0 +1,4 @@
  1 +mod_psgi.la: mod_psgi.slo
  2 + $(SH_LINK) -rpath $(libexecdir) -module -avoid-version mod_psgi.lo
  3 +DISTCLEAN_TARGETS = modules.mk
  4 +shared = mod_psgi.la
117 t/00_output.t
... ... @@ -0,0 +1,117 @@
  1 +use strict;
  2 +use warnings;
  3 +use t::TestModPSGI;
  4 +
  5 +BEGIN {
  6 + no warnings 'once';
  7 + $YAML::LoadCode = 1;
  8 +}
  9 +
  10 +{
  11 + package t::ModPSGIHandle;
  12 + sub new { bless \my $i, $_[0] }
  13 + sub getline {
  14 + my $self = shift;
  15 + return $$self if $$self++ < 3;
  16 + return;
  17 + }
  18 + sub close {
  19 + my $self = shift;
  20 +# warn "close called\nself: $$self";
  21 + }
  22 +}
  23 +
  24 +return eval_response_app if running_in_mod_psgi;
  25 +
  26 +run_eval_request;
  27 +
  28 +__END__
  29 +
  30 +=== simple
  31 +--- request
  32 +method: GET
  33 +code: |
  34 + [ 200, [ 'Content-Type' => 'text/plain' ], ['test'] ]
  35 +--- response
  36 +is_success: 1
  37 +content: test
  38 +code: 200
  39 +content_type: text/plain
  40 +
  41 +=== status
  42 +--- request
  43 +method: GET
  44 +code: |
  45 + [ 404, [ 'Content-Type' => 'text/plain' ], [ 'Not Found' ] ]
  46 +--- response
  47 +is_success: not ok
  48 +code: 404
  49 +content: Not Found
  50 +
  51 +=== headers
  52 +--- request
  53 +method: GET
  54 +code: |
  55 + [ 200, [ 'Content-Type' => 'text/plain', 'X-ModPSGI' => 1 ], [ '' ] ]
  56 +--- response
  57 +is_success: ok
  58 +content_type: text/plain
  59 +header:
  60 + X-ModPSGI: 1
  61 +
  62 +=== auto set content_length
  63 +--- request
  64 +method: GET
  65 +code: |
  66 + [ 200, [ 'Content-Type' => 'text/plain' ], ['test'] ]
  67 +--- response
  68 +is_success: ok
  69 +content: test
  70 +code: 200
  71 +content_length: 4
  72 +
  73 +=== multiple body
  74 +--- request
  75 +method: GET
  76 +code: |
  77 + [ 200, [ 'Content-Type' => 'text/plain' ], ['foo', 'bar'] ]
  78 +--- response
  79 +is_success: ok
  80 +content: foobar
  81 +
  82 +=== body filehandle
  83 +--- request
  84 +method: GET
  85 +code: !perl/code |
  86 + {
  87 + require Path::Class;
  88 + my $file = Path::Class::file($0)->absolute;
  89 + qq{
  90 + open my \$fh, '<', "$file" or die \$!;
  91 + [ 200, [ 'Content-Type' => 'text/plain' ], \$fh ];
  92 + };
  93 + }
  94 +--- response
  95 +is_success: ok
  96 +content_length: !perl/code |
  97 + {
  98 + require Path::Class;
  99 + my $file = Path::Class::file($0);
  100 + $file->stat->size;
  101 + }
  102 +content: !perl/code |
  103 + {
  104 + require Path::Class;
  105 + my $file = Path::Class::file($0);
  106 + scalar $file->slurp;
  107 + }
  108 +
  109 +=== body filehandle like object
  110 +--- request
  111 +method: GET
  112 +code: |
  113 + [ 200, [ 'Content-Type' => 'text/plain' ], t::ModPSGIHandle->new ]
  114 +--- response
  115 +is_success: ok
  116 +content: 123
  117 +
21 t/01_lint.t
... ... @@ -0,0 +1,21 @@
  1 +use strict;
  2 +use warnings;
  3 +use t::TestModPSGI;
  4 +
  5 +return eval_body_app if running_in_mod_psgi;
  6 +
  7 +run_eval_request;
  8 +
  9 +__END__
  10 +
  11 +=== Lint OK
  12 +--- request
  13 +method: GET
  14 +code: |
  15 + require Plack::Lint;
  16 + eval { Plack::Lint->validate_env($env) };
  17 + $@ || 'valid env';
  18 +--- response
  19 +is_success: ok
  20 +content: valid env
  21 +
68 t/02_input.t
... ... @@ -0,0 +1,68 @@
  1 +use strict;
  2 +use warnings;
  3 +use t::TestModPSGI;
  4 +
  5 +return eval_body_app if running_in_mod_psgi;
  6 +
  7 +run_eval_request;
  8 +
  9 +__END__
  10 +
  11 +=== isa
  12 +--- request
  13 +method: GET
  14 +code: |
  15 + $env->{'psgi.input'}->isa('ModPSGI::Input');
  16 +--- response
  17 +is_success: ok
  18 +content: ok
  19 +
  20 +=== can read
  21 +--- request
  22 +method: GET
  23 +code: |
  24 + $env->{'psgi.input'}->can('read');
  25 +--- response
  26 +is_success: ok
  27 +content: ok
  28 +
  29 +=== read
  30 +--- request
  31 +method: POST
  32 +code: |
  33 + $env->{'psgi.input'}->read(my $buf, 1);
  34 + $buf;
  35 +args:
  36 + - foo: bar
  37 +--- response
  38 +is_success: ok
  39 +content: f
  40 +
  41 +=== read all
  42 +--- request
  43 +method: POST
  44 +code: |
  45 + $env->{'psgi.input'}->read(my $buf, $env->{CONTENT_LENGTH});
  46 + $buf;
  47 +args:
  48 + - a: 1
  49 + b: 2
  50 +--- response
  51 +is_success: ok
  52 +content: a=1&b=2
  53 +
  54 +=== read each bytes
  55 +--- request
  56 +method: POST
  57 +code: |
  58 + my ($buf, $read);
  59 + while ($env->{'psgi.input'}->read($read, 1)) {
  60 + $buf .= $read;
  61 + }
  62 + $buf;
  63 +args:
  64 + - foo: bar
  65 +--- response
  66 +is_success: ok
  67 +content: foo=bar
  68 +
37 t/03_errors.t
... ... @@ -0,0 +1,37 @@
  1 +use strict;
  2 +use warnings;
  3 +use t::TestModPSGI;
  4 +
  5 +return eval_body_app if running_in_mod_psgi;
  6 +
  7 +run_eval_request;
  8 +
  9 +__END__
  10 +
  11 +=== isa
  12 +--- request
  13 +method: get
  14 +code: |
  15 + $env->{'psgi.errors'}->isa('ModPSGI::Errors');
  16 +--- response
  17 +is_success: ok
  18 +content: ok
  19 +
  20 +=== can print
  21 +--- request
  22 +method: get
  23 +code: |
  24 + $env->{'psgi.errors'}->can('print');
  25 +--- response
  26 +is_success: ok
  27 +content: ok
  28 +
  29 +=== print
  30 +--- request
  31 +method: get
  32 +code: |
  33 + $env->{'psgi.errors'}->print('this is test');
  34 +--- response
  35 +is_success: ok
  36 +content: ok
  37 +
28 t/04_die.t
... ... @@ -0,0 +1,28 @@
  1 +use strict;
  2 +use warnings;
  3 +use t::TestModPSGI;
  4 +
  5 +return eval_body_app if running_in_mod_psgi;
  6 +
  7 +run_eval_request;
  8 +
  9 +__END__
  10 +
  11 +=== app exit but apache process is still running
  12 +--- request
  13 +method: GET
  14 +code: |
  15 + $env->{'psgi.errors'}->print('test exit');
  16 + exit;
  17 +--- response
  18 +is_success: not ok
  19 +code: 500
  20 +=== app die but apache process is still running
  21 +--- request
  22 +method: GET
  23 +code: |
  24 + die 'test die';
  25 +--- response
  26 +is_success: not ok
  27 +code: 500
  28 +
9 t/Makefile
... ... @@ -0,0 +1,9 @@
  1 +all: conf
  2 +test: test.conf
  3 + prove -I.. .
  4 +conf: test.conf
  5 +test.conf: test.conf.tt *.t mkconf.pl
  6 + ./mkconf.pl --input $< --output $@
  7 +clean:
  8 + rm -f test.conf
  9 +.PHONY: conf clean test
118 t/TestModPSGI.pm
... ... @@ -0,0 +1,118 @@
  1 +package t::TestModPSGI;
  2 +use strict;
  3 +use warnings;
  4 +use Test::Base -Base;
  5 +
  6 +use File::Basename;
  7 +use URI::Escape;
  8 +use List::Util qw(sum);
  9 +
  10 +our @EXPORT = qw(
  11 + running_in_mod_psgi eval_body_app eval_response_app
  12 + run_eval_request
  13 +);
  14 +
  15 +our $Host = '127.0.0.1';
  16 +our $Path = '/psgi/t';
  17 +
  18 +BEGIN {
  19 + no warnings 'redefine';
  20 + *Test::Base::run_compare = sub {}; # XXX
  21 +}
  22 +
  23 +sub running_in_mod_psgi() {
  24 + exists $ENV{MOD_PSGI};
  25 +}
  26 +
  27 +sub eval_body_app() {
  28 + sub {
  29 + my $env = shift;
  30 + my $code = uri_unescape($env->{QUERY_STRING});
  31 + my $body = eval $code;
  32 + [ 200, [ 'Content-Type' => 'text/plain' ], [ $body ] ];
  33 + };
  34 +}
  35 +
  36 +sub eval_response_app() {
  37 + sub {
  38 + my $env = shift;
  39 + my $code = uri_unescape($env->{QUERY_STRING});
  40 + eval $code;
  41 + };
  42 +}
  43 +
  44 +our $UA;
  45 +
  46 +sub ua() {
  47 + require LWP::UserAgent;
  48 + $UA ||= LWP::UserAgent->new;
  49 +}
  50 +
  51 +sub eval_request($$$;@) {
  52 + my ($file, $method, $code, @args) = @_;
  53 + if (ref $code eq 'CODE') {
  54 + no warnings 'prototype';
  55 + return eval_request($file, $method, $code->(), @args);
  56 + }
  57 + my $uri = sprintf 'http://%s%s/%s?%s', $Host, $Path,
  58 + basename($file), uri_escape($code);
  59 + $method = lc $method;
  60 + ua->$method($uri, @args);
  61 +}