Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 582 lines (515 sloc) 15.342 kb
f61f1885 »
2009-09-18 Initial commit
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 #include "EXTERN.h"
26 #include "perl.h"
27 #include "XSUB.h"
28 #define NEED_eval_pv
29 #define NEED_newRV_noinc
30 #define NEED_sv_2pv_flags
31 #include "ppport.h"
32
33 #ifdef DEBUG
34 #define TRACE(...) ap_log_error(APLOG_MARK, APLOG_NOERRNO|APLOG_NOTICE, 0, NULL, __VA_ARGS__)
35 #endif
36
37 module AP_MODULE_DECLARE_DATA psgi_module;
38
39 typedef struct {
ace12729 »
2009-10-03 Make PerlInterpreter persistent
40 char *file;
41 SV *app;
f61f1885 »
2009-09-18 Initial commit
42 } psgi_dir_config;
43
ace12729 »
2009-10-03 Make PerlInterpreter persistent
44 static PerlInterpreter *perlinterp;
e284234d »
2009-10-03 Call PERL_SYS_INIT3,PERL_SYS_TERM once per process
45
f61f1885 »
2009-09-18 Initial commit
46 static void server_error(request_rec *r, const char *fmt, ...)
47 {
48 va_list argp;
49 const char *msg;
50 va_start(argp, fmt);
51 msg = apr_pvsprintf(r->pool, fmt, argp);
52 va_end(argp);
53 ap_log_error(APLOG_MARK, APLOG_NOERRNO|APLOG_ERR, 0, r->server, "%s", msg);
54 }
55
56 EXTERN_C void xs_init (pTHX);
57
58 EXTERN_C void boot_DynaLoader (pTHX_ CV* cv);
59
60 XS(ModPSGI_exit);
61 XS(ModPSGI_exit)
62 {
63 dXSARGS;
64 croak("exit");
65 XSRETURN(0);
66 }
67
68 XS(ModPSGI_Input_read);
69 XS(ModPSGI_Input_read)
70 {
71 dXSARGS;
72 SV *self = ST(0);
73 SV *buf = ST(1);
74 request_rec *r = (request_rec *) mg_find(SvRV(self), PERL_MAGIC_ext)->mg_obj;
75 apr_size_t len = SvIV(ST(2));
76 apr_size_t offset = items >= 4 ? SvIV(ST(3)) : 0;
77 apr_status_t rv;
78 apr_bucket_brigade *bb;
79 apr_bucket *bucket;
80 int eos = 0;
81 SV *ret;
82 dXSTARG;
83
84 ret = newSVpv("", 0);
85 bb = apr_brigade_create(r->pool, r->connection->bucket_alloc);
86 rv = ap_get_brigade(r->input_filters, bb, AP_MODE_READBYTES, APR_BLOCK_READ, len);
87 if (rv != APR_SUCCESS) {
88 ST(0) = &PL_sv_undef;
89 XSRETURN(1);
90 }
91
92 for (bucket = APR_BRIGADE_FIRST(bb);
93 bucket != APR_BRIGADE_SENTINEL(bb);
94 bucket = APR_BUCKET_NEXT(bucket)) {
95 const char *bbuf;
96 apr_size_t blen;
97 if (APR_BUCKET_IS_EOS(bucket)) {
98 eos = 1;
99 break;
100 }
101 if (APR_BUCKET_IS_METADATA(bucket)) {
102 continue;
103 }
104 apr_bucket_read(bucket, &bbuf, &blen, APR_BLOCK_READ);
105 sv_catpvn(ret, bbuf, blen);
106 }
107
108 sv_setsv(buf, ret);
109 ST(0) = sv_2mortal(newSViv(SvCUR(buf)));
110 XSRETURN(1);
111 }
112
113 XS(ModPSGI_Errors_print);
114 XS(ModPSGI_Errors_print)
115 {
116 dXSARGS;
117 SV *self = ST(0);
118 SV *msg = ST(1);
119 dXSTARG;
120 request_rec *r = (request_rec *) mg_find(SvRV(self), PERL_MAGIC_ext)->mg_obj;
121 ap_log_error(APLOG_MARK, APLOG_NOERRNO|APLOG_ERR, 0, r->server, "%s", SvPV_nolen(msg));
122 ST(0) = newSViv(1);
123 XSRETURN(1);
124 }
125
126 EXTERN_C void
127 xs_init(pTHX)
128 {
129 char *file = __FILE__;
130 dXSUB_SYS;
131
132 newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);
133 newXS("ModPSGI::exit", ModPSGI_exit, file);
134 newXSproto("ModPSGI::Input::read", ModPSGI_Input_read, file, "$$$;$");
135 newXSproto("ModPSGI::Errors::print", ModPSGI_Errors_print, file, "$$");
136 }
137
138 static int copy_env(void *rec, const char *key, const char *val)
139 {
fe98cae8 »
2009-10-03 use dTHX
140 dTHX;
f61f1885 »
2009-09-18 Initial commit
141 HV *env = (HV *) rec;
142 hv_store(env, key, strlen(key), newSVpv(val, 0), 0);
143 return 1;
144 }
145
146 static SV *make_env(request_rec *r)
147 {
fe98cae8 »
2009-10-03 use dTHX
148 dTHX;
f61f1885 »
2009-09-18 Initial commit
149 HV *env;
150 AV *version;
151 char *url_scheme;
152 SV *input, *errors;
153
154 env = newHV();
155
156 ap_add_cgi_vars(r);
157 ap_add_common_vars(r);
158 if (apr_table_get(r->subprocess_env, "PATH_INFO") == NULL) {
159 apr_table_set(r->subprocess_env, "PATH_INFO", "");
160 }
161 if (strcmp(apr_table_get(r->subprocess_env, "SCRIPT_NAME"), "/") == 0
162 && strcmp(apr_table_get(r->subprocess_env, "PATH_INFO"), "") == 0) {
163 apr_table_set(r->subprocess_env, "PATH_INFO", "/");
164 apr_table_set(r->subprocess_env, "SCRIPT_NAME", "");
165 }
166 apr_table_do(copy_env, env, r->subprocess_env, NULL);
167
168 version = newAV();
169 av_push(version, newSViv(1));
170 av_push(version, newSViv(0));
171 hv_store(env, "psgi.version", 12, newRV_inc((SV *) version), 0);
172
173 url_scheme = apr_table_get(r->subprocess_env, "HTTPS") == NULL ? "http" : "https";
174 hv_store(env, "psgi.url_scheme", 15, newSVpv(url_scheme, 0), 0);
175
176 input = newRV_noinc(newSV(0));
177 sv_magic(SvRV(input), NULL, PERL_MAGIC_ext, NULL, 0);
178 mg_find(SvRV(input), PERL_MAGIC_ext)->mg_obj = (void *) r;
179 sv_bless(input, gv_stashpv("ModPSGI::Input", 1));
180 hv_store(env, "psgi.input", 10, input, 0);
181
182 errors = newRV_noinc(newSV(0));
183 sv_magic(SvRV(errors), NULL, PERL_MAGIC_ext, NULL, 0);
184 mg_find(SvRV(errors), PERL_MAGIC_ext)->mg_obj = (void *) r;
185 sv_bless(errors, gv_stashpv("ModPSGI::Errors", 1));
186 hv_store(env, "psgi.errors", 11, errors, 0);
187
188 hv_store(env, "psgi.multithread", 16, newSViv(0), 0);
189 hv_store(env, "psgi.multiprocess", 17, newSViv(1), 0);
190 hv_store(env, "psgi.run_once", 13, newSViv(1), 0);
191 hv_store(env, "psgi.async", 10, newSViv(0), 0);
192
193 return newRV_inc((SV *) env);
194 }
195
196 static SV *run_app(request_rec *r, SV *app, SV *env)
197 {
fe98cae8 »
2009-10-03 use dTHX
198 dTHX;
f61f1885 »
2009-09-18 Initial commit
199 int count;
200 SV *res;
201 dSP;
202 ENTER;
203 SAVETMPS;
204 PUSHMARK(SP) ;
205 XPUSHs(sv_2mortal(env));
206 PUTBACK;
207
208 count = call_sv(app, G_EVAL|G_KEEPERR|G_SCALAR);
209 SPAGAIN;
210 if (SvTRUE(ERRSV)) {
211 res = NULL;
212 server_error(r, "%s", SvPV_nolen(ERRSV));
213 POPs;
214 } else if (count > 0) {
215 res = POPs;
216 SvREFCNT_inc(res);
217 } else {
218 res = NULL;
219 }
220 PUTBACK;
221 FREETMPS;
222 LEAVE;
223 return res;
224 }
225
226 static int output_status(request_rec *r, SV *status)
227 {
fe98cae8 »
2009-10-03 use dTHX
228 dTHX;
f61f1885 »
2009-09-18 Initial commit
229 int s = SvIV(status);
230 if (s < 100) {
231 server_error(r, "invalid response status %d", s);
232 return HTTP_INTERNAL_SERVER_ERROR;
233 }
234 r->status = s;
235 return OK;
236 }
237
238 static int output_headers(request_rec *r, AV *headers)
239 {
fe98cae8 »
2009-10-03 use dTHX
240 dTHX;
f61f1885 »
2009-09-18 Initial commit
241 SV *key_sv, *val_sv;
242 char *key, *val;
243 while (av_len(headers) > -1) {
244 key_sv = av_shift(headers);
245 val_sv = av_shift(headers);
246 if (key_sv == NULL || val_sv == NULL) break;
247 key = SvPV_nolen(key_sv);
248 val = SvPV_nolen(val_sv);
aab7f6a0 »
2009-10-03 Do not check header value
249 if (strcmp(key, "Content-Type") == 0) {
f61f1885 »
2009-09-18 Initial commit
250 r->content_type = apr_pstrdup(r->pool, val);
251 } else if (strcmp(key, "Status") == 0) {
252 server_error(r, "headers must not contain a Status");
253 return HTTP_INTERNAL_SERVER_ERROR;
254 } else {
255 apr_table_add(r->headers_out, key, val);
256 }
257 }
258 return OK;
259 }
260
261 static int respond_to(SV *obj, const char *method)
262 {
fe98cae8 »
2009-10-03 use dTHX
263 dTHX;
f61f1885 »
2009-09-18 Initial commit
264 int res;
265 dSP;
266 ENTER;
267 SAVETMPS;
268 PUSHMARK(SP);
269 XPUSHs(obj);
270 XPUSHs(sv_2mortal(newSVpv(method, 0)));
271 PUTBACK;
272
273 call_method("can", G_SCALAR);
274 SPAGAIN;
275 res = SvROK(POPs);
276 PUTBACK;
277 FREETMPS;
278 LEAVE;
279 return res;
280 }
281
282 static void set_content_length(request_rec *r, apr_off_t length)
283 {
284 if (apr_table_get(r->headers_out, "Content-Length") == NULL) {
285 apr_table_add(r->headers_out, "Content-Length", apr_off_t_toa(r->pool, length));
286 }
287 }
288
289 static int output_body_ary(request_rec *r, AV *bodys)
290 {
fe98cae8 »
2009-10-03 use dTHX
291 dTHX;
f61f1885 »
2009-09-18 Initial commit
292 SV **body;
293 I32 i;
294 I32 lastidx;
295 char *buf;
296 STRLEN len;
297 apr_off_t clen;
298
299 lastidx = av_len(bodys);
300 for (i = 0; i <= lastidx; i++) {
301 body = av_fetch(bodys, i, 0);
302 if (SvOK(*body)) {
303 buf = SvPV(*body, len);
304 ap_rwrite(buf, len, r);
305 clen += len;
306 }
307 }
308 set_content_length(r, clen);
309 return OK;
310 }
311
312 static int output_body_obj(request_rec *r, SV *obj, int type)
313 {
fe98cae8 »
2009-10-03 use dTHX
314 dTHX;
f61f1885 »
2009-09-18 Initial commit
315 SV *buf_sv, *rs;
316 apr_off_t clen = 0;
317 STRLEN len;
318 char *buf;
319 int count;
320
321 if (type == SVt_PVMG && !respond_to(obj, "getline")) {
322 server_error(r, "response body object must be able to getline");
323 return HTTP_INTERNAL_SERVER_ERROR;
324 }
325
326 dSP;
327 ENTER;
328 SAVETMPS;
329 SAVESPTR(PL_rs);
330 PL_rs = newRV_inc(newSViv(AP_IOBUFSIZE));
331 while (1) {
332 PUSHMARK(SP);
333 XPUSHs(obj);
334 PUTBACK;
335 count = call_method("getline", G_SCALAR);
336 if (count != 1) croak("Big trouble\n");
337 SPAGAIN;
338 buf_sv = POPs;
339 if (SvOK(buf_sv)) {
340 buf = SvPV(buf_sv, len);
341 clen += len;
342 ap_rwrite(buf, len, r);
343 } else {
344 break;
345 }
346 }
347 set_content_length(r, len);
348 PUSHMARK(SP);
349 XPUSHs(obj);
350 PUTBACK;
351 call_method("close", G_DISCARD);
352 SPAGAIN;
353 PUTBACK;
354 FREETMPS;
355 LEAVE;
356 return OK;
357 }
358
359 static int output_body(request_rec *r, SV *body)
360 {
fe98cae8 »
2009-10-03 use dTHX
361 dTHX;
f61f1885 »
2009-09-18 Initial commit
362 int rc, type;
363 switch (type = SvTYPE(SvRV(body))) {
364 case SVt_PVAV:
365 rc = output_body_ary(r, (AV *) SvRV(body));
366 break;
367 case SVt_PVGV:
368 require_pv("IO/Handle.pm");
369 case SVt_PVMG:
370 rc = output_body_obj(r, body, type);
371 break;
372 default:
373 server_error(r, "response body must be an array reference or object");
374 rc = HTTP_INTERNAL_SERVER_ERROR;
375 break;
376 }
377 return rc;
378 }
379
380 static int output_response(request_rec *r, SV *res)
381 {
fe98cae8 »
2009-10-03 use dTHX
382 dTHX;
f61f1885 »
2009-09-18 Initial commit
383 AV *res_av;
384 SV **status;
385 SV **headers;
386 AV *headers_av;
387 SV **body;
388 int rc;
389
390 if (!SvROK(res) || SvTYPE(SvRV(res)) != SVt_PVAV) {
391 server_error(r, "response must be an array reference");
392 return HTTP_INTERNAL_SERVER_ERROR;
393 }
394 res_av = (AV *) SvRV(res);
395 if (av_len(res_av) != 2) {
396 server_error(r, "response must have 3 elements");
397 return HTTP_INTERNAL_SERVER_ERROR;
398 }
399
400 status = av_fetch(res_av, 0, 0);
401 if (!SvOK(*status)) {
402 server_error(r, "response status must be a scalar value");
403 return HTTP_INTERNAL_SERVER_ERROR;
404 }
405 rc = output_status(r, *status);
406 if (rc != OK) return rc;
407
408 headers = av_fetch(res_av, 1, 0);
409 if (!SvROK(*headers) || SvTYPE(SvRV(*headers)) != SVt_PVAV) {
410 server_error(r, "response headers must be an array reference");
411 return HTTP_INTERNAL_SERVER_ERROR;
412 }
413 headers_av = (AV *) SvRV(*headers);
414 if ((av_len(headers_av) + 1) % 2 != 0) {
415 server_error(r, "num of response headers must be even");
416 return HTTP_INTERNAL_SERVER_ERROR;
417 }
418 rc = output_headers(r, headers_av);
419 if (rc != OK) return rc;
420
421 body = av_fetch(res_av, 2, 0);
422 if (!SvROK(*body)) {
423 server_error(r, "response body must be a reference");
424 return HTTP_INTERNAL_SERVER_ERROR;
425 }
426 rc = output_body(r, *body);
427
428 return rc;
429 }
430
ace12729 »
2009-10-03 Make PerlInterpreter persistent
431 static void init_perl_variables()
f61f1885 »
2009-09-18 Initial commit
432 {
fe98cae8 »
2009-10-03 use dTHX
433 dTHX;
f61f1885 »
2009-09-18 Initial commit
434 GV *exit_gv = gv_fetchpv("CORE::GLOBAL::exit", TRUE, SVt_PVCV);
435 GvCV(exit_gv) = get_cv("ModPSGI::exit", TRUE);
436 GvIMPORTED_CV_on(exit_gv);
437 hv_store(GvHV(PL_envgv), "MOD_PSGI", 8, newSVpv(MOD_PSGI_VERSION, 0), 0);
438 }
439
4e00d638 »
2009-10-03 init and destroy in handler
440 static int psgi_handler(request_rec *r)
f61f1885 »
2009-09-18 Initial commit
441 {
442 SV *app, *env, *res;
443 psgi_dir_config *c;
444 int rc;
445
446 if (strcmp(r->handler, "psgi")) {
447 return DECLINED;
448 }
449
450 c = (psgi_dir_config *) ap_get_module_config(r->per_dir_config, &psgi_module);
451
ace12729 »
2009-10-03 Make PerlInterpreter persistent
452 if (c->file == NULL) {
f61f1885 »
2009-09-18 Initial commit
453 ap_log_error(APLOG_MARK, APLOG_NOERRNO|APLOG_NOTICE, 0, r->server,
454 "PSGIApp not configured");
455 return DECLINED;
456 }
457
458 env = make_env(r);
ace12729 »
2009-10-03 Make PerlInterpreter persistent
459 res = run_app(r, c->app, env);
f61f1885 »
2009-09-18 Initial commit
460 if (res == NULL) {
461 server_error(r, "invalid response");
462 rc = HTTP_INTERNAL_SERVER_ERROR;
463 goto exit;
464 }
465 rc = output_response(r, res);
466 goto exit;
467 exit:
468 return rc;
469 }
470
471 static int supported_mpm()
472 {
473 int result;
474 ap_mpm_query(AP_MPMQ_IS_FORKED, &result);
475 return result;
476 }
477
e284234d »
2009-10-03 Call PERL_SYS_INIT3,PERL_SYS_TERM once per process
478 static apr_status_t psgi_child_exit(void *p)
479 {
ace12729 »
2009-10-03 Make PerlInterpreter persistent
480 PerlInterpreter *my_perl = perlinterp;
481 PL_perl_destruct_level = 1;
482 perl_destruct(my_perl);
483 perl_free(my_perl);
e284234d »
2009-10-03 Call PERL_SYS_INIT3,PERL_SYS_TERM once per process
484 PERL_SYS_TERM();
485 return OK;
486 }
487
488 static void psgi_child_init(apr_pool_t *p, server_rec *s)
489 {
490 apr_pool_cleanup_register(p, NULL, psgi_child_exit, psgi_child_exit);
491 }
492
ace12729 »
2009-10-03 Make PerlInterpreter persistent
493 static SV *load_psgi(apr_pool_t *pool, const char *file)
494 {
495 dTHX;
496 SV *app;
497 char *code;
498
499 code = apr_psprintf(pool, "do q\"%s\" or die $@",
500 ap_escape_quotes(pool, file));
501 app = eval_pv(code, FALSE);
502
503 if (SvTRUE(ERRSV)) {
504 ap_log_error(APLOG_MARK, APLOG_NOERRNO|APLOG_ERR, 0, NULL, "%s", SvPV_nolen(ERRSV));
505 return NULL;
506 }
507 if (!SvOK(app) || !SvROK(app) || SvTYPE(SvRV(app)) != SVt_PVCV) {
508 ap_log_error(APLOG_MARK, APLOG_NOERRNO|APLOG_ERR, 0, NULL,
509 "%s does not return an application code reference", file);
510 return NULL;
511 }
512 return app;
513 }
514
515 static int psgi_pre_configured = 0;
516
517 static int psgi_pre_config(apr_pool_t *pconf, apr_pool_t *plog, apr_pool_t *ptemp)
518 {
519 int argc = 2;
520 char *argv[] = { "perl", "-e;0", NULL };
521 char **envp = NULL;
522
523 if (psgi_pre_configured) return OK;
524 PERL_SYS_INIT3(&argc, (char ***) argv, &envp);
525 perlinterp = perl_alloc();
526 PL_perl_destruct_level = 1;
527 perl_construct(perlinterp);
528 perl_parse(perlinterp, xs_init, argc, argv, envp);
529 PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
530 perl_run(perlinterp);
531 init_perl_variables();
532 psgi_pre_configured++;
533 return OK;
534 }
535
f61f1885 »
2009-09-18 Initial commit
536 static void psgi_register_hooks(apr_pool_t *p)
537 {
538 if (supported_mpm()) {
ace12729 »
2009-10-03 Make PerlInterpreter persistent
539 ap_hook_pre_config(psgi_pre_config, NULL, NULL, APR_HOOK_MIDDLE);
e284234d »
2009-10-03 Call PERL_SYS_INIT3,PERL_SYS_TERM once per process
540 ap_hook_child_init(psgi_child_init, NULL, NULL, APR_HOOK_MIDDLE);
ace12729 »
2009-10-03 Make PerlInterpreter persistent
541 ap_hook_handler(psgi_handler, NULL, NULL, APR_HOOK_MIDDLE);
f61f1885 »
2009-09-18 Initial commit
542 } else {
ace12729 »
2009-10-03 Make PerlInterpreter persistent
543 ap_log_error(APLOG_MARK, APLOG_NOERRNO|APLOG_ERR, 0, NULL,
544 "mod_psgi only supports prefork mpm");
f61f1885 »
2009-09-18 Initial commit
545 }
546 }
547
548 static void *create_dir_config(apr_pool_t *p, char *path)
549 {
550 psgi_dir_config *c = apr_pcalloc(p, sizeof(psgi_dir_config));
ace12729 »
2009-10-03 Make PerlInterpreter persistent
551 c->file = NULL;
f61f1885 »
2009-09-18 Initial commit
552 return (void *) c;
553 }
554
555 static const char *cmd_psgi_app(cmd_parms *cmd, void *conf, const char *v)
556 {
557 psgi_dir_config *c = (psgi_dir_config *) conf;
ace12729 »
2009-10-03 Make PerlInterpreter persistent
558 c->file = (char *) apr_pstrdup(cmd->pool, v);
559 c->app = load_psgi(cmd->pool, c->file);
560 if (c->app == NULL) {
561 return apr_psprintf(cmd->pool, "%s had compilation errors.", c->file);
562 }
f61f1885 »
2009-09-18 Initial commit
563 return NULL;
564 }
565
566 static const command_rec command_table[] = {
567 AP_INIT_TAKE1("PSGIApp", cmd_psgi_app, NULL,
b991f345 »
2009-10-03 Allow PSGIApp in .htaccess
568 OR_LIMIT, "set PSGI application"),
f61f1885 »
2009-09-18 Initial commit
569 { NULL }
570 };
571
572 module AP_MODULE_DECLARE_DATA psgi_module = {
573 STANDARD20_MODULE_STUFF,
574 create_dir_config, /* create per-dir config structures */
575 NULL, /* merge per-dir config structures */
576 NULL, /* create per-server config structures */
577 NULL, /* merge per-server config structures */
578 command_table, /* table of config file commands */
579 psgi_register_hooks /* register hooks */
580 };
581
Something went wrong with that request. Please try again.