xref: /unit/src/perl/nxt_perl_psgi.c (revision 749:9290ae53e8bf)
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 
55 /* For currect load XS modules */
56 EXTERN_C void boot_DynaLoader(pTHX_ CV *cv);
57 
58 static nxt_int_t nxt_perl_psgi_io_input_init(PerlInterpreter *my_perl,
59     nxt_perl_psgi_io_arg_t *arg);
60 static nxt_int_t nxt_perl_psgi_io_error_init(PerlInterpreter *my_perl,
61     nxt_perl_psgi_io_arg_t *arg);
62 
63 static PerlInterpreter *nxt_perl_psgi_interpreter_init(nxt_task_t *task,
64     char *script, SV **app);
65 
66 static SV *nxt_perl_psgi_env_create(PerlInterpreter *my_perl,
67     nxt_unit_request_info_t *req, nxt_perl_psgi_input_t *input);
68 nxt_inline int nxt_perl_psgi_add_sptr(PerlInterpreter *my_perl, HV *hash_env,
69     const char *name, uint32_t name_len, nxt_unit_sptr_t *sptr, uint32_t len);
70 nxt_inline int nxt_perl_psgi_add_str(PerlInterpreter *my_perl, HV *hash_env,
71     const char *name, uint32_t name_len, char *str, uint32_t len);
72 nxt_inline int nxt_perl_psgi_add_value(PerlInterpreter *my_perl, HV *hash_env,
73     const char *name, uint32_t name_len, void *value);
74 
75 
76 static u_char *nxt_perl_psgi_module_create(nxt_task_t *task,
77     const char *script);
78 
79 static nxt_int_t nxt_perl_psgi_result_status(PerlInterpreter *my_perl,
80     SV *result);
81 static int nxt_perl_psgi_result_head(PerlInterpreter *my_perl,
82     SV *sv_head, nxt_unit_request_info_t *req, uint16_t status);
83 static int nxt_perl_psgi_result_body(PerlInterpreter *my_perl,
84     SV *result, nxt_unit_request_info_t *req);
85 static int nxt_perl_psgi_result_body_ref(PerlInterpreter *my_perl,
86     SV *sv_body, nxt_unit_request_info_t *req);
87 static ssize_t nxt_perl_psgi_io_read(nxt_unit_read_info_t *read_info,
88     void *dst, size_t size);
89 static int nxt_perl_psgi_result_array(PerlInterpreter *my_perl,
90     SV *result, nxt_unit_request_info_t *req);
91 
92 static nxt_int_t nxt_perl_psgi_init(nxt_task_t *task,
93     nxt_common_app_conf_t *conf);
94 static void nxt_perl_psgi_request_handler(nxt_unit_request_info_t *req);
95 static void nxt_perl_psgi_atexit(void);
96 
97 typedef SV *(*nxt_perl_psgi_callback_f)(PerlInterpreter *my_perl,
98     SV *env, nxt_task_t *task);
99 
100 static PerlInterpreter         *nxt_perl_psgi;
101 static nxt_perl_psgi_io_arg_t  nxt_perl_psgi_arg_input, nxt_perl_psgi_arg_error;
102 
103 static uint32_t  nxt_perl_psgi_compat[] = {
104     NXT_VERNUM, NXT_DEBUG,
105 };
106 
107 NXT_EXPORT nxt_app_module_t  nxt_app_module = {
108     sizeof(nxt_perl_psgi_compat),
109     nxt_perl_psgi_compat,
110     nxt_string("perl"),
111     PERL_VERSION_STRING,
112     nxt_perl_psgi_init,
113 };
114 
115 
116 static long
117 nxt_perl_psgi_io_input_read(PerlInterpreter *my_perl,
118     nxt_perl_psgi_io_arg_t *arg, void *vbuf, size_t length)
119 {
120     nxt_perl_psgi_input_t  *input;
121 
122     input = (nxt_perl_psgi_input_t *) arg->ctx;
123 
124     return nxt_unit_request_read(input->req, vbuf, length);
125 }
126 
127 
128 static long
129 nxt_perl_psgi_io_input_write(PerlInterpreter *my_perl,
130     nxt_perl_psgi_io_arg_t *arg, const void *vbuf, size_t length)
131 {
132     return 0;
133 }
134 
135 
136 static long
137 nxt_perl_psgi_io_input_flush(PerlInterpreter *my_perl,
138     nxt_perl_psgi_io_arg_t *arg)
139 {
140     return 0;
141 }
142 
143 
144 static long
145 nxt_perl_psgi_io_error_read(PerlInterpreter *my_perl,
146     nxt_perl_psgi_io_arg_t *arg, void *vbuf, size_t length)
147 {
148     return 0;
149 }
150 
151 
152 static long
153 nxt_perl_psgi_io_error_write(PerlInterpreter *my_perl,
154     nxt_perl_psgi_io_arg_t *arg, const void *vbuf, size_t length)
155 {
156     nxt_perl_psgi_input_t *input;
157 
158     input = (nxt_perl_psgi_input_t *) arg->ctx;
159     nxt_unit_req_error(input->req, "Perl: %s", vbuf);
160 
161     return (long) length;
162 }
163 
164 
165 static long
166 nxt_perl_psgi_io_error_flush(PerlInterpreter *my_perl,
167     nxt_perl_psgi_io_arg_t *arg)
168 {
169     return 0;
170 }
171 
172 
173 /* In the future it will be necessary to change some Perl functions. */
174 /*
175 static void
176 nxt_perl_psgi_xs_core_global_changes(PerlInterpreter *my_perl,
177     const char *core, const char *sub, XSUBADDR_t sub_addr)
178 {
179     GV  *gv;
180 
181     gv = gv_fetchpv(core, TRUE, SVt_PVCV);
182 
183 #ifdef MUTABLE_CV
184     GvCV_set(gv, MUTABLE_CV(SvREFCNT_inc(get_cv(sub, TRUE))));
185 #else
186     GvCV_set(gv, (CV *) (SvREFCNT_inc(get_cv(sub, TRUE))));
187 #endif
188     GvIMPORTED_CV_on(gv);
189 
190     newXS(sub, sub_addr, __FILE__);
191 }
192 */
193 
194 
195 XS(XS_NGINX__Unit__PSGI_exit);
196 XS(XS_NGINX__Unit__PSGI_exit)
197 {
198     I32 ax = POPMARK;
199     Perl_croak(aTHX_ (char *) NULL);
200     XSRETURN_EMPTY;
201 }
202 
203 
204 static void
205 nxt_perl_psgi_xs_init(pTHX)
206 {
207 /*
208     nxt_perl_psgi_xs_core_global_changes(my_perl, "CORE::GLOBAL::exit",
209                                          "NGINX::Unit::PSGI::exit",
210                                          XS_NGINX__Unit__PSGI_exit);
211 */
212     nxt_perl_psgi_layer_stream_init(aTHX);
213 
214     /* DynaLoader for Perl modules who use XS */
215     newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, __FILE__);
216 }
217 
218 
219 static SV *
220 nxt_perl_psgi_call_var_application(PerlInterpreter *my_perl,
221     SV *env, SV *app, nxt_unit_request_info_t *req)
222 {
223     SV  *result;
224 
225     dSP;
226 
227     ENTER;
228     SAVETMPS;
229 
230     PUSHMARK(sp);
231     XPUSHs(env);
232     PUTBACK;
233 
234     call_sv(app, G_EVAL|G_SCALAR);
235 
236     SPAGAIN;
237 
238     if (SvTRUE(ERRSV)) {
239         nxt_unit_req_error(req, "PSGI: Failed to run Perl Application: \n%s",
240                            SvPV_nolen(ERRSV));
241     }
242 
243     result = POPs;
244     SvREFCNT_inc(result);
245 
246     PUTBACK;
247     FREETMPS;
248     LEAVE;
249 
250     return result;
251 }
252 
253 
254 static u_char *
255 nxt_perl_psgi_module_create(nxt_task_t *task, const char *script)
256 {
257     u_char  *buf, *p;
258     size_t  length;
259 
260     static nxt_str_t  prefix = nxt_string(
261         "package NGINX::Unit::Sandbox;"
262         "{my $app = do \""
263     );
264 
265     static nxt_str_t  suffix = nxt_string_zero(
266         "\";"
267         "unless ($app) {"
268         "    if($@ || $1) {die $@ || $1}"
269         "    else {die \"File not found or compilation error.\"}"
270         "} "
271         "return $app}"
272     );
273 
274     length = strlen(script);
275 
276     buf = nxt_malloc(prefix.length + length + suffix.length);
277 
278     if (nxt_slow_path(buf == NULL)) {
279         nxt_log_error(NXT_LOG_ERR, task->log,
280                       "PSGI: Failed to allocate memory "
281                       "for Perl script file %s", script);
282         return NULL;
283     }
284 
285     p = nxt_cpymem(buf, prefix.start, prefix.length);
286     p = nxt_cpymem(p, script, length);
287     nxt_memcpy(p, suffix.start, suffix.length);
288 
289     return buf;
290 }
291 
292 
293 static nxt_int_t
294 nxt_perl_psgi_io_input_init(PerlInterpreter *my_perl,
295     nxt_perl_psgi_io_arg_t *arg)
296 {
297     SV      *io;
298     PerlIO  *fp;
299 
300     fp = nxt_perl_psgi_layer_stream_fp_create(aTHX_ arg, "r");
301 
302     if (nxt_slow_path(fp == NULL)) {
303         return NXT_ERROR;
304     }
305 
306     io = nxt_perl_psgi_layer_stream_io_create(aTHX_ fp);
307 
308     if (nxt_slow_path(io == NULL)) {
309         nxt_perl_psgi_layer_stream_fp_destroy(aTHX_ fp);
310         return NXT_ERROR;
311     }
312 
313     arg->io = io;
314     arg->fp = fp;
315     arg->flush = nxt_perl_psgi_io_input_flush;
316     arg->read = nxt_perl_psgi_io_input_read;
317     arg->write = nxt_perl_psgi_io_input_write;
318 
319     return NXT_OK;
320 }
321 
322 
323 static nxt_int_t
324 nxt_perl_psgi_io_error_init(PerlInterpreter *my_perl,
325     nxt_perl_psgi_io_arg_t *arg)
326 {
327     SV      *io;
328     PerlIO  *fp;
329 
330     fp = nxt_perl_psgi_layer_stream_fp_create(aTHX_ arg, "w");
331 
332     if (nxt_slow_path(fp == NULL)) {
333         return NXT_ERROR;
334     }
335 
336     io = nxt_perl_psgi_layer_stream_io_create(aTHX_ fp);
337 
338     if (nxt_slow_path(io == NULL)) {
339         nxt_perl_psgi_layer_stream_fp_destroy(aTHX_ fp);
340         return NXT_ERROR;
341     }
342 
343     arg->io = io;
344     arg->fp = fp;
345     arg->flush = nxt_perl_psgi_io_error_flush;
346     arg->read = nxt_perl_psgi_io_error_read;
347     arg->write = nxt_perl_psgi_io_error_write;
348 
349     return NXT_OK;
350 }
351 
352 
353 static PerlInterpreter *
354 nxt_perl_psgi_interpreter_init(nxt_task_t *task, char *script, SV **app)
355 {
356     int              status, pargc;
357     char             **pargv, **penv;
358     u_char           *run_module;
359     PerlInterpreter  *my_perl;
360 
361     static char  argv[] = "\0""-e\0""0";
362     static char  *embedding[] = { &argv[0], &argv[1], &argv[4] };
363 
364     pargc = 0;
365     pargv = NULL;
366     penv = NULL;
367 
368     PERL_SYS_INIT3(&pargc, &pargv, &penv);
369 
370     my_perl = perl_alloc();
371 
372     if (nxt_slow_path(my_perl == NULL)) {
373         nxt_alert(task, "PSGI: Failed to allocate memory for Perl interpreter");
374         return NULL;
375     }
376 
377     run_module = NULL;
378 
379     perl_construct(my_perl);
380     PERL_SET_CONTEXT(my_perl);
381 
382     status = perl_parse(my_perl, nxt_perl_psgi_xs_init, 3, embedding, NULL);
383 
384     if (nxt_slow_path(status != 0)) {
385         nxt_alert(task, "PSGI: Failed to parse Perl Script");
386         goto fail;
387     }
388 
389     PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
390     PL_origalen = 1;
391 
392     status = perl_run(my_perl);
393 
394     if (nxt_slow_path(status != 0)) {
395         nxt_alert(task, "PSGI: Failed to run Perl");
396         goto fail;
397     }
398 
399     sv_setsv(get_sv("0", 0), newSVpv(script, 0));
400 
401     run_module = nxt_perl_psgi_module_create(task, script);
402 
403     if (nxt_slow_path(run_module == NULL)) {
404         goto fail;
405     }
406 
407     status = nxt_perl_psgi_io_input_init(my_perl, &nxt_perl_psgi_arg_input);
408 
409     if (nxt_slow_path(status != NXT_OK)) {
410         nxt_alert(task, "PSGI: Failed to init io.psgi.input");
411         goto fail;
412     }
413 
414     status = nxt_perl_psgi_io_error_init(my_perl, &nxt_perl_psgi_arg_error);
415 
416     if (nxt_slow_path(status != NXT_OK)) {
417         nxt_alert(task, "PSGI: Failed to init io.psgi.errors");
418         goto fail;
419     }
420 
421     *app = eval_pv((const char *) run_module, FALSE);
422 
423     if (SvTRUE(ERRSV)) {
424         nxt_alert(task, "PSGI: Failed to parse script: %s\n%s",
425                   script, SvPV_nolen(ERRSV));
426         goto fail;
427     }
428 
429     nxt_free(run_module);
430 
431     return my_perl;
432 
433 fail:
434 
435     if (run_module != NULL) {
436         nxt_free(run_module);
437     }
438 
439     perl_destruct(my_perl);
440     perl_free(my_perl);
441     PERL_SYS_TERM();
442 
443     return NULL;
444 }
445 
446 
447 static SV *
448 nxt_perl_psgi_env_create(PerlInterpreter *my_perl,
449     nxt_unit_request_info_t *req, nxt_perl_psgi_input_t *input)
450 {
451     HV                  *hash_env;
452     AV                  *array_version;
453     char                *host_start, *port_start;
454     uint32_t            i, host_length, port_length;
455     nxt_unit_field_t    *f;
456     nxt_unit_request_t  *r;
457 
458     hash_env = newHV();
459     if (nxt_slow_path(hash_env == NULL)) {
460         return NULL;
461     }
462 
463 #define RC(FNS)                                                               \
464     do {                                                                      \
465         if (nxt_slow_path((FNS) != NXT_UNIT_OK))                              \
466             goto fail;                                                        \
467      } while (0)
468 
469 #define NL(S) (S), sizeof(S)-1
470 
471     r = req->request;
472 
473     RC(nxt_perl_psgi_add_str(my_perl, hash_env, NL("SERVER_SOFTWARE"),
474                              (char *) nxt_server.start, nxt_server.length));
475 
476     RC(nxt_perl_psgi_add_sptr(my_perl, hash_env, NL("REQUEST_METHOD"),
477                               &r->method, r->method_length));
478     RC(nxt_perl_psgi_add_sptr(my_perl, hash_env, NL("REQUEST_URI"),
479                               &r->target, r->target_length));
480     RC(nxt_perl_psgi_add_sptr(my_perl, hash_env, NL("PATH_INFO"),
481                               &r->path, r->path_length));
482 
483     array_version = newAV();
484 
485     if (nxt_slow_path(array_version == NULL)) {
486         goto fail;
487     }
488 
489     av_push(array_version, newSViv(1));
490     av_push(array_version, newSViv(1));
491 
492     RC(nxt_perl_psgi_add_value(my_perl, hash_env, NL("psgi.version"),
493                                 newRV_noinc((SV *) array_version)));
494     RC(nxt_perl_psgi_add_value(my_perl, hash_env, NL("psgi.url_scheme"),
495                                 newSVpv("http", 4)));
496     RC(nxt_perl_psgi_add_value(my_perl, hash_env, NL("psgi.input"),
497                                 SvREFCNT_inc(nxt_perl_psgi_arg_input.io)));
498     RC(nxt_perl_psgi_add_value(my_perl, hash_env, NL("psgi.errors"),
499                                 SvREFCNT_inc(nxt_perl_psgi_arg_error.io)));
500     RC(nxt_perl_psgi_add_value(my_perl, hash_env, NL("psgi.multithread"),
501                                 &PL_sv_no));
502     RC(nxt_perl_psgi_add_value(my_perl, hash_env, NL("psgi.multiprocess"),
503                                 &PL_sv_yes));
504     RC(nxt_perl_psgi_add_value(my_perl, hash_env, NL("psgi.run_once"),
505                                 &PL_sv_no));
506     RC(nxt_perl_psgi_add_value(my_perl, hash_env, NL("psgi.nonblocking"),
507                                 &PL_sv_no));
508     RC(nxt_perl_psgi_add_value(my_perl, hash_env, NL("psgi.streaming"),
509                                 &PL_sv_no));
510 
511     if (r->query.offset) {
512         RC(nxt_perl_psgi_add_sptr(my_perl, hash_env, NL("QUERY_STRING"),
513                                   &r->query, r->query_length));
514     }
515     RC(nxt_perl_psgi_add_sptr(my_perl, hash_env, NL("SERVER_PROTOCOL"),
516                               &r->version, r->version_length));
517     RC(nxt_perl_psgi_add_sptr(my_perl, hash_env, NL("REMOTE_ADDR"),
518                               &r->remote, r->remote_length));
519     RC(nxt_perl_psgi_add_sptr(my_perl, hash_env, NL("SERVER_ADDR"),
520                               &r->local, r->local_length));
521 
522     for (i = 0; i < r->fields_count; i++) {
523         f = r->fields + i;
524 
525         RC(nxt_perl_psgi_add_sptr(my_perl, hash_env,
526                                   nxt_unit_sptr_get(&f->name), f->name_length,
527                                   &f->value, f->value_length));
528     }
529 
530     if (r->content_length_field != NXT_UNIT_NONE_FIELD) {
531         f = r->fields + r->content_length_field;
532 
533         RC(nxt_perl_psgi_add_sptr(my_perl, hash_env, NL("CONTENT_LENGTH"),
534                                   &f->value, f->value_length));
535     }
536 
537     if (r->content_type_field != NXT_UNIT_NONE_FIELD) {
538         f = r->fields + r->content_type_field;
539 
540         RC(nxt_perl_psgi_add_sptr(my_perl, hash_env, NL("CONTENT_TYPE"),
541                                   &f->value, f->value_length));
542     }
543 
544     if (r->host_field != NXT_UNIT_NONE_FIELD) {
545         f = r->fields + r->host_field;
546 
547         host_start = nxt_unit_sptr_get(&f->value);
548         host_length = f->value_length;
549 
550     } else {
551         host_start = NULL;
552         host_length = 0;
553     }
554 
555     nxt_unit_split_host(host_start, host_length, &host_start, &host_length,
556                         &port_start, &port_length);
557 
558     RC(nxt_perl_psgi_add_str(my_perl, hash_env, NL("SERVER_NAME"),
559                              host_start, host_length));
560     RC(nxt_perl_psgi_add_str(my_perl, hash_env, NL("SERVER_PORT"),
561                              port_start, port_length));
562 
563 #undef NL
564 #undef RC
565 
566     return newRV_noinc((SV *) hash_env);
567 
568 fail:
569 
570     SvREFCNT_dec(hash_env);
571 
572     return NULL;
573 }
574 
575 
576 nxt_inline int
577 nxt_perl_psgi_add_sptr(PerlInterpreter *my_perl, HV *hash_env,
578     const char *name, uint32_t name_len, nxt_unit_sptr_t *sptr, uint32_t len)
579 {
580     return nxt_perl_psgi_add_str(my_perl, hash_env, name, name_len,
581                                  nxt_unit_sptr_get(sptr), len);
582 }
583 
584 
585 nxt_inline int
586 nxt_perl_psgi_add_str(PerlInterpreter *my_perl, HV *hash_env,
587     const char *name, uint32_t name_len, char *str, uint32_t len)
588 {
589     SV  **ha;
590 
591     ha = hv_store(hash_env, name, (I32) name_len,
592                   newSVpv(str, (STRLEN) len), 0);
593     if (nxt_slow_path(ha == NULL)) {
594         return NXT_UNIT_ERROR;
595     }
596 
597     return NXT_UNIT_OK;
598 }
599 
600 
601 nxt_inline int
602 nxt_perl_psgi_add_value(PerlInterpreter *my_perl, HV *hash_env,
603     const char *name, uint32_t name_len, void *value)
604 {
605     SV  **ha;
606 
607     ha = hv_store(hash_env, name, (I32) name_len, value, 0);
608     if (nxt_slow_path(ha == NULL)) {
609         return NXT_UNIT_ERROR;
610     }
611 
612     return NXT_UNIT_OK;
613 }
614 
615 
616 static nxt_int_t
617 nxt_perl_psgi_result_status(PerlInterpreter *my_perl, SV *result)
618 {
619     SV         **sv_status;
620     AV         *array;
621     u_char     *space;
622     nxt_str_t  status;
623 
624     array = (AV *) SvRV(result);
625     sv_status = av_fetch(array, 0, 0);
626 
627     status.start = (u_char *) SvPV(*sv_status, status.length);
628 
629     space = nxt_memchr(status.start, ' ', status.length);
630     if (space != NULL) {
631         status.length = space - status.start;
632     }
633 
634     return nxt_int_parse(status.start, status.length);
635 }
636 
637 
638 static int
639 nxt_perl_psgi_result_head(PerlInterpreter *my_perl, SV *sv_head,
640     nxt_unit_request_info_t *req, uint16_t status)
641 {
642     AV         *array_head;
643     SV         **entry;
644     int        rc;
645     long       i, array_len;
646     char       *name, *value;
647     STRLEN     name_len, value_len;
648     uint32_t   fields, size;
649 
650     if (nxt_slow_path(SvROK(sv_head) == 0
651                       || SvTYPE(SvRV(sv_head)) != SVt_PVAV))
652     {
653         nxt_unit_req_error(req,
654                            "PSGI: An unsupported format was received from "
655                            "Perl Application for head part");
656 
657         return NXT_UNIT_ERROR;
658     }
659 
660     array_head = (AV *) SvRV(sv_head);
661     array_len = av_len(array_head);
662 
663     if (array_len < 1) {
664         return nxt_unit_response_init(req, status, 0, 0);
665     }
666 
667     if (nxt_slow_path((array_len % 2) == 0)) {
668         nxt_unit_req_error(req, "PSGI: Bad format for head from "
669                            "Perl Application");
670 
671         return NXT_UNIT_ERROR;
672     }
673 
674     fields = 0;
675     size = 0;
676 
677     for (i = 0; i <= array_len; i++) {
678         entry = av_fetch(array_head, i, 0);
679 
680         if (nxt_fast_path(entry == NULL)) {
681             nxt_unit_req_error(req, "PSGI: Failed to get head entry from "
682                                "Perl Application");
683 
684             return NXT_UNIT_ERROR;
685         }
686 
687         value = SvPV(*entry, value_len);
688         size += value_len;
689 
690         if ((i % 2) == 0) {
691             fields++;
692         }
693     }
694 
695     rc = nxt_unit_response_init(req, status, fields, size);
696     if (nxt_slow_path(rc != NXT_UNIT_OK)) {
697         return rc;
698     }
699 
700     for (i = 0; i <= array_len; i += 2) {
701         entry = av_fetch(array_head, i, 0);
702         name = SvPV(*entry, name_len);
703 
704         entry = av_fetch(array_head, i + 1, 0);
705         value = SvPV(*entry, value_len);
706 
707         rc = nxt_unit_response_add_field(req, name, name_len, value, value_len);
708         if (nxt_slow_path(rc != NXT_UNIT_OK)) {
709             return rc;
710         }
711     }
712 
713     return NXT_UNIT_OK;
714 }
715 
716 
717 static int
718 nxt_perl_psgi_result_body(PerlInterpreter *my_perl, SV *sv_body,
719     nxt_unit_request_info_t *req)
720 {
721     SV         **entry;
722     AV         *body_array;
723     int        rc;
724     long       i;
725     nxt_str_t  body;
726 
727     if (nxt_slow_path(SvROK(sv_body) == 0
728                       || SvTYPE(SvRV(sv_body)) != SVt_PVAV))
729     {
730         nxt_unit_req_error(req, "PSGI: An unsupported format was received from "
731                            "Perl Application for a body part");
732 
733         return NXT_UNIT_ERROR;
734     }
735 
736     body_array = (AV *) SvRV(sv_body);
737 
738     for (i = 0; i <= av_len(body_array); i++) {
739 
740         entry = av_fetch(body_array, i, 0);
741 
742         if (nxt_fast_path(entry == NULL)) {
743             nxt_unit_req_error(req, "PSGI: Failed to get body entry from "
744                                "Perl Application");
745 
746             return NXT_UNIT_ERROR;
747         }
748 
749         body.start = (u_char *) SvPV(*entry, body.length);
750 
751         if (body.length == 0) {
752             continue;
753         }
754 
755         rc = nxt_unit_response_write(req, body.start, body.length);
756 
757         if (nxt_slow_path(rc != NXT_UNIT_OK)) {
758             nxt_unit_req_error(req, "PSGI: Failed to write content from "
759                                "Perl Application");
760             return rc;
761         }
762     }
763 
764     return NXT_UNIT_OK;
765 }
766 
767 
768 typedef struct {
769     PerlInterpreter  *my_perl;
770     PerlIO           *fp;
771 } nxt_perl_psgi_io_ctx_t;
772 
773 
774 static int
775 nxt_perl_psgi_result_body_ref(PerlInterpreter *my_perl, SV *sv_body,
776     nxt_unit_request_info_t *req)
777 {
778     IO                      *io;
779     nxt_unit_read_info_t    read_info;
780     nxt_perl_psgi_io_ctx_t  io_ctx;
781 
782     io = GvIO(SvRV(sv_body));
783 
784     if (io == NULL) {
785         return NXT_UNIT_OK;
786     }
787 
788     io_ctx.my_perl = my_perl;
789     io_ctx.fp = IoIFP(io);
790 
791     read_info.read = nxt_perl_psgi_io_read;
792     read_info.eof = PerlIO_eof(io_ctx.fp);
793     read_info.buf_size = 8192;
794     read_info.data = &io_ctx;
795 
796     return nxt_unit_response_write_cb(req, &read_info);
797 }
798 
799 
800 static ssize_t
801 nxt_perl_psgi_io_read(nxt_unit_read_info_t *read_info, void *dst, size_t size)
802 {
803     ssize_t                 res;
804     nxt_perl_psgi_io_ctx_t  *ctx;
805 
806     ctx = read_info->data;
807 
808     dTHXa(ctx->my_perl);
809 
810     res = PerlIO_read(ctx->fp, dst, size);
811 
812     read_info->eof = PerlIO_eof(ctx->fp);
813 
814     return res;
815 }
816 
817 
818 static int
819 nxt_perl_psgi_result_array(PerlInterpreter *my_perl, SV *result,
820     nxt_unit_request_info_t *req)
821 {
822     AV         *array;
823     SV         **sv_temp;
824     int        rc;
825     long       array_len;
826     nxt_int_t  status;
827 
828     array = (AV *) SvRV(result);
829     array_len = av_len(array);
830 
831     if (nxt_slow_path(array_len < 0)) {
832         nxt_unit_req_error(req,
833                            "PSGI: Invalid result format from Perl Application");
834 
835         return NXT_UNIT_ERROR;
836     }
837 
838     status = nxt_perl_psgi_result_status(my_perl, result);
839 
840     if (nxt_slow_path(status < 0)) {
841         nxt_unit_req_error(req,
842                            "PSGI: An unexpected status was received "
843                            "from Perl Application");
844 
845         return NXT_UNIT_ERROR;
846     }
847 
848     if (array_len >= 1) {
849         sv_temp = av_fetch(array, 1, 0);
850 
851         if (nxt_slow_path(sv_temp == NULL)) {
852             nxt_unit_req_error(req, "PSGI: Failed to get head from "
853                                "Perl ARRAY variable");
854 
855             return NXT_UNIT_ERROR;
856         }
857 
858         rc = nxt_perl_psgi_result_head(my_perl, *sv_temp, req, status);
859         if (nxt_slow_path(rc != NXT_UNIT_OK)) {
860             return rc;
861         }
862 
863     } else {
864         return nxt_unit_response_init(req, status, 0, 0);
865     }
866 
867     if (nxt_fast_path(array_len < 2)) {
868         return NXT_UNIT_OK;
869     }
870 
871     sv_temp = av_fetch(array, 2, 0);
872 
873     if (nxt_slow_path(sv_temp == NULL || SvROK(*sv_temp) == FALSE)) {
874         nxt_unit_req_error(req,
875                            "PSGI: Failed to get body from "
876                            "Perl ARRAY variable");
877 
878         return NXT_UNIT_ERROR;
879     }
880 
881     if (SvTYPE(SvRV(*sv_temp)) == SVt_PVAV) {
882         return nxt_perl_psgi_result_body(my_perl, *sv_temp, req);
883     }
884 
885     return nxt_perl_psgi_result_body_ref(my_perl, *sv_temp, req);
886 }
887 
888 
889 static nxt_int_t
890 nxt_perl_psgi_init(nxt_task_t *task, nxt_common_app_conf_t *conf)
891 {
892     int                     rc;
893     nxt_unit_ctx_t          *unit_ctx;
894     nxt_unit_init_t         perl_init;
895     PerlInterpreter         *my_perl;
896     nxt_perl_psgi_module_t  module;
897 
898     my_perl = nxt_perl_psgi_interpreter_init(task, conf->u.perl.script,
899                                              &module.app);
900 
901     if (nxt_slow_path(my_perl == NULL)) {
902         return NXT_ERROR;
903     }
904 
905     module.my_perl = my_perl;
906     nxt_perl_psgi = my_perl;
907 
908     nxt_unit_default_init(task, &perl_init);
909 
910     perl_init.callbacks.request_handler = nxt_perl_psgi_request_handler;
911     perl_init.data = &module;
912 
913     unit_ctx = nxt_unit_init(&perl_init);
914     if (nxt_slow_path(unit_ctx == NULL)) {
915         return NXT_ERROR;
916     }
917 
918     rc = nxt_unit_run(unit_ctx);
919 
920     nxt_unit_done(unit_ctx);
921 
922     nxt_perl_psgi_atexit();
923 
924     exit(rc);
925 
926     return NXT_OK;
927 }
928 
929 
930 static void
931 nxt_perl_psgi_request_handler(nxt_unit_request_info_t *req)
932 {
933     SV                      *env, *result;
934     nxt_int_t               rc;
935     PerlInterpreter         *my_perl;
936     nxt_perl_psgi_input_t   input;
937     nxt_perl_psgi_module_t  *module;
938 
939     module = req->unit->data;
940     my_perl = module->my_perl;
941 
942     input.my_perl = my_perl;
943     input.req = req;
944 
945     /*
946      * Create environ variable for perl sub "application".
947      *  > sub application {
948      *  >     my ($environ) = @_;
949      */
950     env = nxt_perl_psgi_env_create(my_perl, req, &input);
951     if (nxt_slow_path(env == NULL)) {
952         nxt_unit_req_error(req,
953                            "PSGI: Failed to create 'env' for Perl Application");
954         nxt_unit_request_done(req, NXT_UNIT_ERROR);
955 
956         return;
957     }
958 
959     nxt_perl_psgi_arg_input.ctx = &input;
960     nxt_perl_psgi_arg_error.ctx = &input;
961 
962     /* Call perl sub and get result as SV*. */
963     result = nxt_perl_psgi_call_var_application(my_perl, env, module->app, req);
964 
965     /*
966      * We expect ARRAY ref like a
967      * ['200', ['Content-Type' => "text/plain"], ["body"]]
968      */
969     if (nxt_slow_path(SvOK(result) == 0 || SvROK(result) == 0
970                       || SvTYPE(SvRV(result)) != SVt_PVAV))
971     {
972         nxt_unit_req_error(req, "PSGI: An unexpected response was received "
973                            "from Perl Application");
974 
975         rc = NXT_UNIT_ERROR;
976 
977     } else {
978         rc = nxt_perl_psgi_result_array(my_perl, result, req);
979     }
980 
981     nxt_unit_request_done(req, rc);
982 
983     SvREFCNT_dec(result);
984     SvREFCNT_dec(env);
985 }
986 
987 
988 static void
989 nxt_perl_psgi_atexit(void)
990 {
991     dTHXa(nxt_perl_psgi);
992 
993     nxt_perl_psgi_layer_stream_io_destroy(aTHX_ nxt_perl_psgi_arg_input.io);
994     nxt_perl_psgi_layer_stream_fp_destroy(aTHX_ nxt_perl_psgi_arg_input.fp);
995 
996     nxt_perl_psgi_layer_stream_io_destroy(aTHX_ nxt_perl_psgi_arg_error.io);
997     nxt_perl_psgi_layer_stream_fp_destroy(aTHX_ nxt_perl_psgi_arg_error.fp);
998 
999     perl_destruct(nxt_perl_psgi);
1000     perl_free(nxt_perl_psgi);
1001     PERL_SYS_TERM();
1002 }
1003