xref: /unit/src/perl/nxt_perl_psgi.c (revision 510:4979fe09d9cd)
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_log_error(NXT_LOG_CRIT, task->log,
441                       "PSGI: Failed to allocate memory for Perl interpreter");
442         return NULL;
443     }
444 
445     run_module = NULL;
446 
447     perl_construct(my_perl);
448     PERL_SET_CONTEXT(my_perl);
449 
450     status = perl_parse(my_perl, nxt_perl_psgi_xs_init, 3, embedding, NULL);
451 
452     if (nxt_slow_path(status != 0)) {
453         nxt_log_error(NXT_LOG_CRIT, task->log,
454                       "PSGI: Failed to parse Perl Script");
455         goto fail;
456     }
457 
458     PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
459     PL_origalen = 1;
460 
461     status = perl_run(my_perl);
462 
463     if (nxt_slow_path(status != 0)) {
464         nxt_log_error(NXT_LOG_CRIT, task->log,
465                       "PSGI: Failed to run Perl");
466         goto fail;
467     }
468 
469     sv_setsv(get_sv("0", 0), newSVpv(script, 0));
470 
471     run_module = nxt_perl_psgi_module_create(task, script);
472 
473     if (nxt_slow_path(run_module == NULL)) {
474         goto fail;
475     }
476 
477     status = nxt_perl_psgi_io_input_init(my_perl, &nxt_perl_psgi_arg_input);
478 
479     if (nxt_slow_path(status != NXT_OK)) {
480         nxt_log_error(NXT_LOG_CRIT, task->log,
481                       "PSGI: Failed to init io.psgi.input");
482         goto fail;
483     }
484 
485     status = nxt_perl_psgi_io_error_init(my_perl, &nxt_perl_psgi_arg_error);
486 
487     if (nxt_slow_path(status != NXT_OK)) {
488         nxt_log_error(NXT_LOG_CRIT, task->log,
489                       "PSGI: Failed to init io.psgi.errors");
490         goto fail;
491     }
492 
493     nxt_perl_psgi_app = eval_pv((const char *) run_module, FALSE);
494 
495     if (SvTRUE(ERRSV)) {
496         nxt_log_emerg(task->log, "PSGI: Failed to parse script: %s\n%s",
497                       script, SvPV_nolen(ERRSV));
498         goto fail;
499     }
500 
501     nxt_free(run_module);
502 
503     return my_perl;
504 
505 fail:
506 
507     if (run_module != NULL) {
508         nxt_free(run_module);
509     }
510 
511     perl_destruct(my_perl);
512     perl_free(my_perl);
513     PERL_SYS_TERM();
514 
515     return NULL;
516 }
517 
518 
519 nxt_inline nxt_int_t
520 nxt_perl_psgi_env_append_str(PerlInterpreter *my_perl, HV *hash_env,
521     const char *name, nxt_str_t *str)
522 {
523     SV  **ha;
524 
525     ha = hv_store(hash_env, name, (I32) strlen(name),
526                   newSVpv((const char *) str->start, (STRLEN)str->length), 0);
527 
528     if (nxt_slow_path(ha == NULL)) {
529         return NXT_ERROR;
530     }
531 
532     return NXT_OK;
533 }
534 
535 
536 nxt_inline nxt_int_t
537 nxt_perl_psgi_env_append(PerlInterpreter *my_perl, HV *hash_env,
538     const char *name, void *value)
539 {
540     SV  **ha;
541 
542     ha = hv_store(hash_env, name, (I32) strlen(name), value, 0);
543 
544     if (nxt_slow_path(ha == NULL)) {
545         return NXT_ERROR;
546     }
547 
548     return NXT_OK;
549 }
550 
551 
552 nxt_inline nxt_int_t
553 nxt_perl_psgi_read_add_env(PerlInterpreter *my_perl, nxt_task_t *task,
554     nxt_app_rmsg_t *rmsg, HV *hash_env,
555     const char *name, nxt_str_t *str)
556 {
557     nxt_int_t  rc;
558 
559     rc = nxt_app_msg_read_str(task, rmsg, str);
560 
561     if (nxt_slow_path(rc != NXT_OK)) {
562         return rc;
563     }
564 
565     if (str->start == NULL) {
566         return NXT_OK;
567     }
568 
569     return nxt_perl_psgi_env_append_str(my_perl, hash_env, name, str);
570 }
571 
572 
573 static SV *
574 nxt_perl_psgi_env_create(PerlInterpreter *my_perl, nxt_task_t *task,
575     nxt_app_rmsg_t *rmsg, size_t *body_preread_size)
576 {
577     HV         *hash_env;
578     AV         *array_version;
579     u_char     *colon;
580     size_t     query_size;
581     nxt_int_t  rc;
582     nxt_str_t  str, value, path, target;
583     nxt_str_t  host, server_name, server_port;
584 
585     static nxt_str_t  def_host = nxt_string("localhost");
586     static nxt_str_t  def_port = nxt_string("80");
587 
588     hash_env = newHV();
589 
590     if (nxt_slow_path(hash_env == NULL)) {
591         return NULL;
592     }
593 
594 #define RC(FNS)                                                  \
595     do {                                                         \
596         if (nxt_slow_path((FNS) != NXT_OK))                      \
597             goto fail;                                           \
598     } while (0)
599 
600 #define GET_STR(ATTR)                                            \
601     RC(nxt_perl_psgi_read_add_env(my_perl, task, rmsg,           \
602         hash_env, ATTR, &str))
603 
604     GET_STR("REQUEST_METHOD");
605     GET_STR("REQUEST_URI");
606 
607     target = str;
608 
609     RC(nxt_app_msg_read_str(task, rmsg, &path));
610     RC(nxt_app_msg_read_size(task, rmsg, &query_size));
611 
612     if (path.start == NULL || path.length == 0) {
613         path = target;
614     }
615 
616     array_version = newAV();
617 
618     if (nxt_slow_path(array_version == NULL)) {
619         goto fail;
620     }
621 
622     av_push(array_version, newSViv(1));
623     av_push(array_version, newSViv(1));
624 
625     RC(nxt_perl_psgi_env_append_str(my_perl, hash_env, "PATH_INFO",
626                                     &path));
627     RC(nxt_perl_psgi_env_append(my_perl, hash_env, "SCRIPT_NAME",
628                                 newSVpv("", 0)));
629     RC(nxt_perl_psgi_env_append(my_perl, hash_env, "psgi.run_once",
630                                 newSVpv("", 0)));
631     RC(nxt_perl_psgi_env_append(my_perl, hash_env, "psgi.streaming",
632                                 newSViv(0)));
633     RC(nxt_perl_psgi_env_append(my_perl, hash_env, "psgi.nonblocking",
634                                 newSVpv("", 0)));
635     RC(nxt_perl_psgi_env_append(my_perl, hash_env, "psgi.multithread",
636                                 newSVpv("", 0)));
637     RC(nxt_perl_psgi_env_append(my_perl, hash_env, "psgi.multiprocess",
638                                 newSVpv("", 0)));
639     RC(nxt_perl_psgi_env_append(my_perl, hash_env, "psgi.url_scheme",
640                                 newSVpv("http", 4)));
641     RC(nxt_perl_psgi_env_append(my_perl, hash_env, "psgi.input",
642                                 SvREFCNT_inc(nxt_perl_psgi_arg_input.io)));
643     RC(nxt_perl_psgi_env_append(my_perl, hash_env, "psgi.errors",
644                                 SvREFCNT_inc(nxt_perl_psgi_arg_error.io)));
645     RC(nxt_perl_psgi_env_append(my_perl, hash_env, "psgi.version",
646                                 newRV_noinc((SV *) array_version)));
647 
648     if (query_size > 0) {
649         query_size--;
650 
651         if (nxt_slow_path(target.length < query_size)) {
652             goto fail;
653         }
654 
655         str.start = &target.start[query_size];
656         str.length = target.length - query_size;
657 
658         RC(nxt_perl_psgi_env_append_str(my_perl, hash_env,
659                                         "QUERY_STRING", &str));
660     }
661 
662     GET_STR("SERVER_PROTOCOL");
663     GET_STR("REMOTE_ADDR");
664     GET_STR("SERVER_ADDR");
665 
666     RC(nxt_app_msg_read_str(task, rmsg, &host));
667 
668     if (host.length == 0) {
669         host = def_host;
670     }
671 
672     colon = nxt_memchr(host.start, ':', host.length);
673     server_name = host;
674 
675     if (colon != NULL) {
676         server_name.length = colon - host.start;
677 
678         server_port.start = colon + 1;
679         server_port.length = host.length - server_name.length - 1;
680 
681     } else {
682         server_port = def_port;
683     }
684 
685     RC(nxt_perl_psgi_env_append_str(my_perl, hash_env,
686                                     "SERVER_NAME", &server_name));
687     RC(nxt_perl_psgi_env_append_str(my_perl, hash_env,
688                                     "SERVER_PORT", &server_port));
689 
690     GET_STR("CONTENT_TYPE");
691     GET_STR("CONTENT_LENGTH");
692 
693     for ( ;; ) {
694         rc = nxt_app_msg_read_str(task, rmsg, &str);
695 
696         if (nxt_slow_path(rc != NXT_OK)) {
697             goto fail;
698         }
699 
700         if (nxt_slow_path(str.length == 0)) {
701             break;
702         }
703 
704         rc = nxt_app_msg_read_str(task, rmsg, &value);
705 
706         if (nxt_slow_path(rc != NXT_OK)) {
707             break;
708         }
709 
710         RC(nxt_perl_psgi_env_append_str(my_perl, hash_env,
711                                         (char *) str.start, &value));
712     }
713 
714     RC(nxt_app_msg_read_size(task, rmsg, body_preread_size));
715 
716 #undef GET_STR
717 #undef RC
718 
719     return newRV_noinc((SV *) hash_env);
720 
721 fail:
722 
723     SvREFCNT_dec(hash_env);
724 
725     return NULL;
726 }
727 
728 
729 static nxt_str_t
730 nxt_perl_psgi_result_status(PerlInterpreter *my_perl, SV *result)
731 {
732     SV         **sv_status;
733     AV         *array;
734     nxt_str_t  status;
735 
736     array = (AV *) SvRV(result);
737     sv_status = av_fetch(array, 0, 0);
738 
739     status.start = (u_char *) SvPV(*sv_status, status.length);
740 
741     return status;
742 }
743 
744 
745 static nxt_int_t
746 nxt_perl_psgi_result_head(PerlInterpreter *my_perl, SV *sv_head,
747     nxt_task_t *task, nxt_app_wmsg_t *wmsg)
748 {
749     AV         *array_head;
750     SV         **entry;
751     long       i, array_len;
752     nxt_int_t  rc;
753     nxt_str_t  body;
754 
755     if (nxt_slow_path(SvROK(sv_head) == 0
756                       || SvTYPE(SvRV(sv_head)) != SVt_PVAV))
757     {
758         nxt_log_error(NXT_LOG_ERR, task->log,
759                       "PSGI: An unsupported format was received from "
760                       "Perl Application for head part");
761 
762         return NXT_ERROR;
763     }
764 
765     array_head = (AV *) SvRV(sv_head);
766     array_len = av_len(array_head);
767 
768     if (array_len < 1) {
769         return NXT_OK;
770     }
771 
772     if (nxt_slow_path((array_len % 2) == 0)) {
773         nxt_log_error(NXT_LOG_ERR, task->log,
774                       "PSGI: Bad format for head from "
775                       "Perl Application");
776 
777         return NXT_ERROR;
778     }
779 
780     for (i = 0; i <= array_len; i++) {
781         entry = av_fetch(array_head, i, 0);
782 
783         if (nxt_fast_path(entry == NULL)) {
784             nxt_log_error(NXT_LOG_ERR, task->log,
785                           "PSGI: Failed to get head entry from "
786                           "Perl Application");
787 
788             return NXT_ERROR;
789         }
790 
791         body.start = (u_char *) SvPV(*entry, body.length);
792 
793         rc = nxt_app_msg_write_raw(task, wmsg,
794                                    (u_char *) body.start, body.length);
795 
796         if (nxt_slow_path(rc != NXT_OK)) {
797             nxt_log_error(NXT_LOG_ERR, task->log,
798                           "PSGI: Failed to write head "
799                           "from Perl Application");
800             return rc;
801         }
802 
803         if ((i % 2) == 0) {
804             rc = nxt_app_msg_write_raw(task, wmsg,
805                                        (u_char *) ": ",
806                                        (sizeof(": ") - 1));
807         } else {
808             rc = nxt_app_msg_write_raw(task, wmsg,
809                                        (u_char *) "\r\n",
810                                        (sizeof("\r\n") - 1));
811         }
812 
813         if (nxt_slow_path(rc != NXT_OK)) {
814             nxt_log_error(NXT_LOG_ERR, task->log,
815                           "PSGI: Failed to write head from "
816                           "Perl Application");
817             return rc;
818         }
819     }
820 
821     return NXT_OK;
822 }
823 
824 
825 static nxt_int_t
826 nxt_perl_psgi_result_body(PerlInterpreter *my_perl, SV *sv_body,
827     nxt_task_t *task, nxt_app_wmsg_t *wmsg)
828 {
829     SV         **entry;
830     AV         *body_array;
831     long       i;
832     nxt_int_t  rc;
833     nxt_str_t  body;
834 
835     if (nxt_slow_path(SvROK(sv_body) == 0
836                       || SvTYPE(SvRV(sv_body)) != SVt_PVAV))
837     {
838         nxt_log_error(NXT_LOG_ERR, task->log,
839                       "PSGI: An unsupported format was received from "
840                       "Perl Application for a body part");
841 
842         return NXT_ERROR;
843     }
844 
845     body_array = (AV *) SvRV(sv_body);
846 
847     for (i = 0; i <= av_len(body_array); i++) {
848 
849         entry = av_fetch(body_array, i, 0);
850 
851         if (nxt_fast_path(entry == NULL)) {
852             nxt_log_error(NXT_LOG_ERR, task->log,
853                           "PSGI: Failed to get body entry from "
854                           "Perl Application");
855             return NXT_ERROR;
856         }
857 
858         body.start = (u_char *) SvPV(*entry, body.length);
859 
860         if (body.length == 0) {
861             continue;
862         }
863 
864         rc = nxt_app_msg_write_raw(task, wmsg,
865                                    (u_char *) body.start, body.length);
866 
867         if (nxt_slow_path(rc != NXT_OK)) {
868             nxt_log_error(NXT_LOG_ERR, task->log,
869                           "PSGI: Failed to write 'body' from "
870                           "Perl Application");
871             return rc;
872         }
873 
874         rc = nxt_app_msg_flush(task, wmsg, 0);
875 
876         if (nxt_slow_path(rc != NXT_OK)) {
877             nxt_log_error(NXT_LOG_ERR, task->log,
878                           "PSGI: Failed to flush data for a 'body' "
879                           "part from Perl Application");
880             return rc;
881         }
882     }
883 
884     return NXT_OK;
885 }
886 
887 
888 static nxt_int_t
889 nxt_perl_psgi_result_body_ref(PerlInterpreter *my_perl, SV *sv_body,
890     nxt_task_t *task, nxt_app_wmsg_t *wmsg)
891 {
892     IO         *io;
893     PerlIO     *fp;
894     SSize_t    n;
895     nxt_int_t  rc;
896     u_char     vbuf[8192];
897 
898     io = GvIO(SvRV(sv_body));
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)) {
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