xref: /unit/src/perl/nxt_perl_psgi.c (revision 1489:4a3ec07f4b19)
1 
2 /*
3  * Copyright (C) Alexander Borisov
4  * Copyright (C) NGINX, Inc.
5  */
6 
7 #include <perl/nxt_perl_psgi_layer.h>
8 
9 #include <nxt_main.h>
10 #include <nxt_router.h>
11 #include <nxt_runtime.h>
12 #include <nxt_application.h>
13 #include <nxt_file.h>
14 #include <nxt_unit.h>
15 #include <nxt_unit_request.h>
16 #include <nxt_unit_response.h>
17 
18 
19 typedef struct {
20     PerlInterpreter          *my_perl;
21     nxt_unit_request_info_t  *req;
22 } nxt_perl_psgi_input_t;
23 
24 
25 typedef struct {
26     PerlInterpreter          *my_perl;
27     SV                       *app;
28 } nxt_perl_psgi_module_t;
29 
30 
31 static long nxt_perl_psgi_io_input_read(PerlInterpreter *my_perl,
32     nxt_perl_psgi_io_arg_t *arg, void *vbuf, size_t length);
33 static long nxt_perl_psgi_io_input_write(PerlInterpreter *my_perl,
34     nxt_perl_psgi_io_arg_t *arg, const void *vbuf, size_t length);
35 static long nxt_perl_psgi_io_input_flush(PerlInterpreter *my_perl,
36     nxt_perl_psgi_io_arg_t *arg);
37 
38 static long nxt_perl_psgi_io_error_read(PerlInterpreter *my_perl,
39     nxt_perl_psgi_io_arg_t *arg, void *vbuf, size_t length);
40 static long nxt_perl_psgi_io_error_write(PerlInterpreter *my_perl,
41     nxt_perl_psgi_io_arg_t *arg, const void *vbuf, size_t length);
42 static long nxt_perl_psgi_io_error_flush(PerlInterpreter *my_perl,
43     nxt_perl_psgi_io_arg_t *arg);
44 
45 /*
46 static void nxt_perl_psgi_xs_core_global_changes(PerlInterpreter *my_perl,
47     const char *core, const char *sub, XSUBADDR_t sub_addr);
48 */
49 
50 static void nxt_perl_psgi_xs_init(pTHX);
51 
52 static SV *nxt_perl_psgi_call_var_application(PerlInterpreter *my_perl,
53     SV *env, SV *app, nxt_unit_request_info_t *req);
54 static SV *nxt_perl_psgi_call_method(PerlInterpreter *my_perl, SV *obj,
55     const char *method, nxt_unit_request_info_t *req);
56 
57 /* For currect load XS modules */
58 EXTERN_C void boot_DynaLoader(pTHX_ CV *cv);
59 
60 static nxt_int_t nxt_perl_psgi_io_input_init(PerlInterpreter *my_perl,
61     nxt_perl_psgi_io_arg_t *arg);
62 static nxt_int_t nxt_perl_psgi_io_error_init(PerlInterpreter *my_perl,
63     nxt_perl_psgi_io_arg_t *arg);
64 
65 static PerlInterpreter *nxt_perl_psgi_interpreter_init(nxt_task_t *task,
66     char *script, SV **app);
67 
68 static SV *nxt_perl_psgi_env_create(PerlInterpreter *my_perl,
69     nxt_unit_request_info_t *req, nxt_perl_psgi_input_t *input);
70 nxt_inline int nxt_perl_psgi_add_sptr(PerlInterpreter *my_perl, HV *hash_env,
71     const char *name, uint32_t name_len, nxt_unit_sptr_t *sptr, uint32_t len);
72 nxt_inline int nxt_perl_psgi_add_str(PerlInterpreter *my_perl, HV *hash_env,
73     const char *name, uint32_t name_len, const char *str, uint32_t len);
74 nxt_inline int nxt_perl_psgi_add_value(PerlInterpreter *my_perl, HV *hash_env,
75     const char *name, uint32_t name_len, void *value);
76 
77 
78 static u_char *nxt_perl_psgi_module_create(nxt_task_t *task,
79     const char *script);
80 
81 static nxt_int_t nxt_perl_psgi_result_status(PerlInterpreter *my_perl,
82     SV *result);
83 static int nxt_perl_psgi_result_head(PerlInterpreter *my_perl,
84     SV *sv_head, nxt_unit_request_info_t *req, uint16_t status);
85 static int nxt_perl_psgi_result_body(PerlInterpreter *my_perl,
86     SV *result, nxt_unit_request_info_t *req);
87 static int nxt_perl_psgi_result_body_ref(PerlInterpreter *my_perl,
88     SV *sv_body, nxt_unit_request_info_t *req);
89 static int nxt_perl_psgi_result_body_fh(PerlInterpreter *my_perl, SV *sv_body,
90     nxt_unit_request_info_t *req);
91 static ssize_t nxt_perl_psgi_io_read(nxt_unit_read_info_t *read_info, void *dst,
92     size_t size);
93 static int nxt_perl_psgi_result_array(PerlInterpreter *my_perl,
94     SV *result, nxt_unit_request_info_t *req);
95 static void nxt_perl_psgi_result_cb(PerlInterpreter *my_perl, SV *result,
96     nxt_unit_request_info_t *req);
97 
98 static nxt_int_t nxt_perl_psgi_start(nxt_task_t *task,
99     nxt_process_data_t *conf);
100 static void nxt_perl_psgi_request_handler(nxt_unit_request_info_t *req);
101 static void nxt_perl_psgi_atexit(void);
102 
103 typedef SV *(*nxt_perl_psgi_callback_f)(PerlInterpreter *my_perl,
104     SV *env, nxt_task_t *task);
105 
106 static CV                       *nxt_perl_psgi_cb;
107 static PerlInterpreter          *nxt_perl_psgi;
108 static nxt_perl_psgi_io_arg_t   nxt_perl_psgi_arg_input;
109 static nxt_perl_psgi_io_arg_t   nxt_perl_psgi_arg_error;
110 static nxt_unit_request_info_t  *nxt_perl_psgi_request;
111 
112 static uint32_t  nxt_perl_psgi_compat[] = {
113     NXT_VERNUM, NXT_DEBUG,
114 };
115 
116 NXT_EXPORT nxt_app_module_t  nxt_app_module = {
117     sizeof(nxt_perl_psgi_compat),
118     nxt_perl_psgi_compat,
119     nxt_string("perl"),
120     PERL_VERSION_STRING,
121 
122 #if (NXT_HAVE_ISOLATION_ROOTFS)
123     NULL,
124     0,
125 #endif
126 
127     NULL,
128     nxt_perl_psgi_start,
129 };
130 
131 
132 static long
133 nxt_perl_psgi_io_input_read(PerlInterpreter *my_perl,
134     nxt_perl_psgi_io_arg_t *arg, void *vbuf, size_t length)
135 {
136     nxt_perl_psgi_input_t  *input;
137 
138     input = (nxt_perl_psgi_input_t *) arg->ctx;
139 
140     return nxt_unit_request_read(input->req, vbuf, length);
141 }
142 
143 
144 static long
145 nxt_perl_psgi_io_input_write(PerlInterpreter *my_perl,
146     nxt_perl_psgi_io_arg_t *arg, const void *vbuf, size_t length)
147 {
148     return 0;
149 }
150 
151 
152 static long
153 nxt_perl_psgi_io_input_flush(PerlInterpreter *my_perl,
154     nxt_perl_psgi_io_arg_t *arg)
155 {
156     return 0;
157 }
158 
159 
160 static long
161 nxt_perl_psgi_io_error_read(PerlInterpreter *my_perl,
162     nxt_perl_psgi_io_arg_t *arg, void *vbuf, size_t length)
163 {
164     return 0;
165 }
166 
167 
168 static long
169 nxt_perl_psgi_io_error_write(PerlInterpreter *my_perl,
170     nxt_perl_psgi_io_arg_t *arg, const void *vbuf, size_t length)
171 {
172     nxt_perl_psgi_input_t *input;
173 
174     input = (nxt_perl_psgi_input_t *) arg->ctx;
175     nxt_unit_req_error(input->req, "Perl: %s", (const char*) vbuf);
176 
177     return (long) length;
178 }
179 
180 
181 static long
182 nxt_perl_psgi_io_error_flush(PerlInterpreter *my_perl,
183     nxt_perl_psgi_io_arg_t *arg)
184 {
185     return 0;
186 }
187 
188 
189 /* In the future it will be necessary to change some Perl functions. */
190 /*
191 static void
192 nxt_perl_psgi_xs_core_global_changes(PerlInterpreter *my_perl,
193     const char *core, const char *sub, XSUBADDR_t sub_addr)
194 {
195     GV  *gv;
196 
197     gv = gv_fetchpv(core, TRUE, SVt_PVCV);
198 
199 #ifdef MUTABLE_CV
200     GvCV_set(gv, MUTABLE_CV(SvREFCNT_inc(get_cv(sub, TRUE))));
201 #else
202     GvCV_set(gv, (CV *) (SvREFCNT_inc(get_cv(sub, TRUE))));
203 #endif
204     GvIMPORTED_CV_on(gv);
205 
206     newXS(sub, sub_addr, __FILE__);
207 }
208 */
209 
210 
211 XS(XS_NGINX__Unit__PSGI_exit);
212 XS(XS_NGINX__Unit__PSGI_exit)
213 {
214     I32 ax = POPMARK;
215     Perl_croak(aTHX_ (char *) NULL);
216     XSRETURN_EMPTY;
217 }
218 
219 
220 XS(XS_NGINX__Unit__Sandbox_write);
221 XS(XS_NGINX__Unit__Sandbox_write)
222 {
223     int     rc;
224     char    *body;
225     size_t  len;
226 
227     dXSARGS;
228 
229     if (nxt_slow_path(items != 2)) {
230         Perl_croak(aTHX_ "Wrong number of arguments. Need one string");
231 
232         XSRETURN_EMPTY;
233     }
234 
235     body = SvPV(ST(1), len);
236 
237     rc = nxt_unit_response_write(nxt_perl_psgi_request, body, len);
238     if (nxt_slow_path(rc != NXT_UNIT_OK)) {
239         Perl_croak(aTHX_ "Failed to write response body");
240 
241         XSRETURN_EMPTY;
242     }
243 
244     XSRETURN_IV(len);
245 }
246 
247 
248 nxt_inline void
249 nxt_perl_psgi_cb_request_done(nxt_int_t status)
250 {
251     nxt_unit_request_info_t  *req;
252 
253     req = nxt_perl_psgi_request;
254 
255     if (req != NULL) {
256         nxt_unit_request_done(req, status);
257         nxt_perl_psgi_request = NULL;
258     }
259 }
260 
261 
262 XS(XS_NGINX__Unit__Sandbox_close);
263 XS(XS_NGINX__Unit__Sandbox_close)
264 {
265     I32  ax;
266 
267     ax = POPMARK;
268 
269     nxt_perl_psgi_cb_request_done(NXT_UNIT_OK);
270 
271     XSRETURN_NO;
272 }
273 
274 
275 XS(XS_NGINX__Unit__Sandbox_cb);
276 XS(XS_NGINX__Unit__Sandbox_cb)
277 {
278     SV    *obj;
279     int   rc;
280     long  array_len;
281 
282     dXSARGS;
283 
284     if (nxt_slow_path(items != 1)) {
285         nxt_perl_psgi_cb_request_done(NXT_UNIT_ERROR);
286 
287         Perl_croak(aTHX_ "Wrong number of arguments");
288 
289         XSRETURN_EMPTY;
290     }
291 
292     if (nxt_slow_path(SvOK(ST(0)) == 0 || SvROK(ST(0)) == 0
293                       || SvTYPE(SvRV(ST(0))) != SVt_PVAV))
294     {
295         nxt_perl_psgi_cb_request_done(NXT_UNIT_ERROR);
296 
297         Perl_croak(aTHX_ "PSGI: An unexpected response was received "
298                    "from Perl Application");
299 
300         XSRETURN_EMPTY;
301     }
302 
303     rc = nxt_perl_psgi_result_array(PERL_GET_CONTEXT, ST(0),
304                                     nxt_perl_psgi_request);
305     if (nxt_slow_path(rc != NXT_UNIT_OK)) {
306         nxt_perl_psgi_cb_request_done(NXT_UNIT_ERROR);
307 
308         Perl_croak(aTHX_ (char *) NULL);
309 
310         XSRETURN_EMPTY;
311     }
312 
313     array_len = av_len((AV *) SvRV(ST(0)));
314 
315     if (array_len < 2) {
316         obj = sv_bless(newRV_noinc((SV *) newHV()),
317                        gv_stashpv("NGINX::Unit::Sandbox", GV_ADD));
318         ST(0) = obj;
319 
320         XSRETURN(1);
321     }
322 
323     nxt_perl_psgi_cb_request_done(NXT_UNIT_OK);
324 
325     XSRETURN_EMPTY;
326 }
327 
328 
329 static void
330 nxt_perl_psgi_xs_init(pTHX)
331 {
332 /*
333     nxt_perl_psgi_xs_core_global_changes(my_perl, "CORE::GLOBAL::exit",
334                                          "NGINX::Unit::PSGI::exit",
335                                          XS_NGINX__Unit__PSGI_exit);
336 */
337     nxt_perl_psgi_layer_stream_init(aTHX);
338 
339     /* DynaLoader for Perl modules who use XS */
340     newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, __FILE__);
341 
342     newXS("NGINX::Unit::Sandbox::write", XS_NGINX__Unit__Sandbox_write,
343           __FILE__);
344     newXS("NGINX::Unit::Sandbox::close", XS_NGINX__Unit__Sandbox_close,
345           __FILE__);
346 
347     nxt_perl_psgi_cb = newXS("NGINX::Unit::Sandbox::cb",
348                              XS_NGINX__Unit__Sandbox_cb, __FILE__);
349 }
350 
351 
352 static SV *
353 nxt_perl_psgi_call_var_application(PerlInterpreter *my_perl,
354     SV *env, SV *app, nxt_unit_request_info_t *req)
355 {
356     SV  *result;
357 
358     dSP;
359 
360     ENTER;
361     SAVETMPS;
362 
363     PUSHMARK(sp);
364     XPUSHs(env);
365     PUTBACK;
366 
367     call_sv(app, G_EVAL|G_SCALAR);
368 
369     SPAGAIN;
370 
371     if (SvTRUE(ERRSV)) {
372         nxt_unit_req_error(req, "PSGI: Failed to run Perl Application: \n%s",
373                            SvPV_nolen(ERRSV));
374     }
375 
376     result = POPs;
377     SvREFCNT_inc(result);
378 
379     PUTBACK;
380     FREETMPS;
381     LEAVE;
382 
383     return result;
384 }
385 
386 
387 static SV *
388 nxt_perl_psgi_call_method(PerlInterpreter *my_perl, SV *obj, const char *method,
389     nxt_unit_request_info_t *req)
390 {
391     SV  *result;
392 
393     dSP;
394 
395     ENTER;
396     SAVETMPS;
397 
398     PUSHMARK(sp);
399     XPUSHs(obj);
400     PUTBACK;
401 
402     call_method(method, G_EVAL|G_SCALAR);
403 
404     SPAGAIN;
405 
406     if (SvTRUE(ERRSV)) {
407         nxt_unit_req_error(req, "PSGI: Failed to call method '%s':\n%s",
408                            method, SvPV_nolen(ERRSV));
409         result = NULL;
410 
411     } else {
412         result = SvREFCNT_inc(POPs);
413     }
414 
415     PUTBACK;
416     FREETMPS;
417     LEAVE;
418 
419     return result;
420 }
421 
422 
423 static u_char *
424 nxt_perl_psgi_module_create(nxt_task_t *task, const char *script)
425 {
426     u_char  *buf, *p;
427     size_t  length;
428 
429     static nxt_str_t  prefix = nxt_string(
430         "package NGINX::Unit::Sandbox;"
431         "sub new {"
432         "   return bless {}, $_[0];"
433         "}"
434         "{my $app = do \""
435     );
436 
437     static nxt_str_t  suffix = nxt_string_zero(
438         "\";"
439         "unless ($app) {"
440         "    if($@ || $1) {die $@ || $1}"
441         "    else {die \"File not found or compilation error.\"}"
442         "} "
443         "return $app}"
444     );
445 
446     length = strlen(script);
447 
448     buf = nxt_malloc(prefix.length + length + suffix.length);
449 
450     if (nxt_slow_path(buf == NULL)) {
451         nxt_log_error(NXT_LOG_ERR, task->log,
452                       "PSGI: Failed to allocate memory "
453                       "for Perl script file %s", script);
454         return NULL;
455     }
456 
457     p = nxt_cpymem(buf, prefix.start, prefix.length);
458     p = nxt_cpymem(p, script, length);
459     nxt_memcpy(p, suffix.start, suffix.length);
460 
461     return buf;
462 }
463 
464 
465 static nxt_int_t
466 nxt_perl_psgi_io_input_init(PerlInterpreter *my_perl,
467     nxt_perl_psgi_io_arg_t *arg)
468 {
469     SV      *io;
470     PerlIO  *fp;
471 
472     fp = nxt_perl_psgi_layer_stream_fp_create(aTHX_ arg, "r");
473 
474     if (nxt_slow_path(fp == NULL)) {
475         return NXT_ERROR;
476     }
477 
478     io = nxt_perl_psgi_layer_stream_io_create(aTHX_ fp);
479 
480     if (nxt_slow_path(io == NULL)) {
481         nxt_perl_psgi_layer_stream_fp_destroy(aTHX_ fp);
482         return NXT_ERROR;
483     }
484 
485     arg->io = io;
486     arg->fp = fp;
487     arg->flush = nxt_perl_psgi_io_input_flush;
488     arg->read = nxt_perl_psgi_io_input_read;
489     arg->write = nxt_perl_psgi_io_input_write;
490 
491     return NXT_OK;
492 }
493 
494 
495 static nxt_int_t
496 nxt_perl_psgi_io_error_init(PerlInterpreter *my_perl,
497     nxt_perl_psgi_io_arg_t *arg)
498 {
499     SV      *io;
500     PerlIO  *fp;
501 
502     fp = nxt_perl_psgi_layer_stream_fp_create(aTHX_ arg, "w");
503 
504     if (nxt_slow_path(fp == NULL)) {
505         return NXT_ERROR;
506     }
507 
508     io = nxt_perl_psgi_layer_stream_io_create(aTHX_ fp);
509 
510     if (nxt_slow_path(io == NULL)) {
511         nxt_perl_psgi_layer_stream_fp_destroy(aTHX_ fp);
512         return NXT_ERROR;
513     }
514 
515     arg->io = io;
516     arg->fp = fp;
517     arg->flush = nxt_perl_psgi_io_error_flush;
518     arg->read = nxt_perl_psgi_io_error_read;
519     arg->write = nxt_perl_psgi_io_error_write;
520 
521     return NXT_OK;
522 }
523 
524 
525 static PerlInterpreter *
526 nxt_perl_psgi_interpreter_init(nxt_task_t *task, char *script, SV **app)
527 {
528     int              status, pargc;
529     char             **pargv, **penv;
530     u_char           *run_module;
531     PerlInterpreter  *my_perl;
532 
533     static char  argv[] = "\0""-e\0""0";
534     static char  *embedding[] = { &argv[0], &argv[1], &argv[4] };
535 
536     pargc = 0;
537     pargv = NULL;
538     penv = NULL;
539 
540     PERL_SYS_INIT3(&pargc, &pargv, &penv);
541 
542     my_perl = perl_alloc();
543 
544     if (nxt_slow_path(my_perl == NULL)) {
545         nxt_alert(task, "PSGI: Failed to allocate memory for Perl interpreter");
546         return NULL;
547     }
548 
549     run_module = NULL;
550 
551     perl_construct(my_perl);
552     PERL_SET_CONTEXT(my_perl);
553 
554     status = perl_parse(my_perl, nxt_perl_psgi_xs_init, 3, embedding, NULL);
555 
556     if (nxt_slow_path(status != 0)) {
557         nxt_alert(task, "PSGI: Failed to parse Perl Script");
558         goto fail;
559     }
560 
561     PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
562     PL_origalen = 1;
563 
564     status = perl_run(my_perl);
565 
566     if (nxt_slow_path(status != 0)) {
567         nxt_alert(task, "PSGI: Failed to run Perl");
568         goto fail;
569     }
570 
571     sv_setsv(get_sv("0", 0), newSVpv(script, 0));
572 
573     run_module = nxt_perl_psgi_module_create(task, script);
574 
575     if (nxt_slow_path(run_module == NULL)) {
576         goto fail;
577     }
578 
579     status = nxt_perl_psgi_io_input_init(my_perl, &nxt_perl_psgi_arg_input);
580 
581     if (nxt_slow_path(status != NXT_OK)) {
582         nxt_alert(task, "PSGI: Failed to init io.psgi.input");
583         goto fail;
584     }
585 
586     status = nxt_perl_psgi_io_error_init(my_perl, &nxt_perl_psgi_arg_error);
587 
588     if (nxt_slow_path(status != NXT_OK)) {
589         nxt_alert(task, "PSGI: Failed to init io.psgi.errors");
590         goto fail;
591     }
592 
593     *app = eval_pv((const char *) run_module, FALSE);
594 
595     if (SvTRUE(ERRSV)) {
596         nxt_alert(task, "PSGI: Failed to parse script: %s\n%s",
597                   script, SvPV_nolen(ERRSV));
598         goto fail;
599     }
600 
601     nxt_free(run_module);
602 
603     return my_perl;
604 
605 fail:
606 
607     if (run_module != NULL) {
608         nxt_free(run_module);
609     }
610 
611     perl_destruct(my_perl);
612     perl_free(my_perl);
613     PERL_SYS_TERM();
614 
615     return NULL;
616 }
617 
618 
619 static SV *
620 nxt_perl_psgi_env_create(PerlInterpreter *my_perl,
621     nxt_unit_request_info_t *req, nxt_perl_psgi_input_t *input)
622 {
623     HV                  *hash_env;
624     AV                  *array_version;
625     uint32_t            i;
626     nxt_unit_field_t    *f;
627     nxt_unit_request_t  *r;
628 
629     hash_env = newHV();
630     if (nxt_slow_path(hash_env == NULL)) {
631         return NULL;
632     }
633 
634 #define RC(FNS)                                                               \
635     do {                                                                      \
636         if (nxt_slow_path((FNS) != NXT_UNIT_OK))                              \
637             goto fail;                                                        \
638      } while (0)
639 
640 #define NL(S) (S), sizeof(S)-1
641 
642     r = req->request;
643 
644     RC(nxt_perl_psgi_add_str(my_perl, hash_env, NL("SERVER_SOFTWARE"),
645                              (char *) nxt_server.start, nxt_server.length));
646 
647     RC(nxt_perl_psgi_add_sptr(my_perl, hash_env, NL("REQUEST_METHOD"),
648                               &r->method, r->method_length));
649     RC(nxt_perl_psgi_add_sptr(my_perl, hash_env, NL("REQUEST_URI"),
650                               &r->target, r->target_length));
651     RC(nxt_perl_psgi_add_sptr(my_perl, hash_env, NL("PATH_INFO"),
652                               &r->path, r->path_length));
653 
654     array_version = newAV();
655 
656     if (nxt_slow_path(array_version == NULL)) {
657         goto fail;
658     }
659 
660     av_push(array_version, newSViv(1));
661     av_push(array_version, newSViv(1));
662 
663     RC(nxt_perl_psgi_add_value(my_perl, hash_env, NL("psgi.version"),
664                                 newRV_noinc((SV *) array_version)));
665 
666     RC(nxt_perl_psgi_add_value(my_perl, hash_env, NL("psgi.url_scheme"),
667                                r->tls ? newSVpv("https", 5)
668                                     : newSVpv("http", 4)));
669 
670     RC(nxt_perl_psgi_add_value(my_perl, hash_env, NL("psgi.input"),
671                                 SvREFCNT_inc(nxt_perl_psgi_arg_input.io)));
672     RC(nxt_perl_psgi_add_value(my_perl, hash_env, NL("psgi.errors"),
673                                 SvREFCNT_inc(nxt_perl_psgi_arg_error.io)));
674     RC(nxt_perl_psgi_add_value(my_perl, hash_env, NL("psgi.multithread"),
675                                 &PL_sv_no));
676     RC(nxt_perl_psgi_add_value(my_perl, hash_env, NL("psgi.multiprocess"),
677                                 &PL_sv_yes));
678     RC(nxt_perl_psgi_add_value(my_perl, hash_env, NL("psgi.run_once"),
679                                 &PL_sv_no));
680     RC(nxt_perl_psgi_add_value(my_perl, hash_env, NL("psgi.nonblocking"),
681                                 &PL_sv_no));
682     RC(nxt_perl_psgi_add_value(my_perl, hash_env, NL("psgi.streaming"),
683                                 &PL_sv_yes));
684 
685     RC(nxt_perl_psgi_add_sptr(my_perl, hash_env, NL("QUERY_STRING"),
686                               &r->query, r->query_length));
687     RC(nxt_perl_psgi_add_sptr(my_perl, hash_env, NL("SERVER_PROTOCOL"),
688                               &r->version, r->version_length));
689     RC(nxt_perl_psgi_add_sptr(my_perl, hash_env, NL("REMOTE_ADDR"),
690                               &r->remote, r->remote_length));
691     RC(nxt_perl_psgi_add_sptr(my_perl, hash_env, NL("SERVER_ADDR"),
692                               &r->local, r->local_length));
693 
694     RC(nxt_perl_psgi_add_sptr(my_perl, hash_env, NL("SERVER_NAME"),
695                               &r->server_name, r->server_name_length));
696     RC(nxt_perl_psgi_add_str(my_perl, hash_env, NL("SERVER_PORT"), "80", 2));
697 
698     for (i = 0; i < r->fields_count; i++) {
699         f = r->fields + i;
700 
701         RC(nxt_perl_psgi_add_sptr(my_perl, hash_env,
702                                   nxt_unit_sptr_get(&f->name), f->name_length,
703                                   &f->value, f->value_length));
704     }
705 
706     if (r->content_length_field != NXT_UNIT_NONE_FIELD) {
707         f = r->fields + r->content_length_field;
708 
709         RC(nxt_perl_psgi_add_sptr(my_perl, hash_env, NL("CONTENT_LENGTH"),
710                                   &f->value, f->value_length));
711     }
712 
713     if (r->content_type_field != NXT_UNIT_NONE_FIELD) {
714         f = r->fields + r->content_type_field;
715 
716         RC(nxt_perl_psgi_add_sptr(my_perl, hash_env, NL("CONTENT_TYPE"),
717                                   &f->value, f->value_length));
718     }
719 
720 #undef NL
721 #undef RC
722 
723     return newRV_noinc((SV *) hash_env);
724 
725 fail:
726 
727     SvREFCNT_dec(hash_env);
728 
729     return NULL;
730 }
731 
732 
733 nxt_inline int
734 nxt_perl_psgi_add_sptr(PerlInterpreter *my_perl, HV *hash_env,
735     const char *name, uint32_t name_len, nxt_unit_sptr_t *sptr, uint32_t len)
736 {
737     return nxt_perl_psgi_add_str(my_perl, hash_env, name, name_len,
738                                  nxt_unit_sptr_get(sptr), len);
739 }
740 
741 
742 nxt_inline int
743 nxt_perl_psgi_add_str(PerlInterpreter *my_perl, HV *hash_env,
744     const char *name, uint32_t name_len, const char *str, uint32_t len)
745 {
746     SV  **ha;
747 
748     ha = hv_store(hash_env, name, (I32) name_len,
749                   newSVpv(str, (STRLEN) len), 0);
750     if (nxt_slow_path(ha == NULL)) {
751         return NXT_UNIT_ERROR;
752     }
753 
754     return NXT_UNIT_OK;
755 }
756 
757 
758 nxt_inline int
759 nxt_perl_psgi_add_value(PerlInterpreter *my_perl, HV *hash_env,
760     const char *name, uint32_t name_len, void *value)
761 {
762     SV  **ha;
763 
764     ha = hv_store(hash_env, name, (I32) name_len, value, 0);
765     if (nxt_slow_path(ha == NULL)) {
766         return NXT_UNIT_ERROR;
767     }
768 
769     return NXT_UNIT_OK;
770 }
771 
772 
773 static nxt_int_t
774 nxt_perl_psgi_result_status(PerlInterpreter *my_perl, SV *result)
775 {
776     SV         **sv_status;
777     AV         *array;
778     u_char     *space;
779     nxt_str_t  status;
780 
781     array = (AV *) SvRV(result);
782     sv_status = av_fetch(array, 0, 0);
783 
784     status.start = (u_char *) SvPV(*sv_status, status.length);
785 
786     space = nxt_memchr(status.start, ' ', status.length);
787     if (space != NULL) {
788         status.length = space - status.start;
789     }
790 
791     return nxt_int_parse(status.start, status.length);
792 }
793 
794 
795 static int
796 nxt_perl_psgi_result_head(PerlInterpreter *my_perl, SV *sv_head,
797     nxt_unit_request_info_t *req, uint16_t status)
798 {
799     AV         *array_head;
800     SV         **entry;
801     int        rc;
802     long       i, array_len;
803     char       *name, *value;
804     STRLEN     name_len, value_len;
805     uint32_t   fields, size;
806 
807     if (nxt_slow_path(SvROK(sv_head) == 0
808                       || SvTYPE(SvRV(sv_head)) != SVt_PVAV))
809     {
810         nxt_unit_req_error(req,
811                            "PSGI: An unsupported format was received from "
812                            "Perl Application for head part");
813 
814         return NXT_UNIT_ERROR;
815     }
816 
817     array_head = (AV *) SvRV(sv_head);
818     array_len = av_len(array_head);
819 
820     if (array_len < 1) {
821         return nxt_unit_response_init(req, status, 0, 0);
822     }
823 
824     if (nxt_slow_path((array_len % 2) == 0)) {
825         nxt_unit_req_error(req, "PSGI: Bad format for head from "
826                            "Perl Application");
827 
828         return NXT_UNIT_ERROR;
829     }
830 
831     fields = 0;
832     size = 0;
833 
834     for (i = 0; i <= array_len; i++) {
835         entry = av_fetch(array_head, i, 0);
836 
837         if (nxt_fast_path(entry == NULL)) {
838             nxt_unit_req_error(req, "PSGI: Failed to get head entry from "
839                                "Perl Application");
840 
841             return NXT_UNIT_ERROR;
842         }
843 
844         value = SvPV(*entry, value_len);
845         size += value_len;
846 
847         if ((i % 2) == 0) {
848             fields++;
849         }
850     }
851 
852     rc = nxt_unit_response_init(req, status, fields, size);
853     if (nxt_slow_path(rc != NXT_UNIT_OK)) {
854         return rc;
855     }
856 
857     for (i = 0; i <= array_len; i += 2) {
858         entry = av_fetch(array_head, i, 0);
859         name = SvPV(*entry, name_len);
860 
861         entry = av_fetch(array_head, i + 1, 0);
862         value = SvPV(*entry, value_len);
863 
864         rc = nxt_unit_response_add_field(req, name, name_len, value, value_len);
865         if (nxt_slow_path(rc != NXT_UNIT_OK)) {
866             return rc;
867         }
868     }
869 
870     return NXT_UNIT_OK;
871 }
872 
873 
874 static int
875 nxt_perl_psgi_result_body(PerlInterpreter *my_perl, SV *sv_body,
876     nxt_unit_request_info_t *req)
877 {
878     SV         **entry;
879     AV         *body_array;
880     int        rc;
881     long       i;
882     nxt_str_t  body;
883 
884     if (nxt_slow_path(SvROK(sv_body) == 0
885                       || SvTYPE(SvRV(sv_body)) != SVt_PVAV))
886     {
887         nxt_unit_req_error(req, "PSGI: An unsupported format was received from "
888                            "Perl Application for a body part");
889 
890         return NXT_UNIT_ERROR;
891     }
892 
893     body_array = (AV *) SvRV(sv_body);
894 
895     for (i = 0; i <= av_len(body_array); i++) {
896 
897         entry = av_fetch(body_array, i, 0);
898 
899         if (nxt_fast_path(entry == NULL)) {
900             nxt_unit_req_error(req, "PSGI: Failed to get body entry from "
901                                "Perl Application");
902 
903             return NXT_UNIT_ERROR;
904         }
905 
906         body.start = (u_char *) SvPV(*entry, body.length);
907 
908         if (body.length == 0) {
909             continue;
910         }
911 
912         rc = nxt_unit_response_write(req, body.start, body.length);
913 
914         if (nxt_slow_path(rc != NXT_UNIT_OK)) {
915             nxt_unit_req_error(req, "PSGI: Failed to write content from "
916                                "Perl Application");
917             return rc;
918         }
919     }
920 
921     return NXT_UNIT_OK;
922 }
923 
924 
925 static int
926 nxt_perl_psgi_result_body_ref(PerlInterpreter *my_perl, SV *sv_body,
927     nxt_unit_request_info_t *req)
928 {
929     SV          *data, *old_rs, *old_perl_rs;
930     int         rc;
931     size_t      len;
932     const char  *body;
933 
934     /*
935      * Servers should set the $/ special variable to the buffer size
936      * when reading content from $body using the getline method.
937      * This is done by setting $/ with a reference to an integer ($/ = \8192).
938      */
939 
940     old_rs = PL_rs;
941     old_perl_rs = get_sv("/", GV_ADD);
942 
943     PL_rs = sv_2mortal(newRV_noinc(newSViv(nxt_unit_buf_min())));
944 
945     sv_setsv(old_perl_rs, PL_rs);
946 
947     rc = NXT_UNIT_OK;
948 
949     for ( ;; ) {
950         data = nxt_perl_psgi_call_method(my_perl, sv_body, "getline", req);
951         if (nxt_slow_path(data == NULL)) {
952             rc = NXT_UNIT_ERROR;
953             break;
954         }
955 
956         body = SvPV(data, len);
957 
958         if (len == 0) {
959             SvREFCNT_dec(data);
960 
961             data = nxt_perl_psgi_call_method(my_perl, sv_body, "close", req);
962             if (nxt_fast_path(data != NULL)) {
963                 SvREFCNT_dec(data);
964             }
965 
966             break;
967         }
968 
969         rc = nxt_unit_response_write(req, body, len);
970 
971         SvREFCNT_dec(data);
972 
973         if (nxt_slow_path(rc != NXT_UNIT_OK)) {
974             nxt_unit_req_error(req, "PSGI: Failed to write content from "
975                                "Perl Application");
976             break;
977         }
978     };
979 
980     PL_rs =  old_rs;
981     sv_setsv(get_sv("/", GV_ADD), old_perl_rs);
982 
983     return rc;
984 }
985 
986 
987 typedef struct {
988     PerlInterpreter  *my_perl;
989     PerlIO           *fp;
990 } nxt_perl_psgi_io_ctx_t;
991 
992 
993 static int
994 nxt_perl_psgi_result_body_fh(PerlInterpreter *my_perl, SV *sv_body,
995     nxt_unit_request_info_t *req)
996 {
997     IO                      *io;
998     nxt_unit_read_info_t    read_info;
999     nxt_perl_psgi_io_ctx_t  io_ctx;
1000 
1001     io = GvIO(SvRV(sv_body));
1002 
1003     if (io == NULL) {
1004         return NXT_UNIT_OK;
1005     }
1006 
1007     io_ctx.my_perl = my_perl;
1008     io_ctx.fp = IoIFP(io);
1009 
1010     read_info.read = nxt_perl_psgi_io_read;
1011     read_info.eof = PerlIO_eof(io_ctx.fp);
1012     read_info.buf_size = 8192;
1013     read_info.data = &io_ctx;
1014 
1015     return nxt_unit_response_write_cb(req, &read_info);
1016 }
1017 
1018 
1019 static ssize_t
1020 nxt_perl_psgi_io_read(nxt_unit_read_info_t *read_info, void *dst, size_t size)
1021 {
1022     ssize_t                 res;
1023     nxt_perl_psgi_io_ctx_t  *ctx;
1024 
1025     ctx = read_info->data;
1026 
1027     dTHXa(ctx->my_perl);
1028 
1029     res = PerlIO_read(ctx->fp, dst, size);
1030 
1031     read_info->eof = PerlIO_eof(ctx->fp);
1032 
1033     return res;
1034 }
1035 
1036 
1037 static int
1038 nxt_perl_psgi_result_array(PerlInterpreter *my_perl, SV *result,
1039     nxt_unit_request_info_t *req)
1040 {
1041     AV         *array;
1042     SV         **sv_temp;
1043     int        rc;
1044     long       array_len;
1045     nxt_int_t  status;
1046 
1047     array = (AV *) SvRV(result);
1048     array_len = av_len(array);
1049 
1050     if (nxt_slow_path(array_len < 0)) {
1051         nxt_unit_req_error(req,
1052                            "PSGI: Invalid result format from Perl Application");
1053 
1054         return NXT_UNIT_ERROR;
1055     }
1056 
1057     status = nxt_perl_psgi_result_status(my_perl, result);
1058 
1059     if (nxt_slow_path(status < 0)) {
1060         nxt_unit_req_error(req,
1061                            "PSGI: An unexpected status was received "
1062                            "from Perl Application");
1063 
1064         return NXT_UNIT_ERROR;
1065     }
1066 
1067     if (array_len >= 1) {
1068         sv_temp = av_fetch(array, 1, 0);
1069 
1070         if (nxt_slow_path(sv_temp == NULL)) {
1071             nxt_unit_req_error(req, "PSGI: Failed to get head from "
1072                                "Perl ARRAY variable");
1073 
1074             return NXT_UNIT_ERROR;
1075         }
1076 
1077         rc = nxt_perl_psgi_result_head(my_perl, *sv_temp, req, status);
1078         if (nxt_slow_path(rc != NXT_UNIT_OK)) {
1079             return rc;
1080         }
1081 
1082     } else {
1083         return nxt_unit_response_init(req, status, 0, 0);
1084     }
1085 
1086     if (nxt_fast_path(array_len < 2)) {
1087         return NXT_UNIT_OK;
1088     }
1089 
1090     sv_temp = av_fetch(array, 2, 0);
1091 
1092     if (nxt_slow_path(sv_temp == NULL || SvROK(*sv_temp) == FALSE)) {
1093         nxt_unit_req_error(req,
1094                            "PSGI: Failed to get body from "
1095                            "Perl ARRAY variable");
1096 
1097         return NXT_UNIT_ERROR;
1098     }
1099 
1100     if (SvTYPE(SvRV(*sv_temp)) == SVt_PVAV) {
1101         return nxt_perl_psgi_result_body(my_perl, *sv_temp, req);
1102     }
1103 
1104     if (SvTYPE(SvRV(*sv_temp)) == SVt_PVGV) {
1105         return nxt_perl_psgi_result_body_fh(my_perl, *sv_temp, req);
1106     }
1107 
1108     return nxt_perl_psgi_result_body_ref(my_perl, *sv_temp, req);
1109 }
1110 
1111 
1112 static void
1113 nxt_perl_psgi_result_cb(PerlInterpreter *my_perl, SV *result,
1114     nxt_unit_request_info_t *req)
1115 {
1116     dSP;
1117 
1118     ENTER;
1119     SAVETMPS;
1120 
1121     PUSHMARK(sp);
1122     XPUSHs(newRV_noinc((SV*) nxt_perl_psgi_cb));
1123     PUTBACK;
1124 
1125     call_sv(result, G_EVAL|G_SCALAR);
1126 
1127     SPAGAIN;
1128 
1129     if (SvTRUE(ERRSV)) {
1130         nxt_unit_error(NULL, "PSGI: Failed to execute result callback: \n%s",
1131                        SvPV_nolen(ERRSV));
1132 
1133         nxt_perl_psgi_cb_request_done(NXT_UNIT_ERROR);
1134     }
1135 
1136     PUTBACK;
1137     FREETMPS;
1138     LEAVE;
1139 }
1140 
1141 
1142 static nxt_int_t
1143 nxt_perl_psgi_start(nxt_task_t *task, nxt_process_data_t *data)
1144 {
1145     int                     rc;
1146     nxt_unit_ctx_t          *unit_ctx;
1147     nxt_unit_init_t         perl_init;
1148     PerlInterpreter         *my_perl;
1149     nxt_common_app_conf_t   *conf;
1150     nxt_perl_psgi_module_t  module;
1151 
1152     conf = data->app;
1153 
1154     my_perl = nxt_perl_psgi_interpreter_init(task, conf->u.perl.script,
1155                                              &module.app);
1156 
1157     if (nxt_slow_path(my_perl == NULL)) {
1158         return NXT_ERROR;
1159     }
1160 
1161     module.my_perl = my_perl;
1162     nxt_perl_psgi = my_perl;
1163 
1164     nxt_unit_default_init(task, &perl_init);
1165 
1166     perl_init.callbacks.request_handler = nxt_perl_psgi_request_handler;
1167     perl_init.data = &module;
1168     perl_init.shm_limit = conf->shm_limit;
1169 
1170     unit_ctx = nxt_unit_init(&perl_init);
1171     if (nxt_slow_path(unit_ctx == NULL)) {
1172         return NXT_ERROR;
1173     }
1174 
1175     rc = nxt_unit_run(unit_ctx);
1176 
1177     nxt_unit_done(unit_ctx);
1178 
1179     nxt_perl_psgi_atexit();
1180 
1181     exit(rc);
1182 
1183     return NXT_OK;
1184 }
1185 
1186 
1187 static void
1188 nxt_perl_psgi_request_handler(nxt_unit_request_info_t *req)
1189 {
1190     SV                      *env, *result;
1191     nxt_int_t               rc;
1192     PerlInterpreter         *my_perl;
1193     nxt_perl_psgi_input_t   input;
1194     nxt_perl_psgi_module_t  *module;
1195 
1196     module = req->unit->data;
1197     my_perl = module->my_perl;
1198 
1199     input.my_perl = my_perl;
1200     input.req = req;
1201 
1202     nxt_perl_psgi_request = req;
1203 
1204     /*
1205      * Create environ variable for perl sub "application".
1206      *  > sub application {
1207      *  >     my ($environ) = @_;
1208      */
1209     env = nxt_perl_psgi_env_create(my_perl, req, &input);
1210     if (nxt_slow_path(env == NULL)) {
1211         nxt_unit_req_error(req,
1212                            "PSGI: Failed to create 'env' for Perl Application");
1213         nxt_unit_request_done(req, NXT_UNIT_ERROR);
1214 
1215         return;
1216     }
1217 
1218     nxt_perl_psgi_arg_input.ctx = &input;
1219     nxt_perl_psgi_arg_error.ctx = &input;
1220 
1221     /* Call perl sub and get result as SV*. */
1222     result = nxt_perl_psgi_call_var_application(my_perl, env, module->app, req);
1223 
1224     if (nxt_fast_path(SvOK(result) != 0 && SvROK(result) != 0)) {
1225 
1226         if (SvTYPE(SvRV(result)) == SVt_PVAV) {
1227             rc = nxt_perl_psgi_result_array(my_perl, result, req);
1228             nxt_unit_request_done(req, rc);
1229             goto release;
1230         }
1231 
1232         if (SvTYPE(SvRV(result)) == SVt_PVCV) {
1233             nxt_perl_psgi_result_cb(my_perl, result, req);
1234             goto release;
1235         }
1236     }
1237 
1238     nxt_unit_req_error(req, "PSGI: An unexpected response was received "
1239                        "from Perl Application");
1240 
1241     nxt_unit_request_done(req, NXT_UNIT_ERROR);
1242 
1243 release:
1244 
1245     SvREFCNT_dec(result);
1246     SvREFCNT_dec(env);
1247 }
1248 
1249 
1250 static void
1251 nxt_perl_psgi_atexit(void)
1252 {
1253     dTHXa(nxt_perl_psgi);
1254 
1255     nxt_perl_psgi_layer_stream_io_destroy(aTHX_ nxt_perl_psgi_arg_input.io);
1256     nxt_perl_psgi_layer_stream_fp_destroy(aTHX_ nxt_perl_psgi_arg_input.fp);
1257 
1258     nxt_perl_psgi_layer_stream_io_destroy(aTHX_ nxt_perl_psgi_arg_error.io);
1259     nxt_perl_psgi_layer_stream_fp_destroy(aTHX_ nxt_perl_psgi_arg_error.fp);
1260 
1261     perl_destruct(nxt_perl_psgi);
1262     perl_free(nxt_perl_psgi);
1263     PERL_SYS_TERM();
1264 }
1265