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