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