Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 791 lines (688 sloc) 20.967 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 */
03fb93eb »
2009-10-05 win32 porting.
16 #ifdef _WIN32
17 /* avoid to define duplicate definition of uid_t/gid_t in perl/CORE.h */
18 #define uid_t _uid_t
19 #define gid_t _gid_t
20 #endif
f61f1885 »
2009-09-18 Initial commit
21 #include "httpd.h"
22 #include "http_log.h"
23 #include "http_config.h"
24 #include "http_protocol.h"
25 #include "util_script.h"
26 #include "ap_config.h"
27 #include "ap_mpm.h"
377b40df »
2009-10-17 sendfile support. closes #1
28 #include "apr_file_io.h"
29 #include "apr_file_info.h"
03fb93eb »
2009-10-05 win32 porting.
30 #include "apr_buckets.h"
f61f1885 »
2009-09-18 Initial commit
31 #include "apr_strings.h"
c1156933 »
2009-10-04 'do $psgi_app' at post_config
32 #include "apr_hash.h"
f61f1885 »
2009-09-18 Initial commit
33
03fb93eb »
2009-10-05 win32 porting.
34 #ifdef _WIN32
35 /* use perl's uid_t/gid_t. disable apr's macros. */
36 #undef uid_t
37 #undef gid_t
38 #undef exit
39 #endif
40
f61f1885 »
2009-09-18 Initial commit
41 #include "EXTERN.h"
42 #include "perl.h"
43 #include "XSUB.h"
44 #define NEED_eval_pv
45 #define NEED_newRV_noinc
46 #define NEED_sv_2pv_flags
47 #include "ppport.h"
48
fae83c4b »
2009-10-17 oops, define CLEAR_ERRSV after #include.
49 #ifndef CLEAR_ERRSV /* should support in ppport.h ? */
50 #define CLEAR_ERRSV() STMT_START { sv_setpvn(ERRSV,"",0); if (SvMAGICAL(ERRSV)) { mg_free(ERRSV); } SvPOK_only(ERRSV); } STMT_END
51 #endif /* CLEAR_ERRSV */
52
03fb93eb »
2009-10-05 win32 porting.
53 #ifdef _WIN32
54 /* no use perl compatible macros. it break apr's structure. ex: bucket->link */
55 #undef link
56 #undef read
57 #endif
58
098e77e6 »
2009-10-04 ap_add_version_component
59 #define PSGI_HANDLER_NAME "psgi"
60
3cd211b5 »
2009-10-18 Added --enable-debug
61 #ifdef MOD_PSGI_DEBUG
f61f1885 »
2009-09-18 Initial commit
62 #define TRACE(...) ap_log_error(APLOG_MARK, APLOG_NOERRNO|APLOG_NOTICE, 0, NULL, __VA_ARGS__)
63 #endif
64
65 module AP_MODULE_DECLARE_DATA psgi_module;
66
67 typedef struct {
ace12729 »
2009-10-03 Make PerlInterpreter persistent
68 char *file;
430ccf9e »
2009-10-16 fix PATH_INFO and SCRIPT_NAME
69 char *location;
f61f1885 »
2009-09-18 Initial commit
70 } psgi_dir_config;
71
c1156933 »
2009-10-04 'do $psgi_app' at post_config
72 static PerlInterpreter *perlinterp = NULL;
73
27f555f3 »
2009-10-18 Removed temporary apr_array_header_t
74 static apr_hash_t *psgi_apps = NULL;
e284234d »
2009-10-03 Call PERL_SYS_INIT3,PERL_SYS_TERM once per process
75
f02b617f »
2009-10-18 set psgi.multi{process,thread} by ap_mpm_query
76 static int psgi_multiprocess = 0;
77
78 static int psgi_multithread = 0;
79
f61f1885 »
2009-09-18 Initial commit
80 static void server_error(request_rec *r, const char *fmt, ...)
81 {
82 va_list argp;
83 const char *msg;
84 va_start(argp, fmt);
85 msg = apr_pvsprintf(r->pool, fmt, argp);
86 va_end(argp);
87 ap_log_error(APLOG_MARK, APLOG_NOERRNO|APLOG_ERR, 0, r->server, "%s", msg);
88 }
89
90 EXTERN_C void xs_init (pTHX);
91
92 EXTERN_C void boot_DynaLoader (pTHX_ CV* cv);
93
94 XS(ModPSGI_exit);
95 XS(ModPSGI_exit)
96 {
97 dXSARGS;
d33389c2 »
2009-10-18 suppress warnings
98 int exitval = items > 0 ? SvIV(ST(0)) : 0;
22b60173 »
2009-10-17 suppress warnings
99 croak("exit(%d) was called", exitval);
e2c9fd57 »
2009-10-17 use XSRETURN_*
100 XSRETURN_UNDEF;
f61f1885 »
2009-09-18 Initial commit
101 }
102
103 XS(ModPSGI_Input_read);
104 XS(ModPSGI_Input_read)
105 {
106 dXSARGS;
107 SV *self = ST(0);
108 SV *buf = ST(1);
109 request_rec *r = (request_rec *) mg_find(SvRV(self), PERL_MAGIC_ext)->mg_obj;
110 apr_size_t len = SvIV(ST(2));
6ce4445e »
2010-01-05 $env{"psgi.input"}->read works when offset == 0
111 int offset = items >= 4 ? SvIV(ST(3)) : 0;
f61f1885 »
2009-09-18 Initial commit
112 apr_bucket_brigade *bb;
7733f9b6 »
2009-10-17 Refactored ModPSGI_Input_read
113 apr_size_t nread = 0;
114 char *pv, *tmp;
f61f1885 »
2009-09-18 Initial commit
115 int eos = 0;
116
6ce4445e »
2010-01-05 $env{"psgi.input"}->read works when offset == 0
117 if (offset > 0) {
3b98db77 »
2009-10-17 croak if offset was given
118 croak("$env->{'psgi.input'}->read: mod_psgi can't handle offset");
119 }
120
7733f9b6 »
2009-10-17 Refactored ModPSGI_Input_read
121 if (len <= 0) {
e2c9fd57 »
2009-10-17 use XSRETURN_*
122 XSRETURN_IV(0);
f61f1885 »
2009-09-18 Initial commit
123 }
124
7733f9b6 »
2009-10-17 Refactored ModPSGI_Input_read
125 bb = apr_brigade_create(r->pool, r->connection->bucket_alloc);
126 if (bb == NULL) {
127 server_error(r, "apr_brigade_create() failed");
128 XSRETURN_UNDEF;
129 }
130
131 pv = apr_pcalloc(r->pool, len);
132 tmp = pv;
133
134 do {
135 apr_size_t read;
136 apr_status_t rc;
137
138 rc = ap_get_brigade(r->input_filters, bb, AP_MODE_READBYTES, APR_BLOCK_READ, len);
139 if (rc != APR_SUCCESS) {
140 apr_brigade_destroy(bb);
141 server_error(r, "ap_get_brigade() failed");
142 XSRETURN_UNDEF;
143 }
144
145 if (APR_BRIGADE_EMPTY(bb)) {
146 apr_brigade_destroy(bb);
147 server_error(r, "APR_BRIGADE_EMPTY");
148 XSRETURN_UNDEF;
149 }
150
151 if (APR_BUCKET_IS_EOS(APR_BRIGADE_LAST(bb))) {
f61f1885 »
2009-09-18 Initial commit
152 eos = 1;
153 }
7733f9b6 »
2009-10-17 Refactored ModPSGI_Input_read
154
155 read = len;
156 rc = apr_brigade_flatten(bb, tmp, &read);
157 if (rc != APR_SUCCESS) {
158 apr_brigade_destroy(bb);
159 server_error(r, "apr_brigade_flatten() failed");
160 XSRETURN_UNDEF;
f61f1885 »
2009-09-18 Initial commit
161 }
162
7733f9b6 »
2009-10-17 Refactored ModPSGI_Input_read
163 nread += read;
164 tmp += read;
165 len -= read;
166 apr_brigade_cleanup(bb);
167 } while (len > 0 && !eos);
168
169 apr_brigade_destroy(bb);
170 sv_setpvn(buf, pv, nread);
e2c9fd57 »
2009-10-17 use XSRETURN_*
171 XSRETURN_IV(nread);
f61f1885 »
2009-09-18 Initial commit
172 }
173
174 XS(ModPSGI_Errors_print);
175 XS(ModPSGI_Errors_print)
176 {
177 dXSARGS;
178 SV *self = ST(0);
22b60173 »
2009-10-17 suppress warnings
179 SV *msg = NULL;
f61f1885 »
2009-09-18 Initial commit
180 request_rec *r = (request_rec *) mg_find(SvRV(self), PERL_MAGIC_ext)->mg_obj;
22b60173 »
2009-10-17 suppress warnings
181 int i;
182 for (i = 1; i < items; i++) {
183 msg = ST(i);
184 ap_log_error(APLOG_MARK, APLOG_NOERRNO|APLOG_ERR, 0, r->server, "%s", SvPV_nolen(msg));
185 }
e2c9fd57 »
2009-10-17 use XSRETURN_*
186 XSRETURN_IV(1);
f61f1885 »
2009-09-18 Initial commit
187 }
188
189 EXTERN_C void
190 xs_init(pTHX)
191 {
192 char *file = __FILE__;
193 dXSUB_SYS;
194
195 newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);
22b60173 »
2009-10-17 suppress warnings
196 newXSproto("ModPSGI::exit", ModPSGI_exit, file, ";$");
f61f1885 »
2009-09-18 Initial commit
197 newXSproto("ModPSGI::Input::read", ModPSGI_Input_read, file, "$$$;$");
22b60173 »
2009-10-17 suppress warnings
198 newXSproto("ModPSGI::Errors::print", ModPSGI_Errors_print, file, "$@");
f61f1885 »
2009-09-18 Initial commit
199 }
200
201 static int copy_env(void *rec, const char *key, const char *val)
202 {
fe98cae8 »
2009-10-03 use dTHX
203 dTHX;
f61f1885 »
2009-09-18 Initial commit
204 HV *env = (HV *) rec;
d33389c2 »
2009-10-18 suppress warnings
205 (void) hv_store(env, key, strlen(key), newSVpv(val, 0), 0);
f61f1885 »
2009-09-18 Initial commit
206 return 1;
207 }
208
85880b1a »
2012-08-22 fix PATH_INFO
209 /* r->uri and r->path_info are unusable */
210 static char *get_uri(request_rec *r)
211 {
212 char *p;
213 char *uri = apr_pstrdup(r->pool, r->unparsed_uri);
214 p = strchr(uri, '?');
215 if (p != NULL) p[0] = '\0';
216 ap_unescape_url(uri);
217 return uri;
218 }
219
cad20bff »
2009-10-16 Thanks to fujiwara. fixes #4
220 static SV *make_env(request_rec *r, psgi_dir_config *c)
f61f1885 »
2009-09-18 Initial commit
221 {
fe98cae8 »
2009-10-03 use dTHX
222 dTHX;
f61f1885 »
2009-09-18 Initial commit
223 HV *env;
224 AV *version;
85880b1a »
2012-08-22 fix PATH_INFO
225 char *uri, *url_scheme, *script_name, *path_info;
32af50d5 »
2012-08-22 Set HTTP_AUTHORIZATION
226 const char *auth_hdr;
f61f1885 »
2009-09-18 Initial commit
227 SV *input, *errors;
228
229 env = newHV();
230
231 ap_add_cgi_vars(r);
232 ap_add_common_vars(r);
430ccf9e »
2009-10-16 fix PATH_INFO and SCRIPT_NAME
233
cad20bff »
2009-10-16 Thanks to fujiwara. fixes #4
234 /* fix SCRIPT_NAME & PATH_INFO */
235 if (c->location == NULL || strcmp(c->location, "/") == 0) {
236 script_name = "";
237 } else {
238 script_name = c->location;
f61f1885 »
2009-09-18 Initial commit
239 }
85880b1a »
2012-08-22 fix PATH_INFO
240 uri = get_uri(r);
241 path_info = &uri[strlen(script_name)];
430ccf9e »
2009-10-16 fix PATH_INFO and SCRIPT_NAME
242 apr_table_set(r->subprocess_env, "PATH_INFO", path_info);
cad20bff »
2009-10-16 Thanks to fujiwara. fixes #4
243 apr_table_set(r->subprocess_env, "SCRIPT_NAME", script_name);
430ccf9e »
2009-10-16 fix PATH_INFO and SCRIPT_NAME
244
32af50d5 »
2012-08-22 Set HTTP_AUTHORIZATION
245 /* ap_add_common_vars does not set HTTP_AUTHORIZATION */
246 if ((auth_hdr = apr_table_get(r->headers_in, "Authorization")) != NULL) {
247 apr_table_set(r->subprocess_env, "HTTP_AUTHORIZATION", auth_hdr);
248 }
249
f61f1885 »
2009-09-18 Initial commit
250 apr_table_do(copy_env, env, r->subprocess_env, NULL);
251
252 version = newAV();
253 av_push(version, newSViv(1));
9732348b »
2012-08-22 PSGI 1.1
254 av_push(version, newSViv(1));
22876bcb »
2009-10-18 Fixed memory leak $env->{'psgi.version'}
255 (void) hv_store(env, "psgi.version", 12, newRV_noinc((SV *) version), 0);
f61f1885 »
2009-09-18 Initial commit
256
257 url_scheme = apr_table_get(r->subprocess_env, "HTTPS") == NULL ? "http" : "https";
d33389c2 »
2009-10-18 suppress warnings
258 (void) hv_store(env, "psgi.url_scheme", 15, newSVpv(url_scheme, 0), 0);
f61f1885 »
2009-09-18 Initial commit
259
260 input = newRV_noinc(newSV(0));
261 sv_magic(SvRV(input), NULL, PERL_MAGIC_ext, NULL, 0);
262 mg_find(SvRV(input), PERL_MAGIC_ext)->mg_obj = (void *) r;
263 sv_bless(input, gv_stashpv("ModPSGI::Input", 1));
d33389c2 »
2009-10-18 suppress warnings
264 (void) hv_store(env, "psgi.input", 10, input, 0);
f61f1885 »
2009-09-18 Initial commit
265
266 errors = newRV_noinc(newSV(0));
267 sv_magic(SvRV(errors), NULL, PERL_MAGIC_ext, NULL, 0);
268 mg_find(SvRV(errors), PERL_MAGIC_ext)->mg_obj = (void *) r;
269 sv_bless(errors, gv_stashpv("ModPSGI::Errors", 1));
d33389c2 »
2009-10-18 suppress warnings
270 (void) hv_store(env, "psgi.errors", 11, errors, 0);
f61f1885 »
2009-09-18 Initial commit
271
f02b617f »
2009-10-18 set psgi.multi{process,thread} by ap_mpm_query
272 (void) hv_store(env, "psgi.multithread", 16, newSViv(psgi_multithread), 0);
273 (void) hv_store(env, "psgi.multiprocess", 17, newSViv(psgi_multiprocess), 0);
274 (void) hv_store(env, "psgi.run_once", 13, newSViv(0), 0);
d33389c2 »
2009-10-18 suppress warnings
275 (void) hv_store(env, "psgi.nonblocking", 16, newSViv(0), 0);
9732348b »
2012-08-22 PSGI 1.1
276 (void) hv_store(env, "psgi.streaming", 14, newSViv(0), 0);
f61f1885 »
2009-09-18 Initial commit
277
278 return newRV_inc((SV *) env);
279 }
280
281 static SV *run_app(request_rec *r, SV *app, SV *env)
282 {
fe98cae8 »
2009-10-03 use dTHX
283 dTHX;
f61f1885 »
2009-09-18 Initial commit
284 int count;
285 SV *res;
286 dSP;
287 ENTER;
288 SAVETMPS;
289 PUSHMARK(SP) ;
290 XPUSHs(sv_2mortal(env));
291 PUTBACK;
292
0e90b5fa »
2009-10-16 use G_KEEPERR and CLEAR_ERRSV() to catch errors
293 count = call_sv(app, G_EVAL|G_SCALAR|G_KEEPERR);
f61f1885 »
2009-09-18 Initial commit
294 SPAGAIN;
295 if (SvTRUE(ERRSV)) {
296 res = NULL;
297 server_error(r, "%s", SvPV_nolen(ERRSV));
0e90b5fa »
2009-10-16 use G_KEEPERR and CLEAR_ERRSV() to catch errors
298 CLEAR_ERRSV();
22b60173 »
2009-10-17 suppress warnings
299 (void) POPs;
f61f1885 »
2009-09-18 Initial commit
300 } else if (count > 0) {
301 res = POPs;
302 SvREFCNT_inc(res);
303 } else {
304 res = NULL;
305 }
306 PUTBACK;
307 FREETMPS;
308 LEAVE;
309 return res;
310 }
311
312 static int output_status(request_rec *r, SV *status)
313 {
fe98cae8 »
2009-10-03 use dTHX
314 dTHX;
f61f1885 »
2009-09-18 Initial commit
315 int s = SvIV(status);
316 if (s < 100) {
317 server_error(r, "invalid response status %d", s);
318 return HTTP_INTERNAL_SERVER_ERROR;
319 }
320 r->status = s;
321 return OK;
322 }
323
324 static int output_headers(request_rec *r, AV *headers)
325 {
fe98cae8 »
2009-10-03 use dTHX
326 dTHX;
f61f1885 »
2009-09-18 Initial commit
327 SV *key_sv, *val_sv;
947bdac0 »
2009-10-12 use ap_set_content_length
328 char *key;
329
330 r->content_type = NULL;
f61f1885 »
2009-09-18 Initial commit
331 while (av_len(headers) > -1) {
332 key_sv = av_shift(headers);
333 val_sv = av_shift(headers);
334 if (key_sv == NULL || val_sv == NULL) break;
335 key = SvPV_nolen(key_sv);
aab7f6a0 »
2009-10-03 Do not check header value
336 if (strcmp(key, "Content-Type") == 0) {
947bdac0 »
2009-10-12 use ap_set_content_length
337 r->content_type = apr_pstrdup(r->pool, SvPV_nolen(val_sv));
338 } else if (strcmp(key, "Content-Length") == 0) {
339 ap_set_content_length(r, SvIV(val_sv));
f61f1885 »
2009-09-18 Initial commit
340 } else if (strcmp(key, "Status") == 0) {
341 server_error(r, "headers must not contain a Status");
342 return HTTP_INTERNAL_SERVER_ERROR;
343 } else {
947bdac0 »
2009-10-12 use ap_set_content_length
344 apr_table_add(r->headers_out, key, SvPV_nolen(val_sv));
f61f1885 »
2009-09-18 Initial commit
345 }
32a1013e »
2009-10-17 app runs in the new scope
346 SvREFCNT_dec(key_sv);
347 SvREFCNT_dec(val_sv);
f61f1885 »
2009-09-18 Initial commit
348 }
349 return OK;
350 }
351
352 static int respond_to(SV *obj, const char *method)
353 {
fe98cae8 »
2009-10-03 use dTHX
354 dTHX;
f61f1885 »
2009-09-18 Initial commit
355 int res;
356 dSP;
357 ENTER;
358 SAVETMPS;
359 PUSHMARK(SP);
360 XPUSHs(obj);
361 XPUSHs(sv_2mortal(newSVpv(method, 0)));
362 PUTBACK;
363
364 call_method("can", G_SCALAR);
365 SPAGAIN;
366 res = SvROK(POPs);
367 PUTBACK;
368 FREETMPS;
369 LEAVE;
370 return res;
371 }
372
373 static int output_body_ary(request_rec *r, AV *bodys)
374 {
fe98cae8 »
2009-10-03 use dTHX
375 dTHX;
f61f1885 »
2009-09-18 Initial commit
376 SV **body;
377 I32 i;
378 I32 lastidx;
379 char *buf;
380 STRLEN len;
03fb93eb »
2009-10-05 win32 porting.
381 apr_off_t clen = 0;
f61f1885 »
2009-09-18 Initial commit
382
383 lastidx = av_len(bodys);
384 for (i = 0; i <= lastidx; i++) {
385 body = av_fetch(bodys, i, 0);
386 if (SvOK(*body)) {
387 buf = SvPV(*body, len);
388 ap_rwrite(buf, len, r);
389 clen += len;
390 }
391 }
947bdac0 »
2009-10-12 use ap_set_content_length
392 if (clen > 0) {
393 ap_set_content_length(r, clen);
394 }
f61f1885 »
2009-09-18 Initial commit
395 return OK;
396 }
397
398 static int output_body_obj(request_rec *r, SV *obj, int type)
399 {
fe98cae8 »
2009-10-03 use dTHX
400 dTHX;
22b60173 »
2009-10-17 suppress warnings
401 SV *buf_sv;
f61f1885 »
2009-09-18 Initial commit
402 apr_off_t clen = 0;
403 STRLEN len;
03fb93eb »
2009-10-05 win32 porting.
404 dSP;
f61f1885 »
2009-09-18 Initial commit
405 char *buf;
406 int count;
407
408 if (type == SVt_PVMG && !respond_to(obj, "getline")) {
409 server_error(r, "response body object must be able to getline");
410 return HTTP_INTERNAL_SERVER_ERROR;
411 }
412
413 ENTER;
414 SAVETMPS;
415 SAVESPTR(PL_rs);
416 PL_rs = newRV_inc(newSViv(AP_IOBUFSIZE));
417 while (1) {
418 PUSHMARK(SP);
419 XPUSHs(obj);
420 PUTBACK;
421 count = call_method("getline", G_SCALAR);
422 if (count != 1) croak("Big trouble\n");
423 SPAGAIN;
424 buf_sv = POPs;
425 if (SvOK(buf_sv)) {
426 buf = SvPV(buf_sv, len);
427 clen += len;
428 ap_rwrite(buf, len, r);
429 } else {
430 break;
431 }
432 }
71c91fbf »
2009-10-18 Fixed Content-Length in output_body_obj
433 if (clen > 0) {
434 ap_set_content_length(r, clen);
947bdac0 »
2009-10-12 use ap_set_content_length
435 }
f61f1885 »
2009-09-18 Initial commit
436 PUSHMARK(SP);
437 XPUSHs(obj);
438 PUTBACK;
439 call_method("close", G_DISCARD);
440 SPAGAIN;
441 PUTBACK;
442 FREETMPS;
443 LEAVE;
444 return OK;
445 }
446
377b40df »
2009-10-17 sendfile support. closes #1
447 static int output_body_sendfile(request_rec *r, const char *path)
448 {
449 apr_file_t *fd;
450 apr_status_t status;
451 apr_size_t len, nbytes;
452 apr_finfo_t finfo;
453 int rc;
454
455 status = apr_file_open(&fd, path, APR_READ|APR_BINARY, APR_OS_DEFAULT, r->pool);
456 if (status != APR_SUCCESS) {
457 return HTTP_INTERNAL_SERVER_ERROR;
458 }
459
460 apr_file_info_get(&finfo, APR_FINFO_NORM, fd);
461 len = finfo.size;
462
463 status = ap_send_fd(fd, r, 0, len, &nbytes);
464 apr_file_close(fd);
465
466 if (status == APR_SUCCESS) {
467 ap_set_content_length(r, nbytes);
468 rc = OK;
469 } else {
470 rc = HTTP_INTERNAL_SERVER_ERROR;
471 }
472
473 return rc;
474 }
475
476 static int output_body_path(request_rec *r, SV *body)
477 {
478 dTHX;
479 int count;
480 apr_status_t rc;
481 SV *path_sv;
22b60173 »
2009-10-17 suppress warnings
482 char *path = NULL;
377b40df »
2009-10-17 sendfile support. closes #1
483 dSP;
484 ENTER;
485 SAVETMPS;
486 PUSHMARK(SP);
487 XPUSHs(body);
488 PUTBACK;
489
490 count = call_method("path", G_EVAL|G_SCALAR|G_KEEPERR);
491 SPAGAIN;
492 if (SvTRUE(ERRSV)) {
493 rc = DECLINED;
494 server_error(r, "unable to get path\n%s", SvPV_nolen(ERRSV));
495 CLEAR_ERRSV();
22b60173 »
2009-10-17 suppress warnings
496 (void) POPs;
377b40df »
2009-10-17 sendfile support. closes #1
497 } else if (count > 0) {
498 path_sv = POPs;
499 path = apr_pstrdup(r->pool, SvPV_nolen(path_sv));
500 rc = OK;
501 } else {
502 rc = DECLINED;
503 }
504 PUTBACK;
505 FREETMPS;
506 LEAVE;
507
508 return rc != OK ? rc : output_body_sendfile(r, path);
509 }
510
f61f1885 »
2009-09-18 Initial commit
511 static int output_body(request_rec *r, SV *body)
512 {
fe98cae8 »
2009-10-03 use dTHX
513 dTHX;
f61f1885 »
2009-09-18 Initial commit
514 int rc, type;
515 switch (type = SvTYPE(SvRV(body))) {
516 case SVt_PVAV:
517 rc = output_body_ary(r, (AV *) SvRV(body));
518 break;
519 case SVt_PVGV:
377b40df »
2009-10-17 sendfile support. closes #1
520 /* TODO:
521 * It's possible to get fd by PerlIO_fileno(IoIFP(sv_2io(body)))
522 * It's possible to get apr_file_t by apr_os_file_put
523 * Is it possible to implement above portable?
524 */
f61f1885 »
2009-09-18 Initial commit
525 require_pv("IO/Handle.pm");
526 case SVt_PVMG:
377b40df »
2009-10-17 sendfile support. closes #1
527 if (respond_to(body, "path")) {
528 rc = output_body_path(r, body);
529 if (rc != DECLINED) break;
530 }
f61f1885 »
2009-09-18 Initial commit
531 rc = output_body_obj(r, body, type);
532 break;
533 default:
534 server_error(r, "response body must be an array reference or object");
535 rc = HTTP_INTERNAL_SERVER_ERROR;
536 break;
537 }
538 return rc;
539 }
540
541 static int output_response(request_rec *r, SV *res)
542 {
fe98cae8 »
2009-10-03 use dTHX
543 dTHX;
f61f1885 »
2009-09-18 Initial commit
544 AV *res_av;
545 SV **status;
546 SV **headers;
547 AV *headers_av;
548 SV **body;
549 int rc;
550
551 if (!SvROK(res) || SvTYPE(SvRV(res)) != SVt_PVAV) {
552 server_error(r, "response must be an array reference");
553 return HTTP_INTERNAL_SERVER_ERROR;
554 }
555 res_av = (AV *) SvRV(res);
556 if (av_len(res_av) != 2) {
557 server_error(r, "response must have 3 elements");
558 return HTTP_INTERNAL_SERVER_ERROR;
559 }
560
561 status = av_fetch(res_av, 0, 0);
562 if (!SvOK(*status)) {
563 server_error(r, "response status must be a scalar value");
564 return HTTP_INTERNAL_SERVER_ERROR;
565 }
566 rc = output_status(r, *status);
567 if (rc != OK) return rc;
568
569 headers = av_fetch(res_av, 1, 0);
570 if (!SvROK(*headers) || SvTYPE(SvRV(*headers)) != SVt_PVAV) {
571 server_error(r, "response headers must be an array reference");
572 return HTTP_INTERNAL_SERVER_ERROR;
573 }
574 headers_av = (AV *) SvRV(*headers);
575 if ((av_len(headers_av) + 1) % 2 != 0) {
576 server_error(r, "num of response headers must be even");
577 return HTTP_INTERNAL_SERVER_ERROR;
578 }
579 rc = output_headers(r, headers_av);
580 if (rc != OK) return rc;
581
582 body = av_fetch(res_av, 2, 0);
583 if (!SvROK(*body)) {
584 server_error(r, "response body must be a reference");
585 return HTTP_INTERNAL_SERVER_ERROR;
586 }
587 rc = output_body(r, *body);
588
589 return rc;
590 }
591
ace12729 »
2009-10-03 Make PerlInterpreter persistent
592 static void init_perl_variables()
f61f1885 »
2009-09-18 Initial commit
593 {
fe98cae8 »
2009-10-03 use dTHX
594 dTHX;
f61f1885 »
2009-09-18 Initial commit
595 GV *exit_gv = gv_fetchpv("CORE::GLOBAL::exit", TRUE, SVt_PVCV);
231cd48a »
2012-08-22 Fix compile error
596 GvCV_set(exit_gv, get_cv("ModPSGI::exit", TRUE));
f61f1885 »
2009-09-18 Initial commit
597 GvIMPORTED_CV_on(exit_gv);
d33389c2 »
2009-10-18 suppress warnings
598 (void) hv_store(GvHV(PL_envgv), "MOD_PSGI", 8, newSVpv(MOD_PSGI_VERSION, 0), 0);
f61f1885 »
2009-09-18 Initial commit
599 }
600
ecd58dfe »
2009-10-04 Load .psgi from .htaccess
601 static SV *load_psgi(apr_pool_t *pool, const char *file)
602 {
603 dTHX;
604 SV *app;
605 char *code;
606
607 code = apr_psprintf(pool, "do q\"%s\" or die $@",
608 ap_escape_quotes(pool, file));
609 app = eval_pv(code, FALSE);
610
611 if (SvTRUE(ERRSV)) {
612 ap_log_error(APLOG_MARK, APLOG_NOERRNO|APLOG_ERR, 0, NULL, "%s", SvPV_nolen(ERRSV));
0e90b5fa »
2009-10-16 use G_KEEPERR and CLEAR_ERRSV() to catch errors
613 CLEAR_ERRSV();
ecd58dfe »
2009-10-04 Load .psgi from .htaccess
614 return NULL;
615 }
616 if (!SvOK(app) || !SvROK(app) || SvTYPE(SvRV(app)) != SVt_PVCV) {
617 ap_log_error(APLOG_MARK, APLOG_NOERRNO|APLOG_ERR, 0, NULL,
618 "%s does not return an application code reference", file);
619 return NULL;
620 }
621 return app;
622 }
623
4e00d638 »
2009-10-03 init and destroy in handler
624 static int psgi_handler(request_rec *r)
f61f1885 »
2009-09-18 Initial commit
625 {
626 SV *app, *env, *res;
627 psgi_dir_config *c;
32a1013e »
2009-10-17 app runs in the new scope
628 int rc;
f61f1885 »
2009-09-18 Initial commit
629
098e77e6 »
2009-10-04 ap_add_version_component
630 if (strcmp(r->handler, PSGI_HANDLER_NAME)) {
f61f1885 »
2009-09-18 Initial commit
631 return DECLINED;
632 }
633 c = (psgi_dir_config *) ap_get_module_config(r->per_dir_config, &psgi_module);
ace12729 »
2009-10-03 Make PerlInterpreter persistent
634 if (c->file == NULL) {
f61f1885 »
2009-09-18 Initial commit
635 ap_log_error(APLOG_MARK, APLOG_NOERRNO|APLOG_NOTICE, 0, r->server,
636 "PSGIApp not configured");
637 return DECLINED;
638 }
5b667635 »
2009-10-04 PERL_SET_CONTEXT
639
640 PERL_SET_CONTEXT(perlinterp);
32a1013e »
2009-10-17 app runs in the new scope
641 ENTER;
642 SAVETMPS;
643
27f555f3 »
2009-10-18 Removed temporary apr_array_header_t
644 app = apr_hash_get(psgi_apps, c->file, APR_HASH_KEY_STRING);
ecd58dfe »
2009-10-04 Load .psgi from .htaccess
645 if (app == NULL) {
646 app = load_psgi(r->pool, c->file);
647 if (app == NULL) {
648 server_error(r, "%s had compilation errors.", c->file);
32a1013e »
2009-10-17 app runs in the new scope
649 rc = HTTP_INTERNAL_SERVER_ERROR;
650 goto exit;
ecd58dfe »
2009-10-04 Load .psgi from .htaccess
651 }
27f555f3 »
2009-10-18 Removed temporary apr_array_header_t
652 apr_hash_set(psgi_apps, c->file, APR_HASH_KEY_STRING, app);
ecd58dfe »
2009-10-04 Load .psgi from .htaccess
653 }
32a1013e »
2009-10-17 app runs in the new scope
654
cad20bff »
2009-10-16 Thanks to fujiwara. fixes #4
655 env = make_env(r, c);
c1156933 »
2009-10-04 'do $psgi_app' at post_config
656 res = run_app(r, app, env);
f61f1885 »
2009-09-18 Initial commit
657 if (res == NULL) {
658 server_error(r, "invalid response");
32a1013e »
2009-10-17 app runs in the new scope
659 rc = HTTP_INTERNAL_SERVER_ERROR;
660 goto exit;
f61f1885 »
2009-09-18 Initial commit
661 }
32a1013e »
2009-10-17 app runs in the new scope
662 rc = output_response(r, res);
663 SvREFCNT_dec(res);
664
665 exit:
666 FREETMPS;
667 LEAVE;
668 return rc;
f61f1885 »
2009-09-18 Initial commit
669 }
670
e284234d »
2009-10-03 Call PERL_SYS_INIT3,PERL_SYS_TERM once per process
671 static apr_status_t psgi_child_exit(void *p)
672 {
64db7ebe »
2009-10-18 cleanup at child process exit
673 if (perlinterp != NULL) {
03fb93eb »
2009-10-05 win32 porting.
674 PERL_SET_CONTEXT(perlinterp);
675 PL_perl_destruct_level = 1;
676 perl_destruct(perlinterp);
677 perl_free(perlinterp);
678 PERL_SYS_TERM();
679 perlinterp = NULL;
680 }
e284234d »
2009-10-03 Call PERL_SYS_INIT3,PERL_SYS_TERM once per process
681 return OK;
682 }
683
684 static void psgi_child_init(apr_pool_t *p, server_rec *s)
685 {
686 apr_pool_cleanup_register(p, NULL, psgi_child_exit, psgi_child_exit);
687 }
688
c1156933 »
2009-10-04 'do $psgi_app' at post_config
689 static apr_status_t
690 psgi_pre_config(apr_pool_t *pconf, apr_pool_t *plog, apr_pool_t *ptemp)
ace12729 »
2009-10-03 Make PerlInterpreter persistent
691 {
692 int argc = 2;
693 char *argv[] = { "perl", "-e;0", NULL };
694 char **envp = NULL;
695
696 PERL_SYS_INIT3(&argc, (char ***) argv, &envp);
697 perlinterp = perl_alloc();
698 PL_perl_destruct_level = 1;
699 perl_construct(perlinterp);
700 perl_parse(perlinterp, xs_init, argc, argv, envp);
701 PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
702 perl_run(perlinterp);
703 init_perl_variables();
c1156933 »
2009-10-04 'do $psgi_app' at post_config
704
f02b617f »
2009-10-18 set psgi.multi{process,thread} by ap_mpm_query
705 ap_mpm_query(AP_MPMQ_IS_THREADED, &psgi_multithread);
706 psgi_multithread = (psgi_multithread != AP_MPMQ_NOT_SUPPORTED);
707
708 ap_mpm_query(AP_MPMQ_IS_FORKED, &psgi_multiprocess);
709 psgi_multiprocess = (psgi_multiprocess != AP_MPMQ_NOT_SUPPORTED);
710
85cae050 »
2009-10-18 Allocate psgi_app at psgi_pre_config
711 psgi_apps = apr_hash_make(pconf);
712
c1156933 »
2009-10-04 'do $psgi_app' at post_config
713 return OK;
714 }
715
716 static int
717 psgi_post_config(apr_pool_t *pconf, apr_pool_t *plog, apr_pool_t *ptemp, server_rec *s)
718 {
719 dTHX;
27f555f3 »
2009-10-18 Removed temporary apr_array_header_t
720 const void *key;
721 char *file;
c1156933 »
2009-10-04 'do $psgi_app' at post_config
722 SV *app;
27f555f3 »
2009-10-18 Removed temporary apr_array_header_t
723 apr_hash_index_t *hi;
8fd6f10a »
2009-10-04 Ignore first call psgi_post_config
724 void *data;
725 const char *userdata_key = "psgi_post_config";
726
727 apr_pool_userdata_get(&data, userdata_key, s->process->pool);
728 if (data == NULL) {
729 apr_pool_userdata_set((const void *)1, userdata_key,
730 apr_pool_cleanup_null, s->process->pool);
731 return OK;
732 }
27f555f3 »
2009-10-18 Removed temporary apr_array_header_t
733
734 for (hi = apr_hash_first(pconf, psgi_apps); hi; hi = apr_hash_next(hi)) {
735 apr_hash_this(hi, &key, NULL, NULL);
736 file = (char *) key;
c1156933 »
2009-10-04 'do $psgi_app' at post_config
737 app = load_psgi(pconf, file);
738 if (app == NULL) {
739 ap_log_error(APLOG_MARK, APLOG_NOERRNO|APLOG_ERR, 0, NULL,
740 "%s had compilation errors.", file);
741 return DONE;
742 }
27f555f3 »
2009-10-18 Removed temporary apr_array_header_t
743 apr_hash_set(psgi_apps, file, APR_HASH_KEY_STRING, app);
c1156933 »
2009-10-04 'do $psgi_app' at post_config
744 }
098e77e6 »
2009-10-04 ap_add_version_component
745
746 ap_add_version_component(pconf, apr_psprintf(pconf, "mod_psgi/%s", MOD_PSGI_VERSION));
747
ace12729 »
2009-10-03 Make PerlInterpreter persistent
748 return OK;
749 }
750
f61f1885 »
2009-09-18 Initial commit
751 static void psgi_register_hooks(apr_pool_t *p)
752 {
03fb93eb »
2009-10-05 win32 porting.
753 ap_hook_pre_config(psgi_pre_config, NULL, NULL, APR_HOOK_MIDDLE);
754 ap_hook_post_config(psgi_post_config, NULL, NULL, APR_HOOK_MIDDLE);
755 ap_hook_child_init(psgi_child_init, NULL, NULL, APR_HOOK_MIDDLE);
756 ap_hook_handler(psgi_handler, NULL, NULL, APR_HOOK_MIDDLE);
f61f1885 »
2009-09-18 Initial commit
757 }
758
759 static void *create_dir_config(apr_pool_t *p, char *path)
760 {
761 psgi_dir_config *c = apr_pcalloc(p, sizeof(psgi_dir_config));
ace12729 »
2009-10-03 Make PerlInterpreter persistent
762 c->file = NULL;
401d80a7 »
2009-10-18 allocate psgi_apps and app_mapping as necessary
763 c->location = apr_pstrdup(p, path);
f61f1885 »
2009-09-18 Initial commit
764 return (void *) c;
765 }
766
767 static const char *cmd_psgi_app(cmd_parms *cmd, void *conf, const char *v)
768 {
769 psgi_dir_config *c = (psgi_dir_config *) conf;
ace12729 »
2009-10-03 Make PerlInterpreter persistent
770 c->file = (char *) apr_pstrdup(cmd->pool, v);
27f555f3 »
2009-10-18 Removed temporary apr_array_header_t
771 apr_hash_set(psgi_apps, c->file, APR_HASH_KEY_STRING, c->file);
f61f1885 »
2009-09-18 Initial commit
772 return NULL;
773 }
774
775 static const command_rec command_table[] = {
776 AP_INIT_TAKE1("PSGIApp", cmd_psgi_app, NULL,
b991f345 »
2009-10-03 Allow PSGIApp in .htaccess
777 OR_LIMIT, "set PSGI application"),
f61f1885 »
2009-09-18 Initial commit
778 { NULL }
779 };
780
781 module AP_MODULE_DECLARE_DATA psgi_module = {
782 STANDARD20_MODULE_STUFF,
783 create_dir_config, /* create per-dir config structures */
784 NULL, /* merge per-dir config structures */
785 NULL, /* create per-server config structures */
786 NULL, /* merge per-server config structures */
787 command_table, /* table of config file commands */
788 psgi_register_hooks /* register hooks */
789 };
790
Something went wrong with that request. Please try again.