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