xref: /unit/src/perl/nxt_perl_psgi.c (revision 981:e9253a35f47a)
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     RC(nxt_perl_psgi_add_sptr(my_perl, hash_env, NL("QUERY_STRING"),
552                               &r->query, r->query_length));
553     RC(nxt_perl_psgi_add_sptr(my_perl, hash_env, NL("SERVER_PROTOCOL"),
554                               &r->version, r->version_length));
555     RC(nxt_perl_psgi_add_sptr(my_perl, hash_env, NL("REMOTE_ADDR"),
556                               &r->remote, r->remote_length));
557     RC(nxt_perl_psgi_add_sptr(my_perl, hash_env, NL("SERVER_ADDR"),
558                               &r->local, r->local_length));
559 
560     RC(nxt_perl_psgi_add_sptr(my_perl, hash_env, NL("SERVER_NAME"),
561                               &r->server_name, r->server_name_length));
562     RC(nxt_perl_psgi_add_str(my_perl, hash_env, NL("SERVER_PORT"), "80", 2));
563 
564     for (i = 0; i < r->fields_count; i++) {
565         f = r->fields + i;
566 
567         RC(nxt_perl_psgi_add_sptr(my_perl, hash_env,
568                                   nxt_unit_sptr_get(&f->name), f->name_length,
569                                   &f->value, f->value_length));
570     }
571 
572     if (r->content_length_field != NXT_UNIT_NONE_FIELD) {
573         f = r->fields + r->content_length_field;
574 
575         RC(nxt_perl_psgi_add_sptr(my_perl, hash_env, NL("CONTENT_LENGTH"),
576                                   &f->value, f->value_length));
577     }
578 
579     if (r->content_type_field != NXT_UNIT_NONE_FIELD) {
580         f = r->fields + r->content_type_field;
581 
582         RC(nxt_perl_psgi_add_sptr(my_perl, hash_env, NL("CONTENT_TYPE"),
583                                   &f->value, f->value_length));
584     }
585 
586 #undef NL
587 #undef RC
588 
589     return newRV_noinc((SV *) hash_env);
590 
591 fail:
592 
593     SvREFCNT_dec(hash_env);
594 
595     return NULL;
596 }
597 
598 
599 nxt_inline int
600 nxt_perl_psgi_add_sptr(PerlInterpreter *my_perl, HV *hash_env,
601     const char *name, uint32_t name_len, nxt_unit_sptr_t *sptr, uint32_t len)
602 {
603     return nxt_perl_psgi_add_str(my_perl, hash_env, name, name_len,
604                                  nxt_unit_sptr_get(sptr), len);
605 }
606 
607 
608 nxt_inline int
609 nxt_perl_psgi_add_str(PerlInterpreter *my_perl, HV *hash_env,
610     const char *name, uint32_t name_len, const char *str, uint32_t len)
611 {
612     SV  **ha;
613 
614     ha = hv_store(hash_env, name, (I32) name_len,
615                   newSVpv(str, (STRLEN) len), 0);
616     if (nxt_slow_path(ha == NULL)) {
617         return NXT_UNIT_ERROR;
618     }
619 
620     return NXT_UNIT_OK;
621 }
622 
623 
624 nxt_inline int
625 nxt_perl_psgi_add_value(PerlInterpreter *my_perl, HV *hash_env,
626     const char *name, uint32_t name_len, void *value)
627 {
628     SV  **ha;
629 
630     ha = hv_store(hash_env, name, (I32) name_len, value, 0);
631     if (nxt_slow_path(ha == NULL)) {
632         return NXT_UNIT_ERROR;
633     }
634 
635     return NXT_UNIT_OK;
636 }
637 
638 
639 static nxt_int_t
640 nxt_perl_psgi_result_status(PerlInterpreter *my_perl, SV *result)
641 {
642     SV         **sv_status;
643     AV         *array;
644     u_char     *space;
645     nxt_str_t  status;
646 
647     array = (AV *) SvRV(result);
648     sv_status = av_fetch(array, 0, 0);
649 
650     status.start = (u_char *) SvPV(*sv_status, status.length);
651 
652     space = nxt_memchr(status.start, ' ', status.length);
653     if (space != NULL) {
654         status.length = space - status.start;
655     }
656 
657     return nxt_int_parse(status.start, status.length);
658 }
659 
660 
661 static int
662 nxt_perl_psgi_result_head(PerlInterpreter *my_perl, SV *sv_head,
663     nxt_unit_request_info_t *req, uint16_t status)
664 {
665     AV         *array_head;
666     SV         **entry;
667     int        rc;
668     long       i, array_len;
669     char       *name, *value;
670     STRLEN     name_len, value_len;
671     uint32_t   fields, size;
672 
673     if (nxt_slow_path(SvROK(sv_head) == 0
674                       || SvTYPE(SvRV(sv_head)) != SVt_PVAV))
675     {
676         nxt_unit_req_error(req,
677                            "PSGI: An unsupported format was received from "
678                            "Perl Application for head part");
679 
680         return NXT_UNIT_ERROR;
681     }
682 
683     array_head = (AV *) SvRV(sv_head);
684     array_len = av_len(array_head);
685 
686     if (array_len < 1) {
687         return nxt_unit_response_init(req, status, 0, 0);
688     }
689 
690     if (nxt_slow_path((array_len % 2) == 0)) {
691         nxt_unit_req_error(req, "PSGI: Bad format for head from "
692                            "Perl Application");
693 
694         return NXT_UNIT_ERROR;
695     }
696 
697     fields = 0;
698     size = 0;
699 
700     for (i = 0; i <= array_len; i++) {
701         entry = av_fetch(array_head, i, 0);
702 
703         if (nxt_fast_path(entry == NULL)) {
704             nxt_unit_req_error(req, "PSGI: Failed to get head entry from "
705                                "Perl Application");
706 
707             return NXT_UNIT_ERROR;
708         }
709 
710         value = SvPV(*entry, value_len);
711         size += value_len;
712 
713         if ((i % 2) == 0) {
714             fields++;
715         }
716     }
717 
718     rc = nxt_unit_response_init(req, status, fields, size);
719     if (nxt_slow_path(rc != NXT_UNIT_OK)) {
720         return rc;
721     }
722 
723     for (i = 0; i <= array_len; i += 2) {
724         entry = av_fetch(array_head, i, 0);
725         name = SvPV(*entry, name_len);
726 
727         entry = av_fetch(array_head, i + 1, 0);
728         value = SvPV(*entry, value_len);
729 
730         rc = nxt_unit_response_add_field(req, name, name_len, value, value_len);
731         if (nxt_slow_path(rc != NXT_UNIT_OK)) {
732             return rc;
733         }
734     }
735 
736     return NXT_UNIT_OK;
737 }
738 
739 
740 static int
741 nxt_perl_psgi_result_body(PerlInterpreter *my_perl, SV *sv_body,
742     nxt_unit_request_info_t *req)
743 {
744     SV         **entry;
745     AV         *body_array;
746     int        rc;
747     long       i;
748     nxt_str_t  body;
749 
750     if (nxt_slow_path(SvROK(sv_body) == 0
751                       || SvTYPE(SvRV(sv_body)) != SVt_PVAV))
752     {
753         nxt_unit_req_error(req, "PSGI: An unsupported format was received from "
754                            "Perl Application for a body part");
755 
756         return NXT_UNIT_ERROR;
757     }
758 
759     body_array = (AV *) SvRV(sv_body);
760 
761     for (i = 0; i <= av_len(body_array); i++) {
762 
763         entry = av_fetch(body_array, i, 0);
764 
765         if (nxt_fast_path(entry == NULL)) {
766             nxt_unit_req_error(req, "PSGI: Failed to get body entry from "
767                                "Perl Application");
768 
769             return NXT_UNIT_ERROR;
770         }
771 
772         body.start = (u_char *) SvPV(*entry, body.length);
773 
774         if (body.length == 0) {
775             continue;
776         }
777 
778         rc = nxt_unit_response_write(req, body.start, body.length);
779 
780         if (nxt_slow_path(rc != NXT_UNIT_OK)) {
781             nxt_unit_req_error(req, "PSGI: Failed to write content from "
782                                "Perl Application");
783             return rc;
784         }
785     }
786 
787     return NXT_UNIT_OK;
788 }
789 
790 
791 static int
792 nxt_perl_psgi_result_body_ref(PerlInterpreter *my_perl, SV *sv_body,
793     nxt_unit_request_info_t *req)
794 {
795     SV          *data, *old_rs, *old_perl_rs;
796     int         rc;
797     size_t      len;
798     const char  *body;
799 
800     /*
801      * Servers should set the $/ special variable to the buffer size
802      * when reading content from $body using the getline method.
803      * This is done by setting $/ with a reference to an integer ($/ = \8192).
804      */
805 
806     old_rs = PL_rs;
807     old_perl_rs = get_sv("/", GV_ADD);
808 
809     PL_rs = sv_2mortal(newRV_noinc(newSViv(nxt_unit_buf_min())));
810 
811     sv_setsv(old_perl_rs, PL_rs);
812 
813     rc = NXT_UNIT_OK;
814 
815     for ( ;; ) {
816         data = nxt_perl_psgi_call_method(my_perl, sv_body, "getline", req);
817         if (nxt_slow_path(data == NULL)) {
818             rc = NXT_UNIT_ERROR;
819             break;
820         }
821 
822         body = SvPV(data, len);
823 
824         if (len == 0) {
825             SvREFCNT_dec(data);
826 
827             data = nxt_perl_psgi_call_method(my_perl, sv_body, "close", req);
828             if (nxt_fast_path(data != NULL)) {
829                 SvREFCNT_dec(data);
830             }
831 
832             break;
833         }
834 
835         rc = nxt_unit_response_write(req, body, len);
836 
837         SvREFCNT_dec(data);
838 
839         if (nxt_slow_path(rc != NXT_UNIT_OK)) {
840             nxt_unit_req_error(req, "PSGI: Failed to write content from "
841                                "Perl Application");
842             break;
843         }
844     };
845 
846     PL_rs =  old_rs;
847     sv_setsv(get_sv("/", GV_ADD), old_perl_rs);
848 
849     return rc;
850 }
851 
852 
853 typedef struct {
854     PerlInterpreter  *my_perl;
855     PerlIO           *fp;
856 } nxt_perl_psgi_io_ctx_t;
857 
858 
859 static int
860 nxt_perl_psgi_result_body_fh(PerlInterpreter *my_perl, SV *sv_body,
861     nxt_unit_request_info_t *req)
862 {
863     IO                      *io;
864     nxt_unit_read_info_t    read_info;
865     nxt_perl_psgi_io_ctx_t  io_ctx;
866 
867     io = GvIO(SvRV(sv_body));
868 
869     if (io == NULL) {
870         return NXT_UNIT_OK;
871     }
872 
873     io_ctx.my_perl = my_perl;
874     io_ctx.fp = IoIFP(io);
875 
876     read_info.read = nxt_perl_psgi_io_read;
877     read_info.eof = PerlIO_eof(io_ctx.fp);
878     read_info.buf_size = 8192;
879     read_info.data = &io_ctx;
880 
881     return nxt_unit_response_write_cb(req, &read_info);
882 }
883 
884 
885 static ssize_t
886 nxt_perl_psgi_io_read(nxt_unit_read_info_t *read_info, void *dst, size_t size)
887 {
888     ssize_t                 res;
889     nxt_perl_psgi_io_ctx_t  *ctx;
890 
891     ctx = read_info->data;
892 
893     dTHXa(ctx->my_perl);
894 
895     res = PerlIO_read(ctx->fp, dst, size);
896 
897     read_info->eof = PerlIO_eof(ctx->fp);
898 
899     return res;
900 }
901 
902 
903 static int
904 nxt_perl_psgi_result_array(PerlInterpreter *my_perl, SV *result,
905     nxt_unit_request_info_t *req)
906 {
907     AV         *array;
908     SV         **sv_temp;
909     int        rc;
910     long       array_len;
911     nxt_int_t  status;
912 
913     array = (AV *) SvRV(result);
914     array_len = av_len(array);
915 
916     if (nxt_slow_path(array_len < 0)) {
917         nxt_unit_req_error(req,
918                            "PSGI: Invalid result format from Perl Application");
919 
920         return NXT_UNIT_ERROR;
921     }
922 
923     status = nxt_perl_psgi_result_status(my_perl, result);
924 
925     if (nxt_slow_path(status < 0)) {
926         nxt_unit_req_error(req,
927                            "PSGI: An unexpected status was received "
928                            "from Perl Application");
929 
930         return NXT_UNIT_ERROR;
931     }
932 
933     if (array_len >= 1) {
934         sv_temp = av_fetch(array, 1, 0);
935 
936         if (nxt_slow_path(sv_temp == NULL)) {
937             nxt_unit_req_error(req, "PSGI: Failed to get head from "
938                                "Perl ARRAY variable");
939 
940             return NXT_UNIT_ERROR;
941         }
942 
943         rc = nxt_perl_psgi_result_head(my_perl, *sv_temp, req, status);
944         if (nxt_slow_path(rc != NXT_UNIT_OK)) {
945             return rc;
946         }
947 
948     } else {
949         return nxt_unit_response_init(req, status, 0, 0);
950     }
951 
952     if (nxt_fast_path(array_len < 2)) {
953         return NXT_UNIT_OK;
954     }
955 
956     sv_temp = av_fetch(array, 2, 0);
957 
958     if (nxt_slow_path(sv_temp == NULL || SvROK(*sv_temp) == FALSE)) {
959         nxt_unit_req_error(req,
960                            "PSGI: Failed to get body from "
961                            "Perl ARRAY variable");
962 
963         return NXT_UNIT_ERROR;
964     }
965 
966     if (SvTYPE(SvRV(*sv_temp)) == SVt_PVAV) {
967         return nxt_perl_psgi_result_body(my_perl, *sv_temp, req);
968     }
969 
970     if (SvTYPE(SvRV(*sv_temp)) == SVt_PVGV) {
971         return nxt_perl_psgi_result_body_fh(my_perl, *sv_temp, req);
972     }
973 
974     return nxt_perl_psgi_result_body_ref(my_perl, *sv_temp, req);
975 }
976 
977 
978 static nxt_int_t
979 nxt_perl_psgi_init(nxt_task_t *task, nxt_common_app_conf_t *conf)
980 {
981     int                     rc;
982     nxt_unit_ctx_t          *unit_ctx;
983     nxt_unit_init_t         perl_init;
984     PerlInterpreter         *my_perl;
985     nxt_perl_psgi_module_t  module;
986 
987     my_perl = nxt_perl_psgi_interpreter_init(task, conf->u.perl.script,
988                                              &module.app);
989 
990     if (nxt_slow_path(my_perl == NULL)) {
991         return NXT_ERROR;
992     }
993 
994     module.my_perl = my_perl;
995     nxt_perl_psgi = my_perl;
996 
997     nxt_unit_default_init(task, &perl_init);
998 
999     perl_init.callbacks.request_handler = nxt_perl_psgi_request_handler;
1000     perl_init.data = &module;
1001 
1002     unit_ctx = nxt_unit_init(&perl_init);
1003     if (nxt_slow_path(unit_ctx == NULL)) {
1004         return NXT_ERROR;
1005     }
1006 
1007     rc = nxt_unit_run(unit_ctx);
1008 
1009     nxt_unit_done(unit_ctx);
1010 
1011     nxt_perl_psgi_atexit();
1012 
1013     exit(rc);
1014 
1015     return NXT_OK;
1016 }
1017 
1018 
1019 static void
1020 nxt_perl_psgi_request_handler(nxt_unit_request_info_t *req)
1021 {
1022     SV                      *env, *result;
1023     nxt_int_t               rc;
1024     PerlInterpreter         *my_perl;
1025     nxt_perl_psgi_input_t   input;
1026     nxt_perl_psgi_module_t  *module;
1027 
1028     module = req->unit->data;
1029     my_perl = module->my_perl;
1030 
1031     input.my_perl = my_perl;
1032     input.req = req;
1033 
1034     /*
1035      * Create environ variable for perl sub "application".
1036      *  > sub application {
1037      *  >     my ($environ) = @_;
1038      */
1039     env = nxt_perl_psgi_env_create(my_perl, req, &input);
1040     if (nxt_slow_path(env == NULL)) {
1041         nxt_unit_req_error(req,
1042                            "PSGI: Failed to create 'env' for Perl Application");
1043         nxt_unit_request_done(req, NXT_UNIT_ERROR);
1044 
1045         return;
1046     }
1047 
1048     nxt_perl_psgi_arg_input.ctx = &input;
1049     nxt_perl_psgi_arg_error.ctx = &input;
1050 
1051     /* Call perl sub and get result as SV*. */
1052     result = nxt_perl_psgi_call_var_application(my_perl, env, module->app, req);
1053 
1054     /*
1055      * We expect ARRAY ref like a
1056      * ['200', ['Content-Type' => "text/plain"], ["body"]]
1057      */
1058     if (nxt_slow_path(SvOK(result) == 0 || SvROK(result) == 0
1059                       || SvTYPE(SvRV(result)) != SVt_PVAV))
1060     {
1061         nxt_unit_req_error(req, "PSGI: An unexpected response was received "
1062                            "from Perl Application");
1063 
1064         rc = NXT_UNIT_ERROR;
1065 
1066     } else {
1067         rc = nxt_perl_psgi_result_array(my_perl, result, req);
1068     }
1069 
1070     nxt_unit_request_done(req, rc);
1071 
1072     SvREFCNT_dec(result);
1073     SvREFCNT_dec(env);
1074 }
1075 
1076 
1077 static void
1078 nxt_perl_psgi_atexit(void)
1079 {
1080     dTHXa(nxt_perl_psgi);
1081 
1082     nxt_perl_psgi_layer_stream_io_destroy(aTHX_ nxt_perl_psgi_arg_input.io);
1083     nxt_perl_psgi_layer_stream_fp_destroy(aTHX_ nxt_perl_psgi_arg_input.fp);
1084 
1085     nxt_perl_psgi_layer_stream_io_destroy(aTHX_ nxt_perl_psgi_arg_error.io);
1086     nxt_perl_psgi_layer_stream_fp_destroy(aTHX_ nxt_perl_psgi_arg_error.fp);
1087 
1088     perl_destruct(nxt_perl_psgi);
1089     perl_free(nxt_perl_psgi);
1090     PERL_SYS_TERM();
1091 }
1092