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