Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

Initial commit

  • Loading branch information...
commit f61f18854c61af9b373b99a6d1f291554763efe0 0 parents
Jiro Nishiguchi authored
0  .deps
No changes.
7 .gitignore
@@ -0,0 +1,7 @@
+/ppport.h
+/.libs
+*.la
+*.lo
+*.o
+*.slo
+/t/test.conf
202 LICENSE
@@ -0,0 +1,202 @@
+
+ Apache License
+ Version 2.0, January 2004
+ http://www.apache.org/licenses/
+
+ TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION
+
+ 1. Definitions.
+
+ "License" shall mean the terms and conditions for use, reproduction,
+ and distribution as defined by Sections 1 through 9 of this document.
+
+ "Licensor" shall mean the copyright owner or entity authorized by
+ the copyright owner that is granting the License.
+
+ "Legal Entity" shall mean the union of the acting entity and all
+ other entities that control, are controlled by, or are under common
+ control with that entity. For the purposes of this definition,
+ "control" means (i) the power, direct or indirect, to cause the
+ direction or management of such entity, whether by contract or
+ otherwise, or (ii) ownership of fifty percent (50%) or more of the
+ outstanding shares, or (iii) beneficial ownership of such entity.
+
+ "You" (or "Your") shall mean an individual or Legal Entity
+ exercising permissions granted by this License.
+
+ "Source" form shall mean the preferred form for making modifications,
+ including but not limited to software source code, documentation
+ source, and configuration files.
+
+ "Object" form shall mean any form resulting from mechanical
+ transformation or translation of a Source form, including but
+ not limited to compiled object code, generated documentation,
+ and conversions to other media types.
+
+ "Work" shall mean the work of authorship, whether in Source or
+ Object form, made available under the License, as indicated by a
+ copyright notice that is included in or attached to the work
+ (an example is provided in the Appendix below).
+
+ "Derivative Works" shall mean any work, whether in Source or Object
+ form, that is based on (or derived from) the Work and for which the
+ editorial revisions, annotations, elaborations, or other modifications
+ represent, as a whole, an original work of authorship. For the purposes
+ of this License, Derivative Works shall not include works that remain
+ separable from, or merely link (or bind by name) to the interfaces of,
+ the Work and Derivative Works thereof.
+
+ "Contribution" shall mean any work of authorship, including
+ the original version of the Work and any modifications or additions
+ to that Work or Derivative Works thereof, that is intentionally
+ submitted to Licensor for inclusion in the Work by the copyright owner
+ or by an individual or Legal Entity authorized to submit on behalf of
+ the copyright owner. For the purposes of this definition, "submitted"
+ means any form of electronic, verbal, or written communication sent
+ to the Licensor or its representatives, including but not limited to
+ communication on electronic mailing lists, source code control systems,
+ and issue tracking systems that are managed by, or on behalf of, the
+ Licensor for the purpose of discussing and improving the Work, but
+ excluding communication that is conspicuously marked or otherwise
+ designated in writing by the copyright owner as "Not a Contribution."
+
+ "Contributor" shall mean Licensor and any individual or Legal Entity
+ on behalf of whom a Contribution has been received by Licensor and
+ subsequently incorporated within the Work.
+
+ 2. Grant of Copyright License. Subject to the terms and conditions of
+ this License, each Contributor hereby grants to You a perpetual,
+ worldwide, non-exclusive, no-charge, royalty-free, irrevocable
+ copyright license to reproduce, prepare Derivative Works of,
+ publicly display, publicly perform, sublicense, and distribute the
+ Work and such Derivative Works in Source or Object form.
+
+ 3. Grant of Patent License. Subject to the terms and conditions of
+ this License, each Contributor hereby grants to You a perpetual,
+ worldwide, non-exclusive, no-charge, royalty-free, irrevocable
+ (except as stated in this section) patent license to make, have made,
+ use, offer to sell, sell, import, and otherwise transfer the Work,
+ where such license applies only to those patent claims licensable
+ by such Contributor that are necessarily infringed by their
+ Contribution(s) alone or by combination of their Contribution(s)
+ with the Work to which such Contribution(s) was submitted. If You
+ institute patent litigation against any entity (including a
+ cross-claim or counterclaim in a lawsuit) alleging that the Work
+ or a Contribution incorporated within the Work constitutes direct
+ or contributory patent infringement, then any patent licenses
+ granted to You under this License for that Work shall terminate
+ as of the date such litigation is filed.
+
+ 4. Redistribution. You may reproduce and distribute copies of the
+ Work or Derivative Works thereof in any medium, with or without
+ modifications, and in Source or Object form, provided that You
+ meet the following conditions:
+
+ (a) You must give any other recipients of the Work or
+ Derivative Works a copy of this License; and
+
+ (b) You must cause any modified files to carry prominent notices
+ stating that You changed the files; and
+
+ (c) You must retain, in the Source form of any Derivative Works
+ that You distribute, all copyright, patent, trademark, and
+ attribution notices from the Source form of the Work,
+ excluding those notices that do not pertain to any part of
+ the Derivative Works; and
+
+ (d) If the Work includes a "NOTICE" text file as part of its
+ distribution, then any Derivative Works that You distribute must
+ include a readable copy of the attribution notices contained
+ within such NOTICE file, excluding those notices that do not
+ pertain to any part of the Derivative Works, in at least one
+ of the following places: within a NOTICE text file distributed
+ as part of the Derivative Works; within the Source form or
+ documentation, if provided along with the Derivative Works; or,
+ within a display generated by the Derivative Works, if and
+ wherever such third-party notices normally appear. The contents
+ of the NOTICE file are for informational purposes only and
+ do not modify the License. You may add Your own attribution
+ notices within Derivative Works that You distribute, alongside
+ or as an addendum to the NOTICE text from the Work, provided
+ that such additional attribution notices cannot be construed
+ as modifying the License.
+
+ You may add Your own copyright statement to Your modifications and
+ may provide additional or different license terms and conditions
+ for use, reproduction, or distribution of Your modifications, or
+ for any such Derivative Works as a whole, provided Your use,
+ reproduction, and distribution of the Work otherwise complies with
+ the conditions stated in this License.
+
+ 5. Submission of Contributions. Unless You explicitly state otherwise,
+ any Contribution intentionally submitted for inclusion in the Work
+ by You to the Licensor shall be under the terms and conditions of
+ this License, without any additional terms or conditions.
+ Notwithstanding the above, nothing herein shall supersede or modify
+ the terms of any separate license agreement you may have executed
+ with Licensor regarding such Contributions.
+
+ 6. Trademarks. This License does not grant permission to use the trade
+ names, trademarks, service marks, or product names of the Licensor,
+ except as required for reasonable and customary use in describing the
+ origin of the Work and reproducing the content of the NOTICE file.
+
+ 7. Disclaimer of Warranty. Unless required by applicable law or
+ agreed to in writing, Licensor provides the Work (and each
+ Contributor provides its Contributions) on an "AS IS" BASIS,
+ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or
+ implied, including, without limitation, any warranties or conditions
+ of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A
+ PARTICULAR PURPOSE. You are solely responsible for determining the
+ appropriateness of using or redistributing the Work and assume any
+ risks associated with Your exercise of permissions under this License.
+
+ 8. Limitation of Liability. In no event and under no legal theory,
+ whether in tort (including negligence), contract, or otherwise,
+ unless required by applicable law (such as deliberate and grossly
+ negligent acts) or agreed to in writing, shall any Contributor be
+ liable to You for damages, including any direct, indirect, special,
+ incidental, or consequential damages of any character arising as a
+ result of this License or out of the use or inability to use the
+ Work (including but not limited to damages for loss of goodwill,
+ work stoppage, computer failure or malfunction, or any and all
+ other commercial damages or losses), even if such Contributor
+ has been advised of the possibility of such damages.
+
+ 9. Accepting Warranty or Additional Liability. While redistributing
+ the Work or Derivative Works thereof, You may choose to offer,
+ and charge a fee for, acceptance of support, warranty, indemnity,
+ or other liability obligations and/or rights consistent with this
+ License. However, in accepting such obligations, You may act only
+ on Your own behalf and on Your sole responsibility, not on behalf
+ of any other Contributor, and only if You agree to indemnify,
+ defend, and hold each Contributor harmless for any liability
+ incurred by, or claims asserted against, such Contributor by reason
+ of your accepting any such warranty or additional liability.
+
+ END OF TERMS AND CONDITIONS
+
+ APPENDIX: How to apply the Apache License to your work.
+
+ To apply the Apache License to your work, attach the following
+ boilerplate notice, with the fields enclosed by brackets "[]"
+ replaced with your own identifying information. (Don't include
+ the brackets!) The text should be enclosed in the appropriate
+ comment syntax for the file format. We also recommend that a
+ file or class name and description of purpose be included on the
+ same "printed page" as the copyright notice for easier
+ identification within third-party archives.
+
+ Copyright [yyyy] [name of copyright owner]
+
+ Licensed under the Apache License, Version 2.0 (the "License");
+ you may not use this file except in compliance with the License.
+ You may obtain a copy of the License at
+
+ http://www.apache.org/licenses/LICENSE-2.0
+
+ Unless required by applicable law or agreed to in writing, software
+ distributed under the License is distributed on an "AS IS" BASIS,
+ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+ See the License for the specific language governing permissions and
+ limitations under the License.
76 Makefile
@@ -0,0 +1,76 @@
+##
+## Makefile -- Build procedure for PSGI Apache module
+## Autogenerated via ``apxs -n psgi -g''.
+##
+
+PACKAGE_NAME=mod_psgi
+PACKAGE_VERSION=0.0.1
+
+# the used tools
+APXS=apxs
+APACHECTL=apachectl
+PERL=perl
+
+builddir=.
+top_srcdir=$(shell $(APXS) -q prefix)
+top_builddir=$(shell $(APXS) -q prefix)
+include $(shell $(APXS) -q installbuilddir)/special.mk
+
+# additional defines, includes and libraries
+ifdef MOD_PSGI_DEBUG
+DEBUG_DEFS=-DDEBUG
+else
+DEBUG_DEFS=
+endif
+DEFS=-DMOD_PSGI_VERSION=\"$(PACKAGE_VERSION)\" $(DEBUG_DEFS)
+INCLUDES=$(shell $(PERL) -MExtUtils::Embed -e ccopts)
+LDFLAGS=$(shell $(PERL) -MExtUtils::Embed -e ldopts)
+
+# the default target
+all: local-shared-build
+
+# install the shared object file into Apache
+install: install-modules-yes
+
+# cleanup
+clean:
+ -rm -f mod_psgi.o mod_psgi.lo mod_psgi.slo mod_psgi.la
+ rm -f ppport.h
+ $(MAKE) -C t clean
+
+mod_psgi.c: ppport.h
+
+ppport.h:
+ perl -MDevel::PPPort -e 'Devel::PPPort::WriteFile'
+
+testconf:
+ $(MAKE) -C t conf
+
+test: reload
+ $(MAKE) -C t test
+
+# install and activate shared object by reloading Apache to
+# force a reload of the shared object file
+reload: install restart
+
+# the general Apache start/restart/stop
+# procedures
+start:
+ $(APACHECTL) start
+restart:
+ $(APACHECTL) restart
+stop:
+ $(APACHECTL) stop
+
+DIST_DIR=$(PACKAGE_NAME)-$(PACKAGE_VERSION)
+DIST_FILE=$(PACKAGE_NAME)-$(PACKAGE_VERSION).tar
+dist: ppport.h
+ rm -f $(DIST_FILE)
+ git archive --format=tar --prefix=$(DIST_DIR)/ HEAD > $(DIST_FILE)
+ mkdir $(DIST_DIR)
+ cp ppport.h $(DIST_DIR)
+ tar rf $(DIST_FILE) $(DIST_DIR)/ppport.h
+ rm -fr $(DIST_DIR)
+ gzip --best $(DIST_FILE)
+
+.PHONY: testconf
39 README
@@ -0,0 +1,39 @@
+This is Apache2 module mod_psgi.
+
+* Install
+
+ % make APX=/usr/local/apache2/bin/apx PERL=/usr/local/bin/perl
+ % make install
+
+Then activate it in Apache's httpd.conf file for instance
+for the URL /psgi in as follows:
+
+ # httpd.conf
+ LoadModule psgi_module modules/mod_psgi.so
+ <Location /psgi>
+ SetHandler psgi
+ PSGIApp /path/to/app.psgi
+ </Location>
+
+Then after restarting Apache via
+
+ $ apachectl restart
+
+* Spec
+
+ * This module works on Apache2 which is configured by '--with-mpm=prefork'.
+
+ * PSGIApp files are loaded by 'do $file'. The file must return a code reference
+ that is a PSGI application.
+
+ * The input stream ($env->{'psgi.input'}) is not seekable.
+ $env->{'psgi.input'}->seek($pos, $whence) raises an error.
+
+* License
+
+See the 'LICENSE' file.
+
+* Author
+
+Jiro Nishiguchi <jiro@cpan.org>
+
572 mod_psgi.c
@@ -0,0 +1,572 @@
+/*
+ * Copyright 2009 Jiro Nishiguchi <jiro@cpan.org>
+ *
+ * Licensed under the Apache License, Version 2.0 (the "License");
+ * you may not use this file except in compliance with the License.
+ * You may obtain a copy of the License at
+ *
+ * http://www.apache.org/licenses/LICENSE-2.0
+ *
+ * Unless required by applicable law or agreed to in writing, software
+ * distributed under the License is distributed on an "AS IS" BASIS,
+ * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+ * See the License for the specific language governing permissions and
+ * limitations under the License.
+ */
+#include "httpd.h"
+#include "http_log.h"
+#include "http_config.h"
+#include "http_protocol.h"
+#include "util_script.h"
+#include "ap_config.h"
+#include "ap_mpm.h"
+#include "apr_strings.h"
+
+#define PERL_NO_GET_CONTEXT
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+#define NEED_eval_pv
+#define NEED_newRV_noinc
+#define NEED_sv_2pv_flags
+#include "ppport.h"
+
+#ifdef DEBUG
+#define TRACE(...) ap_log_error(APLOG_MARK, APLOG_NOERRNO|APLOG_NOTICE, 0, NULL, __VA_ARGS__)
+#endif
+
+module AP_MODULE_DECLARE_DATA psgi_module;
+
+typedef struct {
+ char *psgi_app;
+} psgi_dir_config;
+
+static void server_error(request_rec *r, const char *fmt, ...)
+{
+ va_list argp;
+ const char *msg;
+ va_start(argp, fmt);
+ msg = apr_pvsprintf(r->pool, fmt, argp);
+ va_end(argp);
+ ap_log_error(APLOG_MARK, APLOG_NOERRNO|APLOG_ERR, 0, r->server, "%s", msg);
+}
+
+EXTERN_C void xs_init (pTHX);
+
+EXTERN_C void boot_DynaLoader (pTHX_ CV* cv);
+
+XS(ModPSGI_exit);
+XS(ModPSGI_exit)
+{
+ dXSARGS;
+ croak("exit");
+ XSRETURN(0);
+}
+
+XS(ModPSGI_Input_read);
+XS(ModPSGI_Input_read)
+{
+ dXSARGS;
+ SV *self = ST(0);
+ SV *buf = ST(1);
+ request_rec *r = (request_rec *) mg_find(SvRV(self), PERL_MAGIC_ext)->mg_obj;
+ apr_size_t len = SvIV(ST(2));
+ apr_size_t offset = items >= 4 ? SvIV(ST(3)) : 0;
+ apr_status_t rv;
+ apr_bucket_brigade *bb;
+ apr_bucket *bucket;
+ int eos = 0;
+ SV *ret;
+ dXSTARG;
+
+ ret = newSVpv("", 0);
+ bb = apr_brigade_create(r->pool, r->connection->bucket_alloc);
+ rv = ap_get_brigade(r->input_filters, bb, AP_MODE_READBYTES, APR_BLOCK_READ, len);
+ if (rv != APR_SUCCESS) {
+ ST(0) = &PL_sv_undef;
+ XSRETURN(1);
+ }
+
+ for (bucket = APR_BRIGADE_FIRST(bb);
+ bucket != APR_BRIGADE_SENTINEL(bb);
+ bucket = APR_BUCKET_NEXT(bucket)) {
+ const char *bbuf;
+ apr_size_t blen;
+ if (APR_BUCKET_IS_EOS(bucket)) {
+ eos = 1;
+ break;
+ }
+ if (APR_BUCKET_IS_METADATA(bucket)) {
+ continue;
+ }
+ apr_bucket_read(bucket, &bbuf, &blen, APR_BLOCK_READ);
+ sv_catpvn(ret, bbuf, blen);
+ }
+
+ sv_setsv(buf, ret);
+ ST(0) = sv_2mortal(newSViv(SvCUR(buf)));
+ XSRETURN(1);
+}
+
+XS(ModPSGI_Errors_print);
+XS(ModPSGI_Errors_print)
+{
+ dXSARGS;
+ SV *self = ST(0);
+ SV *msg = ST(1);
+ dXSTARG;
+ request_rec *r = (request_rec *) mg_find(SvRV(self), PERL_MAGIC_ext)->mg_obj;
+ ap_log_error(APLOG_MARK, APLOG_NOERRNO|APLOG_ERR, 0, r->server, "%s", SvPV_nolen(msg));
+ ST(0) = newSViv(1);
+ XSRETURN(1);
+}
+
+EXTERN_C void
+xs_init(pTHX)
+{
+ char *file = __FILE__;
+ dXSUB_SYS;
+
+ newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);
+ newXS("ModPSGI::exit", ModPSGI_exit, file);
+ newXSproto("ModPSGI::Input::read", ModPSGI_Input_read, file, "$$$;$");
+ newXSproto("ModPSGI::Errors::print", ModPSGI_Errors_print, file, "$$");
+}
+
+static int copy_env(void *rec, const char *key, const char *val)
+{
+ HV *env = (HV *) rec;
+ hv_store(env, key, strlen(key), newSVpv(val, 0), 0);
+ return 1;
+}
+
+static SV *make_env(request_rec *r)
+{
+ HV *env;
+ AV *version;
+ char *url_scheme;
+ SV *input, *errors;
+
+ env = newHV();
+
+ ap_add_cgi_vars(r);
+ ap_add_common_vars(r);
+ if (apr_table_get(r->subprocess_env, "PATH_INFO") == NULL) {
+ apr_table_set(r->subprocess_env, "PATH_INFO", "");
+ }
+ if (strcmp(apr_table_get(r->subprocess_env, "SCRIPT_NAME"), "/") == 0
+ && strcmp(apr_table_get(r->subprocess_env, "PATH_INFO"), "") == 0) {
+ apr_table_set(r->subprocess_env, "PATH_INFO", "/");
+ apr_table_set(r->subprocess_env, "SCRIPT_NAME", "");
+ }
+ apr_table_do(copy_env, env, r->subprocess_env, NULL);
+
+ version = newAV();
+ av_push(version, newSViv(1));
+ av_push(version, newSViv(0));
+ hv_store(env, "psgi.version", 12, newRV_inc((SV *) version), 0);
+
+ url_scheme = apr_table_get(r->subprocess_env, "HTTPS") == NULL ? "http" : "https";
+ hv_store(env, "psgi.url_scheme", 15, newSVpv(url_scheme, 0), 0);
+
+ input = newRV_noinc(newSV(0));
+ sv_magic(SvRV(input), NULL, PERL_MAGIC_ext, NULL, 0);
+ mg_find(SvRV(input), PERL_MAGIC_ext)->mg_obj = (void *) r;
+ sv_bless(input, gv_stashpv("ModPSGI::Input", 1));
+ hv_store(env, "psgi.input", 10, input, 0);
+
+ errors = newRV_noinc(newSV(0));
+ sv_magic(SvRV(errors), NULL, PERL_MAGIC_ext, NULL, 0);
+ mg_find(SvRV(errors), PERL_MAGIC_ext)->mg_obj = (void *) r;
+ sv_bless(errors, gv_stashpv("ModPSGI::Errors", 1));
+ hv_store(env, "psgi.errors", 11, errors, 0);
+
+ hv_store(env, "psgi.multithread", 16, newSViv(0), 0);
+ hv_store(env, "psgi.multiprocess", 17, newSViv(1), 0);
+ hv_store(env, "psgi.run_once", 13, newSViv(1), 0);
+ hv_store(env, "psgi.async", 10, newSViv(0), 0);
+
+ return newRV_inc((SV *) env);
+}
+
+static SV *load_psgi(request_rec *r, const char *file)
+{
+ SV *app;
+ char *code;
+
+ code = apr_psprintf(r->pool, "do q\"%s\" or die $@",
+ ap_escape_quotes(r->pool, file));
+ app = eval_pv(code, FALSE);
+
+ if (SvTRUE(ERRSV)) {
+ server_error(r, "%s", SvPV_nolen(ERRSV));
+ return NULL;
+ }
+ if (!SvOK(app) || !SvROK(app) || SvTYPE(SvRV(app)) != SVt_PVCV) {
+ server_error(r, "%s does not return an application code reference", file);
+ return NULL;
+ }
+ return app;
+}
+
+static SV *run_app(request_rec *r, SV *app, SV *env)
+{
+ int count;
+ SV *res;
+ dSP;
+ ENTER;
+ SAVETMPS;
+ PUSHMARK(SP) ;
+ XPUSHs(sv_2mortal(env));
+ PUTBACK;
+
+ count = call_sv(app, G_EVAL|G_KEEPERR|G_SCALAR);
+ SPAGAIN;
+ if (SvTRUE(ERRSV)) {
+ res = NULL;
+ server_error(r, "%s", SvPV_nolen(ERRSV));
+ POPs;
+ } else if (count > 0) {
+ res = POPs;
+ SvREFCNT_inc(res);
+ } else {
+ res = NULL;
+ }
+ PUTBACK;
+ FREETMPS;
+ LEAVE;
+ return res;
+}
+
+static int output_status(request_rec *r, SV *status)
+{
+ int s = SvIV(status);
+ if (s < 100) {
+ server_error(r, "invalid response status %d", s);
+ return HTTP_INTERNAL_SERVER_ERROR;
+ }
+ r->status = s;
+ return OK;
+}
+
+static int check_header_value(const char *value)
+{
+ int i;
+ int len = strlen(value);
+ for (i = 0; i < len; i++) {
+ if (value[i] < 37) {
+ return 1;
+ }
+ }
+ return 0;
+}
+
+static int output_headers(request_rec *r, AV *headers)
+{
+ SV *key_sv, *val_sv;
+ char *key, *val;
+ while (av_len(headers) > -1) {
+ key_sv = av_shift(headers);
+ val_sv = av_shift(headers);
+ if (key_sv == NULL || val_sv == NULL) break;
+ key = SvPV_nolen(key_sv);
+ val = SvPV_nolen(val_sv);
+ if (check_header_value(val) != 0) {
+ server_error(r, "value string must not contain characters below chr(37)");
+ return HTTP_INTERNAL_SERVER_ERROR;
+ } else if (strcmp(key, "Content-Type") == 0) {
+ r->content_type = apr_pstrdup(r->pool, val);
+ } else if (strcmp(key, "Status") == 0) {
+ server_error(r, "headers must not contain a Status");
+ return HTTP_INTERNAL_SERVER_ERROR;
+ } else {
+ apr_table_add(r->headers_out, key, val);
+ }
+ }
+ return OK;
+}
+
+static int respond_to(SV *obj, const char *method)
+{
+ int res;
+ dSP;
+ ENTER;
+ SAVETMPS;
+ PUSHMARK(SP);
+ XPUSHs(obj);
+ XPUSHs(sv_2mortal(newSVpv(method, 0)));
+ PUTBACK;
+
+ call_method("can", G_SCALAR);
+ SPAGAIN;
+ res = SvROK(POPs);
+ PUTBACK;
+ FREETMPS;
+ LEAVE;
+ return res;
+}
+
+static void set_content_length(request_rec *r, apr_off_t length)
+{
+ if (apr_table_get(r->headers_out, "Content-Length") == NULL) {
+ apr_table_add(r->headers_out, "Content-Length", apr_off_t_toa(r->pool, length));
+ }
+}
+
+static int output_body_ary(request_rec *r, AV *bodys)
+{
+ SV **body;
+ I32 i;
+ I32 lastidx;
+ char *buf;
+ STRLEN len;
+ apr_off_t clen;
+
+ lastidx = av_len(bodys);
+ for (i = 0; i <= lastidx; i++) {
+ body = av_fetch(bodys, i, 0);
+ if (SvOK(*body)) {
+ buf = SvPV(*body, len);
+ ap_rwrite(buf, len, r);
+ clen += len;
+ }
+ }
+ set_content_length(r, clen);
+ return OK;
+}
+
+static int output_body_obj(request_rec *r, SV *obj, int type)
+{
+ SV *buf_sv, *rs;
+ apr_off_t clen = 0;
+ STRLEN len;
+ char *buf;
+ int count;
+
+ if (type == SVt_PVMG && !respond_to(obj, "getline")) {
+ server_error(r, "response body object must be able to getline");
+ return HTTP_INTERNAL_SERVER_ERROR;
+ }
+
+ dSP;
+ ENTER;
+ SAVETMPS;
+ SAVESPTR(PL_rs);
+ PL_rs = newRV_inc(newSViv(AP_IOBUFSIZE));
+ while (1) {
+ PUSHMARK(SP);
+ XPUSHs(obj);
+ PUTBACK;
+ count = call_method("getline", G_SCALAR);
+ if (count != 1) croak("Big trouble\n");
+ SPAGAIN;
+ buf_sv = POPs;
+ if (SvOK(buf_sv)) {
+ buf = SvPV(buf_sv, len);
+ clen += len;
+ ap_rwrite(buf, len, r);
+ } else {
+ break;
+ }
+ }
+ set_content_length(r, len);
+ PUSHMARK(SP);
+ XPUSHs(obj);
+ PUTBACK;
+ call_method("close", G_DISCARD);
+ SPAGAIN;
+ PUTBACK;
+ FREETMPS;
+ LEAVE;
+ return OK;
+}
+
+static int output_body(request_rec *r, SV *body)
+{
+ int rc, type;
+ switch (type = SvTYPE(SvRV(body))) {
+ case SVt_PVAV:
+ rc = output_body_ary(r, (AV *) SvRV(body));
+ break;
+ case SVt_PVGV:
+ require_pv("IO/Handle.pm");
+ case SVt_PVMG:
+ rc = output_body_obj(r, body, type);
+ break;
+ default:
+ server_error(r, "response body must be an array reference or object");
+ rc = HTTP_INTERNAL_SERVER_ERROR;
+ break;
+ }
+ return rc;
+}
+
+static int output_response(request_rec *r, SV *res)
+{
+ AV *res_av;
+ SV **status;
+ SV **headers;
+ AV *headers_av;
+ SV **body;
+ int rc;
+
+ if (!SvROK(res) || SvTYPE(SvRV(res)) != SVt_PVAV) {
+ server_error(r, "response must be an array reference");
+ return HTTP_INTERNAL_SERVER_ERROR;
+ }
+ res_av = (AV *) SvRV(res);
+ if (av_len(res_av) != 2) {
+ server_error(r, "response must have 3 elements");
+ return HTTP_INTERNAL_SERVER_ERROR;
+ }
+
+ status = av_fetch(res_av, 0, 0);
+ if (!SvOK(*status)) {
+ server_error(r, "response status must be a scalar value");
+ return HTTP_INTERNAL_SERVER_ERROR;
+ }
+ rc = output_status(r, *status);
+ if (rc != OK) return rc;
+
+ headers = av_fetch(res_av, 1, 0);
+ if (!SvROK(*headers) || SvTYPE(SvRV(*headers)) != SVt_PVAV) {
+ server_error(r, "response headers must be an array reference");
+ return HTTP_INTERNAL_SERVER_ERROR;
+ }
+ headers_av = (AV *) SvRV(*headers);
+ if ((av_len(headers_av) + 1) % 2 != 0) {
+ server_error(r, "num of response headers must be even");
+ return HTTP_INTERNAL_SERVER_ERROR;
+ }
+ rc = output_headers(r, headers_av);
+ if (rc != OK) return rc;
+
+ body = av_fetch(res_av, 2, 0);
+ if (!SvROK(*body)) {
+ server_error(r, "response body must be a reference");
+ return HTTP_INTERNAL_SERVER_ERROR;
+ }
+ rc = output_body(r, *body);
+
+ return rc;
+}
+
+static void init_perl_variables(request_rec *r)
+{
+ GV *exit_gv = gv_fetchpv("CORE::GLOBAL::exit", TRUE, SVt_PVCV);
+ GvCV(exit_gv) = get_cv("ModPSGI::exit", TRUE);
+ GvIMPORTED_CV_on(exit_gv);
+ sv_setpv_mg(get_sv("0", FALSE), r->server->process->argv[0]);
+ hv_store(GvHV(PL_envgv), "MOD_PSGI", 8, newSVpv(MOD_PSGI_VERSION, 0), 0);
+}
+
+static PerlInterpreter *init_perl(request_rec *r)
+{
+ int argc = 0;
+ char *argv[] = { "", NULL };
+ char **envp = NULL;
+ PerlInterpreter *perlinterp;
+ PERL_SYS_INIT3(&argc, (char ***) argv, &envp);
+ perlinterp = perl_alloc();
+ PL_perl_destruct_level = 1;
+ perl_construct(perlinterp);
+ perl_parse(perlinterp, xs_init, argc, argv, envp);
+ PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
+ perl_run(perlinterp);
+ init_perl_variables(r);
+ return perlinterp;
+}
+
+static void *destroy_perl(PerlInterpreter *perlinterp)
+{
+ PL_perl_destruct_level = 1;
+ perl_destruct(perlinterp);
+ perl_free(perlinterp);
+ PERL_SYS_TERM();
+}
+
+static int psgi_handler(request_rec *r)
+{
+ SV *app, *env, *res;
+ PerlInterpreter *perlinterp;
+ psgi_dir_config *c;
+ int rc;
+
+ if (strcmp(r->handler, "psgi")) {
+ return DECLINED;
+ }
+
+ c = (psgi_dir_config *) ap_get_module_config(r->per_dir_config, &psgi_module);
+
+ if (c->psgi_app == NULL) {
+ ap_log_error(APLOG_MARK, APLOG_NOERRNO|APLOG_NOTICE, 0, r->server,
+ "PSGIApp not configured");
+ return DECLINED;
+ }
+
+ perlinterp = init_perl(r);
+ app = load_psgi(r, c->psgi_app);
+ if (app == NULL) {
+ rc = HTTP_INTERNAL_SERVER_ERROR;
+ goto exit;
+ }
+ env = make_env(r);
+ res = run_app(r, app, env);
+ if (res == NULL) {
+ server_error(r, "invalid response");
+ rc = HTTP_INTERNAL_SERVER_ERROR;
+ goto exit;
+ }
+ rc = output_response(r, res);
+ goto exit;
+exit:
+ destroy_perl(perlinterp);
+ return rc;
+}
+
+static int supported_mpm()
+{
+ int result;
+ ap_mpm_query(AP_MPMQ_IS_FORKED, &result);
+ return result;
+}
+
+static void psgi_register_hooks(apr_pool_t *p)
+{
+ if (supported_mpm()) {
+ ap_hook_handler(psgi_handler, NULL, NULL, APR_HOOK_MIDDLE);
+ } else {
+ server_error(NULL, "mod_psgi only supports prefork mpm");
+ }
+}
+
+static void *create_dir_config(apr_pool_t *p, char *path)
+{
+ psgi_dir_config *c = apr_pcalloc(p, sizeof(psgi_dir_config));
+ c->psgi_app = NULL;
+ return (void *) c;
+}
+
+static const char *cmd_psgi_app(cmd_parms *cmd, void *conf, const char *v)
+{
+ psgi_dir_config *c = (psgi_dir_config *) conf;
+ c->psgi_app = (char *) apr_pstrdup(cmd->pool, v);
+ return NULL;
+}
+
+static const command_rec command_table[] = {
+ AP_INIT_TAKE1("PSGIApp", cmd_psgi_app, NULL,
+ ACCESS_CONF, "set PSGI application"),
+ { NULL }
+};
+
+module AP_MODULE_DECLARE_DATA psgi_module = {
+ STANDARD20_MODULE_STUFF,
+ create_dir_config, /* create per-dir config structures */
+ NULL, /* merge per-dir config structures */
+ NULL, /* create per-server config structures */
+ NULL, /* merge per-server config structures */
+ command_table, /* table of config file commands */
+ psgi_register_hooks /* register hooks */
+};
+
4 modules.mk
@@ -0,0 +1,4 @@
+mod_psgi.la: mod_psgi.slo
+ $(SH_LINK) -rpath $(libexecdir) -module -avoid-version mod_psgi.lo
+DISTCLEAN_TARGETS = modules.mk
+shared = mod_psgi.la
117 t/00_output.t
@@ -0,0 +1,117 @@
+use strict;
+use warnings;
+use t::TestModPSGI;
+
+BEGIN {
+ no warnings 'once';
+ $YAML::LoadCode = 1;
+}
+
+{
+ package t::ModPSGIHandle;
+ sub new { bless \my $i, $_[0] }
+ sub getline {
+ my $self = shift;
+ return $$self if $$self++ < 3;
+ return;
+ }
+ sub close {
+ my $self = shift;
+# warn "close called\nself: $$self";
+ }
+}
+
+return eval_response_app if running_in_mod_psgi;
+
+run_eval_request;
+
+__END__
+
+=== simple
+--- request
+method: GET
+code: |
+ [ 200, [ 'Content-Type' => 'text/plain' ], ['test'] ]
+--- response
+is_success: 1
+content: test
+code: 200
+content_type: text/plain
+
+=== status
+--- request
+method: GET
+code: |
+ [ 404, [ 'Content-Type' => 'text/plain' ], [ 'Not Found' ] ]
+--- response
+is_success: not ok
+code: 404
+content: Not Found
+
+=== headers
+--- request
+method: GET
+code: |
+ [ 200, [ 'Content-Type' => 'text/plain', 'X-ModPSGI' => 1 ], [ '' ] ]
+--- response
+is_success: ok
+content_type: text/plain
+header:
+ X-ModPSGI: 1
+
+=== auto set content_length
+--- request
+method: GET
+code: |
+ [ 200, [ 'Content-Type' => 'text/plain' ], ['test'] ]
+--- response
+is_success: ok
+content: test
+code: 200
+content_length: 4
+
+=== multiple body
+--- request
+method: GET
+code: |
+ [ 200, [ 'Content-Type' => 'text/plain' ], ['foo', 'bar'] ]
+--- response
+is_success: ok
+content: foobar
+
+=== body filehandle
+--- request
+method: GET
+code: !perl/code |
+ {
+ require Path::Class;
+ my $file = Path::Class::file($0)->absolute;
+ qq{
+ open my \$fh, '<', "$file" or die \$!;
+ [ 200, [ 'Content-Type' => 'text/plain' ], \$fh ];
+ };
+ }
+--- response
+is_success: ok
+content_length: !perl/code |
+ {
+ require Path::Class;
+ my $file = Path::Class::file($0);
+ $file->stat->size;
+ }
+content: !perl/code |
+ {
+ require Path::Class;
+ my $file = Path::Class::file($0);
+ scalar $file->slurp;
+ }
+
+=== body filehandle like object
+--- request
+method: GET
+code: |
+ [ 200, [ 'Content-Type' => 'text/plain' ], t::ModPSGIHandle->new ]
+--- response
+is_success: ok
+content: 123
+
21 t/01_lint.t
@@ -0,0 +1,21 @@
+use strict;
+use warnings;
+use t::TestModPSGI;
+
+return eval_body_app if running_in_mod_psgi;
+
+run_eval_request;
+
+__END__
+
+=== Lint OK
+--- request
+method: GET
+code: |
+ require Plack::Lint;
+ eval { Plack::Lint->validate_env($env) };
+ $@ || 'valid env';
+--- response
+is_success: ok
+content: valid env
+
68 t/02_input.t
@@ -0,0 +1,68 @@
+use strict;
+use warnings;
+use t::TestModPSGI;
+
+return eval_body_app if running_in_mod_psgi;
+
+run_eval_request;
+
+__END__
+
+=== isa
+--- request
+method: GET
+code: |
+ $env->{'psgi.input'}->isa('ModPSGI::Input');
+--- response
+is_success: ok
+content: ok
+
+=== can read
+--- request
+method: GET
+code: |
+ $env->{'psgi.input'}->can('read');
+--- response
+is_success: ok
+content: ok
+
+=== read
+--- request
+method: POST
+code: |
+ $env->{'psgi.input'}->read(my $buf, 1);
+ $buf;
+args:
+ - foo: bar
+--- response
+is_success: ok
+content: f
+
+=== read all
+--- request
+method: POST
+code: |
+ $env->{'psgi.input'}->read(my $buf, $env->{CONTENT_LENGTH});
+ $buf;
+args:
+ - a: 1
+ b: 2
+--- response
+is_success: ok
+content: a=1&b=2
+
+=== read each bytes
+--- request
+method: POST
+code: |
+ my ($buf, $read);
+ while ($env->{'psgi.input'}->read($read, 1)) {
+ $buf .= $read;
+ }
+ $buf;
+args:
+ - foo: bar
+--- response
+is_success: ok
+content: foo=bar
+
37 t/03_errors.t
@@ -0,0 +1,37 @@
+use strict;
+use warnings;
+use t::TestModPSGI;
+
+return eval_body_app if running_in_mod_psgi;
+
+run_eval_request;
+
+__END__
+
+=== isa
+--- request
+method: get
+code: |
+ $env->{'psgi.errors'}->isa('ModPSGI::Errors');
+--- response
+is_success: ok
+content: ok
+
+=== can print
+--- request
+method: get
+code: |
+ $env->{'psgi.errors'}->can('print');
+--- response
+is_success: ok
+content: ok
+
+=== print
+--- request
+method: get
+code: |
+ $env->{'psgi.errors'}->print('this is test');
+--- response
+is_success: ok
+content: ok
+
28 t/04_die.t
@@ -0,0 +1,28 @@
+use strict;
+use warnings;
+use t::TestModPSGI;
+
+return eval_body_app if running_in_mod_psgi;
+
+run_eval_request;
+
+__END__
+
+=== app exit but apache process is still running
+--- request
+method: GET
+code: |
+ $env->{'psgi.errors'}->print('test exit');
+ exit;
+--- response
+is_success: not ok
+code: 500
+=== app die but apache process is still running
+--- request
+method: GET
+code: |
+ die 'test die';
+--- response
+is_success: not ok
+code: 500
+
9 t/Makefile
@@ -0,0 +1,9 @@
+all: conf
+test: test.conf
+ prove -I.. .
+conf: test.conf
+test.conf: test.conf.tt *.t mkconf.pl
+ ./mkconf.pl --input $< --output $@
+clean:
+ rm -f test.conf
+.PHONY: conf clean test
118 t/TestModPSGI.pm
@@ -0,0 +1,118 @@
+package t::TestModPSGI;
+use strict;
+use warnings;
+use Test::Base -Base;
+
+use File::Basename;
+use URI::Escape;
+use List::Util qw(sum);
+
+our @EXPORT = qw(
+ running_in_mod_psgi eval_body_app eval_response_app
+ run_eval_request
+);
+
+our $Host = '127.0.0.1';
+our $Path = '/psgi/t';
+
+BEGIN {
+ no warnings 'redefine';
+ *Test::Base::run_compare = sub {}; # XXX
+}
+
+sub running_in_mod_psgi() {
+ exists $ENV{MOD_PSGI};
+}
+
+sub eval_body_app() {
+ sub {
+ my $env = shift;
+ my $code = uri_unescape($env->{QUERY_STRING});
+ my $body = eval $code;
+ [ 200, [ 'Content-Type' => 'text/plain' ], [ $body ] ];
+ };
+}
+
+sub eval_response_app() {
+ sub {
+ my $env = shift;
+ my $code = uri_unescape($env->{QUERY_STRING});
+ eval $code;
+ };
+}
+
+our $UA;
+
+sub ua() {
+ require LWP::UserAgent;
+ $UA ||= LWP::UserAgent->new;
+}
+
+sub eval_request($$$;@) {
+ my ($file, $method, $code, @args) = @_;
+ if (ref $code eq 'CODE') {
+ no warnings 'prototype';
+ return eval_request($file, $method, $code->(), @args);
+ }
+ my $uri = sprintf 'http://%s%s/%s?%s', $Host, $Path,
+ basename($file), uri_escape($code);
+ $method = lc $method;
+ ua->$method($uri, @args);
+}
+
+sub setup_filters() {
+ filters {
+ request => 'yaml',
+ response => 'yaml',
+ };
+}
+
+sub setup_plan() {
+ plan tests => sum map { scalar keys %{$_->response} } blocks;
+}
+
+sub setup_tests() {
+ setup_filters;
+ setup_plan;
+}
+
+sub compare($$$;@) {
+ my ($res, $input, $expected, @args) = @_;
+ my $ref = ref $expected;
+ if ($ref eq 'CODE') {
+ no warnings 'prototype';
+ compare($res, $input, $expected->());
+ } elsif ($ref eq 'Regexp') {
+ like $res->$input(@args), $expected;
+ } elsif ($ref eq 'HASH') {
+ while (my ($key, $val) = each %$expected) {
+ no warnings 'prototype';
+ compare($res, $input, $val, $key);
+ }
+ } elsif ($ref) {
+ is_deeply $res->$input(@args), $expected;
+ } elsif ($expected eq 'ok') {
+ ok $res->$input(@args);
+ } elsif ($expected eq 'not ok') {
+ ok !$res->$input(@args);
+ } else {
+ is $res->$input(@args), $expected;
+ }
+}
+
+sub run_eval_request() {
+ my ($pkg, $file) = caller;
+ setup_tests;
+ run {
+ my $block = shift;
+ my $req = $block->request;
+ my $res = eval_request($file, $req->{method}, $req->{code},
+ @{$req->{args}});
+ my $response = $block->response;
+ while (my ($input, $expected) = each %$response) {
+ compare($res, $input, $expected);
+ }
+ };
+}
+
+1;
62 t/mkconf.pl
@@ -0,0 +1,62 @@
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use FindBin '$Bin';
+use File::Spec;
+use lib File::Spec->catfile($Bin, '..');
+
+use t::TestModPSGI;
+use Getopt::Long;
+use Template;
+use Cwd;
+
+main() unless caller;
+
+sub main {
+ my $opts = get_opt();
+ my $params = make_params();
+ render($opts, $params);
+}
+
+sub get_opt {
+ my $opts = {
+ input => File::Spec->catfile($Bin, 'test.conf.tt'),
+ output => File::Spec->catfile($Bin, 'test.conf'),
+ };
+ GetOptions($opts, 'input=s', 'output=s')
+ or die "usage: $0 --input FILE --output FILE";
+ $opts;
+}
+
+sub chdir_do {
+ my ($dir, $code) = @_;
+ my $old_cwd = getcwd;
+ chdir $dir;
+ eval { $code->(); };
+ my $err = $@;
+ chdir $old_cwd;
+ die $err if $err;
+}
+
+sub make_params {
+ my (@files, $dir);
+ chdir_do $Bin => sub {
+ push @files, $_ while <[0-9]*.t>;
+ $dir = getcwd;
+ require 'suite.t';
+ };
+ no warnings 'once';
+ +{
+ dir => $dir,
+ files => \@files,
+ path => $t::TestModPSGI::Path,
+ port => $main::Port,
+ };
+}
+
+sub render {
+ my ($opts, $params) = @_;
+ my $tt = Template->new(ABSOLUTE => 1);
+ $tt->process($opts->{input}, $params, $opts->{output}) or die $tt->error;
+}
+
53 t/suite.t
@@ -0,0 +1,53 @@
+use strict;
+use warnings;
+
+use Test::More;
+use Plack::Test::Suite;
+use Path::Class;
+
+our $Port = $ENV{PLACK_TEST_SUITE_PORT} || 8080;
+
+$Plack::Test::Suite::BaseDir = do {
+ my $dir = do {
+ if ($ENV{PLACK_DIR}) {
+ dir($ENV{PLACK_DIR})->file('t')->stringify;
+ } else {
+ my $pmdir = file($INC{'Plack/Test/Suite.pm'})->dir;
+ $pmdir->file('..', '..', '..', 't')->resolve->stringify;
+ }
+ };
+ die "Plack test dir 't' not found" unless -e $dir;
+ $dir;
+};
+
+return \&app if $ENV{MOD_PSGI};
+runtests() unless caller;
+
+sub app {
+ my $env = shift;
+ my $index = $env->{HTTP_X_PLACK_TEST};
+ my $test = $Plack::Test::Suite::TEST[$index];
+ note $test->[0];
+ my $app = $test->[2];
+ my $res = $app->($env);
+ ok $res;
+ done_testing;
+ $res;
+}
+
+sub runtests {
+ require LWP::UserAgent;
+ my $ua = LWP::UserAgent->new;
+ my $index = 0;
+ Plack::Test::Suite->runtests(sub {
+ my ($name, $reqgen, $handler, $test) = @_;
+ note $name;
+ my $req = $reqgen->($Port);
+ $req->headers->header('X-Plack-Test' => $index++);
+ my $res = $ua->request($req);
+ local $Test::Builder::Level = $Test::Builder::Level + 3;
+ $test->($res, $Port);
+ });
+ done_testing;
+}
+
18 t/test.conf.tt
@@ -0,0 +1,18 @@
+LoadModule psgi_module modules/mod_psgi.so
+PassEnv PERL5LIB
+[% FOR file = files %]
+<Location [% path %]/[% file %]>
+ SetHandler psgi
+ PSGIApp [% dir %]/[% file %]
+</Location>
+[% END -%]
+
+NameVirtualHost *:[% port %]
+Listen [% port %]
+<VirtualHost *:[% port %]>
+ ServerName plack.test.suite
+ <Location />
+ SetHandler psgi
+ PSGIApp [% dir %]/suite.t
+ </Location>
+</VirtualHost>
Please sign in to comment.
Something went wrong with that request. Please try again.