Added Perl support.

1 files changed, 1148 insertions, 0 deletions

diff --git a/src/perl/nxt_perl_psgi.c b/src/perl/nxt_perl_psgi.c
new file mode 100644
index 00000000..21cd0b8a
--- /dev/null
+++ b/src/perl/nxt_perl_psgi.c
@@ -0,0 +1,1148 @@
+
+/*
+ * Copyright (C) Alexander Borisov
+ * Copyright (C) NGINX, Inc.
+ */
+
+#include <perl/nxt_perl_psgi_layer.h>
+
+#include <nxt_main.h>
+#include <nxt_router.h>
+#include <nxt_runtime.h>
+#include <nxt_application.h>
+#include <nxt_file.h>
+
+
+typedef struct {
+    PerlInterpreter  *my_perl;
+
+    nxt_task_t       *task;
+    nxt_app_rmsg_t   *rmsg;
+    nxt_app_wmsg_t   *wmsg;
+
+    size_t           body_preread_size;
+} nxt_perl_psgi_input_t;
+
+
+nxt_inline nxt_int_t nxt_perl_psgi_write(nxt_task_t *task,nxt_app_wmsg_t *wmsg,
+    const u_char *data, size_t len,
+    nxt_bool_t flush, nxt_bool_t last);
+
+nxt_inline nxt_int_t nxt_perl_psgi_http_write_status_str(nxt_task_t *task,
+    nxt_app_wmsg_t *wmsg, nxt_str_t *http_status);
+
+static long nxt_perl_psgi_io_input_read(PerlInterpreter *my_perl,
+    nxt_perl_psgi_io_arg_t *arg, void *vbuf, size_t length);
+static long nxt_perl_psgi_io_input_write(PerlInterpreter *my_perl,
+    nxt_perl_psgi_io_arg_t *arg, const void *vbuf, size_t length);
+static long nxt_perl_psgi_io_input_flush(PerlInterpreter *my_perl,
+    nxt_perl_psgi_io_arg_t *arg);
+
+static long nxt_perl_psgi_io_error_read(PerlInterpreter *my_perl,
+    nxt_perl_psgi_io_arg_t *arg, void *vbuf, size_t length);
+static long nxt_perl_psgi_io_error_write(PerlInterpreter *my_perl,
+    nxt_perl_psgi_io_arg_t *arg, const void *vbuf, size_t length);
+static long nxt_perl_psgi_io_error_flush(PerlInterpreter *my_perl,
+    nxt_perl_psgi_io_arg_t *arg);
+
+/*
+static void nxt_perl_psgi_xs_core_global_changes(PerlInterpreter *my_perl,
+    const char *core, const char *sub, XSUBADDR_t sub_addr);
+*/
+
+static void nxt_perl_psgi_xs_init(pTHX);
+
+static SV *nxt_perl_psgi_call_var_application(PerlInterpreter *my_perl,
+    SV *env, nxt_task_t *task);
+
+/* For currect load XS modules */
+EXTERN_C void boot_DynaLoader(pTHX_ CV *cv);
+
+static nxt_int_t nxt_perl_psgi_io_input_init(PerlInterpreter *my_perl,
+    nxt_perl_psgi_io_arg_t *arg);
+static nxt_int_t nxt_perl_psgi_io_error_init(PerlInterpreter *my_perl,
+    nxt_perl_psgi_io_arg_t *arg);
+
+static PerlInterpreter *nxt_perl_psgi_interpreter_init(nxt_task_t *task,
+    char *script);
+
+nxt_inline nxt_int_t nxt_perl_psgi_env_append_str(PerlInterpreter *my_perl,
+    HV *hash_env, const char *name, nxt_str_t *str);
+nxt_inline nxt_int_t nxt_perl_psgi_env_append(PerlInterpreter *my_perl,
+    HV *hash_env, const char *name, void *value);
+
+static SV *nxt_perl_psgi_env_create(PerlInterpreter *my_perl, nxt_task_t *task,
+    nxt_app_rmsg_t *rmsg, size_t *body_preread_size);
+
+nxt_inline nxt_int_t nxt_perl_psgi_read_add_env(PerlInterpreter *my_perl,
+    nxt_task_t *task, nxt_app_rmsg_t *rmsg, HV *hash_env,
+    const char *name, nxt_str_t *str);
+
+static u_char *nxt_perl_psgi_module_create(nxt_task_t *task,
+    const char *script);
+
+static nxt_str_t nxt_perl_psgi_result_status(PerlInterpreter *my_perl,
+    SV *result);
+static nxt_int_t nxt_perl_psgi_result_head(PerlInterpreter *my_perl,
+    SV *sv_head, nxt_task_t *task, nxt_app_wmsg_t *wmsg);
+static nxt_int_t nxt_perl_psgi_result_body(PerlInterpreter *my_perl,
+    SV *result, nxt_task_t *task, nxt_app_wmsg_t *wmsg);
+static nxt_int_t nxt_perl_psgi_result_body_ref(PerlInterpreter *my_perl,
+    SV *sv_body, nxt_task_t *task, nxt_app_wmsg_t *wmsg);
+static nxt_int_t nxt_perl_psgi_result_array(PerlInterpreter *my_perl,
+    SV *result, nxt_task_t *task, nxt_app_wmsg_t *wmsg);
+
+static nxt_int_t nxt_perl_psgi_init(nxt_task_t *task,
+    nxt_common_app_conf_t *conf);
+static nxt_int_t nxt_perl_psgi_run(nxt_task_t *task,
+    nxt_app_rmsg_t *rmsg, nxt_app_wmsg_t *wmsg);
+static void nxt_perl_psgi_atexit(nxt_task_t *task);
+
+typedef SV *(*nxt_perl_psgi_callback_f)(PerlInterpreter *my_perl,
+    SV *env, nxt_task_t *task);
+
+static SV                      *nxt_perl_psgi_app;
+static PerlInterpreter         *nxt_perl_psgi;
+static nxt_perl_psgi_io_arg_t  nxt_perl_psgi_arg_input, nxt_perl_psgi_arg_error;
+
+static uint32_t  nxt_perl_psgi_compat[] = {
+    NXT_VERNUM, NXT_DEBUG,
+};
+
+NXT_EXPORT nxt_application_module_t  nxt_app_module = {
+    sizeof(nxt_perl_psgi_compat),
+    nxt_perl_psgi_compat,
+    nxt_string("perl"),
+    nxt_string(PERL_VERSION_STRING),
+    nxt_perl_psgi_init,
+    nxt_perl_psgi_run,
+    nxt_perl_psgi_atexit,
+};
+
+
+nxt_inline nxt_int_t
+nxt_perl_psgi_write(nxt_task_t *task, nxt_app_wmsg_t *wmsg,
+    const u_char *data, size_t len,
+    nxt_bool_t flush, nxt_bool_t last)
+{
+    nxt_int_t  rc;
+
+    rc = nxt_app_msg_write_raw(task, wmsg, data, len);
+
+    if (nxt_slow_path(rc != NXT_OK)) {
+        return rc;
+    }
+
+    if (flush || last) {
+        rc = nxt_app_msg_flush(task, wmsg, last);
+    }
+
+    return rc;
+}
+
+
+nxt_inline nxt_int_t
+nxt_perl_psgi_http_write_status_str(nxt_task_t *task, nxt_app_wmsg_t *wmsg,
+    nxt_str_t *http_status)
+{
+    nxt_int_t  rc;
+
+    rc = NXT_OK;
+
+#define RC_WRT(DATA, DATALEN, FLUSH)                       \
+    do {                                                   \
+        rc = nxt_perl_psgi_write(task, wmsg, DATA,         \
+                    DATALEN, FLUSH, 0);                    \
+        if (nxt_slow_path(rc != NXT_OK))                   \
+            return rc;                                     \
+                                                           \
+    } while (0)
+
+    RC_WRT((const u_char *) "Status: ", (sizeof("Status: ") - 1), 0);
+    RC_WRT(http_status->start, http_status->length, 0);
+    RC_WRT((u_char *) "\r\n", (sizeof("\r\n") - 1), 0);
+
+#undef RC_WRT
+
+    return rc;
+}
+
+
+static long
+nxt_perl_psgi_io_input_read(PerlInterpreter *my_perl,
+    nxt_perl_psgi_io_arg_t *arg, void *vbuf, size_t length)
+{
+    size_t                 copy_size;
+    nxt_perl_psgi_input_t  *input;
+
+    input = (nxt_perl_psgi_input_t *) arg->ctx;
+
+    if (input->body_preread_size == 0) {
+        return 0;
+    }
+
+    copy_size = nxt_min(length, input->body_preread_size);
+    copy_size = nxt_app_msg_read_raw(input->task, input->rmsg,
+                                     vbuf, copy_size);
+
+    input->body_preread_size -= copy_size;
+
+    return copy_size;
+}
+
+
+static long
+nxt_perl_psgi_io_input_write(PerlInterpreter *my_perl,
+    nxt_perl_psgi_io_arg_t *arg, const void *vbuf, size_t length)
+{
+    return 0;
+}
+
+
+static long
+nxt_perl_psgi_io_input_flush(PerlInterpreter *my_perl,
+    nxt_perl_psgi_io_arg_t *arg)
+{
+    return 0;
+}
+
+
+static long
+nxt_perl_psgi_io_error_read(PerlInterpreter *my_perl,
+    nxt_perl_psgi_io_arg_t *arg, void *vbuf, size_t length)
+{
+    return 0;
+}
+
+
+static long
+nxt_perl_psgi_io_error_write(PerlInterpreter *my_perl,
+    nxt_perl_psgi_io_arg_t *arg, const void *vbuf, size_t length)
+{
+    nxt_perl_psgi_input_t *input;
+
+    input = (nxt_perl_psgi_input_t *) arg->ctx;
+    nxt_log_error(NXT_LOG_ERR, input->task->log, "Perl: %s", vbuf);
+
+    return (long) length;
+}
+
+
+static long
+nxt_perl_psgi_io_error_flush(PerlInterpreter *my_perl,
+    nxt_perl_psgi_io_arg_t *arg)
+{
+    return 0;
+}
+
+
+/* In the future it will be necessary to change some Perl functions. */
+/*
+static void
+nxt_perl_psgi_xs_core_global_changes(PerlInterpreter *my_perl,
+    const char *core, const char *sub, XSUBADDR_t sub_addr)
+{
+    GV  *gv;
+
+    gv = gv_fetchpv(core, TRUE, SVt_PVCV);
+
+#ifdef MUTABLE_CV
+    GvCV_set(gv, MUTABLE_CV(SvREFCNT_inc(get_cv(sub, TRUE))));
+#else
+    GvCV_set(gv, (CV *) (SvREFCNT_inc(get_cv(sub, TRUE))));
+#endif
+    GvIMPORTED_CV_on(gv);
+
+    newXS(sub, sub_addr, __FILE__);
+}
+*/
+
+
+XS(XS_NGINX__Unit__PSGI_exit);
+XS(XS_NGINX__Unit__PSGI_exit)
+{
+    I32 ax = POPMARK;
+    Perl_croak(aTHX_ (char *) NULL);
+    XSRETURN_EMPTY;
+}
+
+
+static void
+nxt_perl_psgi_xs_init(pTHX)
+{
+/*
+    nxt_perl_psgi_xs_core_global_changes(my_perl, "CORE::GLOBAL::exit",
+                                         "NGINX::Unit::PSGI::exit",
+                                         XS_NGINX__Unit__PSGI_exit);
+*/
+    nxt_perl_psgi_layer_stream_init(aTHX);
+
+    /* DynaLoader for Perl modules who use XS */
+    newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, __FILE__);
+}
+
+
+static SV *
+nxt_perl_psgi_call_var_application(PerlInterpreter *my_perl,
+    SV *env, nxt_task_t *task)
+{
+    SV  *result;
+
+    dSP;
+
+    ENTER;
+    SAVETMPS;
+
+    PUSHMARK(sp);
+    XPUSHs(env);
+    PUTBACK;
+
+    call_sv(nxt_perl_psgi_app, G_EVAL|G_SCALAR);
+
+    SPAGAIN;
+
+    if (SvTRUE(ERRSV)) {
+        nxt_log_error(NXT_LOG_ERR, task->log,
+                      "PSGI: Failed to run Perl Application: \n%s",
+                      SvPV_nolen(ERRSV));
+    }
+
+    result = POPs;
+    SvREFCNT_inc(result);
+
+    PUTBACK;
+    FREETMPS;
+    LEAVE;
+
+    return result;
+}
+
+
+static u_char *
+nxt_perl_psgi_module_create(nxt_task_t *task, const char *script)
+{
+    u_char  *buf, *p;
+    size_t  length;
+
+    static nxt_str_t  prefix = nxt_string(
+        "package NGINX::Unit::Sandbox;"
+        "{my $app = do \""
+    );
+
+    static nxt_str_t  suffix = nxt_string_zero(
+        "\";"
+        "unless ($app) {"
+        "    if($@ || $1) {die $@ || $1}"
+        "    else {die \"File not found or compilation error.\"}"
+        "} "
+        "return $app}"
+    );
+
+    length = strlen(script);
+
+    buf = nxt_malloc(prefix.length + length + suffix.length);
+
+    if (nxt_slow_path(buf == NULL)) {
+        nxt_log_error(NXT_LOG_ERR, task->log,
+                      "PSGI: Failed to allocate memory "
+                      "for Perl script file %s", script);
+        return NULL;
+    }
+
+    p = nxt_cpymem(buf, prefix.start, prefix.length);
+    p = nxt_cpymem(p, script, length);
+    nxt_memcpy(p, suffix.start, suffix.length);
+
+    return buf;
+}
+
+
+static nxt_int_t
+nxt_perl_psgi_io_input_init(PerlInterpreter *my_perl,
+    nxt_perl_psgi_io_arg_t *arg)
+{
+    SV      *io;
+    PerlIO  *fp;
+
+    fp = nxt_perl_psgi_layer_stream_fp_create(aTHX_ arg, "r");
+
+    if (nxt_slow_path(fp == NULL)) {
+        return NXT_ERROR;
+    }
+
+    io = nxt_perl_psgi_layer_stream_io_create(aTHX_ fp);
+
+    if (nxt_slow_path(io == NULL)) {
+        nxt_perl_psgi_layer_stream_fp_destroy(aTHX_ fp);
+        return NXT_ERROR;
+    }
+
+    arg->io = io;
+    arg->fp = fp;
+    arg->flush = nxt_perl_psgi_io_input_flush;
+    arg->read = nxt_perl_psgi_io_input_read;
+    arg->write = nxt_perl_psgi_io_input_write;
+
+    return NXT_OK;
+}
+
+
+static nxt_int_t
+nxt_perl_psgi_io_error_init(PerlInterpreter *my_perl,
+    nxt_perl_psgi_io_arg_t *arg)
+{
+    SV      *io;
+    PerlIO  *fp;
+
+    fp = nxt_perl_psgi_layer_stream_fp_create(aTHX_ arg, "w");
+
+    if (nxt_slow_path(fp == NULL)) {
+        return NXT_ERROR;
+    }
+
+    io = nxt_perl_psgi_layer_stream_io_create(aTHX_ fp);
+
+    if (nxt_slow_path(io == NULL)) {
+        nxt_perl_psgi_layer_stream_fp_destroy(aTHX_ fp);
+        return NXT_ERROR;
+    }
+
+    arg->io = io;
+    arg->fp = fp;
+    arg->flush = nxt_perl_psgi_io_error_flush;
+    arg->read = nxt_perl_psgi_io_error_read;
+    arg->write = nxt_perl_psgi_io_error_write;
+
+    return NXT_OK;
+}
+
+
+static PerlInterpreter *
+nxt_perl_psgi_interpreter_init(nxt_task_t *task, char *script)
+{
+    int              status, pargc;
+    char             **pargv, **penv;
+    u_char           *run_module;
+    PerlInterpreter  *my_perl;
+
+    static char  argv[] = "\0""-e\0""0";
+    static char  *embedding[] = { &argv[0], &argv[1], &argv[4] };
+
+    pargc = 0;
+    pargv = NULL;
+    penv = NULL;
+
+    PERL_SYS_INIT3(&pargc, &pargv, &penv);
+
+    my_perl = perl_alloc();
+
+    if (nxt_slow_path(my_perl == NULL)) {
+        nxt_log_error(NXT_LOG_CRIT, task->log,
+                      "PSGI: Failed to allocate memory for Perl interpreter");
+        return NULL;
+    }
+
+    run_module = NULL;
+
+    perl_construct(my_perl);
+    PERL_SET_CONTEXT(my_perl);
+
+    status = perl_parse(my_perl, nxt_perl_psgi_xs_init, 3, embedding, NULL);
+
+    if (nxt_slow_path(status != 0)) {
+        nxt_log_error(NXT_LOG_CRIT, task->log,
+                      "PSGI: Failed to parse Perl Script");
+        goto fail;
+    }
+
+    PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
+    PL_origalen = 1;
+
+    status = perl_run(my_perl);
+
+    if (nxt_slow_path(status != 0)) {
+        nxt_log_error(NXT_LOG_CRIT, task->log,
+                      "PSGI: Failed to run Perl");
+        goto fail;
+    }
+
+    sv_setsv(get_sv("0", 0), newSVpv(script, 0));
+
+    run_module = nxt_perl_psgi_module_create(task, script);
+
+    if (nxt_slow_path(run_module == NULL)) {
+        goto fail;
+    }
+
+    status = nxt_perl_psgi_io_input_init(my_perl, &nxt_perl_psgi_arg_input);
+
+    if (nxt_slow_path(status != NXT_OK)) {
+        nxt_log_error(NXT_LOG_CRIT, task->log,
+                      "PSGI: Failed to init io.psgi.input");
+        goto fail;
+    }
+
+    status = nxt_perl_psgi_io_error_init(my_perl, &nxt_perl_psgi_arg_error);
+
+    if (nxt_slow_path(status != NXT_OK)) {
+        nxt_log_error(NXT_LOG_CRIT, task->log,
+                      "PSGI: Failed to init io.psgi.errors");
+        goto fail;
+    }
+
+    nxt_perl_psgi_app = eval_pv((const char *) run_module, FALSE);
+
+    if (SvTRUE(ERRSV)) {
+        nxt_log_emerg(task->log, "PSGI: Failed to parse script: %s\n%s",
+                      script, SvPV_nolen(ERRSV));
+        goto fail;
+    }
+
+    nxt_free(run_module);
+
+    return my_perl;
+
+fail:
+
+    if (run_module != NULL) {
+        nxt_free(run_module);
+    }
+
+    perl_destruct(my_perl);
+    perl_free(my_perl);
+    PERL_SYS_TERM();
+
+    return NULL;
+}
+
+
+nxt_inline nxt_int_t
+nxt_perl_psgi_env_append_str(PerlInterpreter *my_perl, HV *hash_env,
+    const char *name, nxt_str_t *str)
+{
+    SV  **ha;
+
+    ha = hv_store(hash_env, name, (I32) strlen(name),
+                  newSVpv((const char *) str->start, (STRLEN)str->length), 0);
+
+    if (nxt_slow_path(ha == NULL)) {
+        return NXT_ERROR;
+    }
+
+    return NXT_OK;
+}
+
+
+nxt_inline nxt_int_t
+nxt_perl_psgi_env_append(PerlInterpreter *my_perl, HV *hash_env,
+    const char *name, void *value)
+{
+    SV  **ha;
+
+    ha = hv_store(hash_env, name, (I32) strlen(name), value, 0);
+
+    if (nxt_slow_path(ha == NULL)) {
+        return NXT_ERROR;
+    }
+
+    return NXT_OK;
+}
+
+
+nxt_inline nxt_int_t
+nxt_perl_psgi_read_add_env(PerlInterpreter *my_perl, nxt_task_t *task,
+    nxt_app_rmsg_t *rmsg, HV *hash_env,
+    const char *name, nxt_str_t *str)
+{
+    nxt_int_t  rc;
+
+    rc = nxt_app_msg_read_str(task, rmsg, str);
+
+    if (nxt_slow_path(rc != NXT_OK)) {
+        return rc;
+    }
+
+    if (str->start == NULL) {
+        return NXT_OK;
+    }
+
+    return nxt_perl_psgi_env_append_str(my_perl, hash_env, name, str);
+}
+
+
+static SV *
+nxt_perl_psgi_env_create(PerlInterpreter *my_perl, nxt_task_t *task,
+    nxt_app_rmsg_t *rmsg, size_t *body_preread_size)
+{
+    HV         *hash_env;
+    AV         *array_version;
+    u_char     *colon;
+    size_t     query_size;
+    nxt_int_t  rc;
+    nxt_str_t  str, value, path, target;
+    nxt_str_t  host, server_name, server_port;
+
+    static nxt_str_t  def_host = nxt_string("localhost");
+    static nxt_str_t  def_port = nxt_string("80");
+
+    hash_env = newHV();
+
+    if (nxt_slow_path(hash_env == NULL)) {
+        return NULL;
+    }
+
+#define RC(FNS)                                                  \
+    do {                                                         \
+        if (nxt_slow_path((FNS) != NXT_OK))                      \
+            goto fail;                                           \
+    } while (0)
+
+#define GET_STR(ATTR)                                            \
+    RC(nxt_perl_psgi_read_add_env(my_perl, task, rmsg,           \
+        hash_env, ATTR, &str))
+
+    GET_STR("REQUEST_METHOD");
+    GET_STR("REQUEST_URI");
+
+    target = str;
+
+    RC(nxt_app_msg_read_str(task, rmsg, &path));
+    RC(nxt_app_msg_read_size(task, rmsg, &query_size));
+
+    if (path.start == NULL || path.length == 0) {
+        path = target;
+    }
+
+    array_version = newAV();
+
+    if (nxt_slow_path(array_version == NULL)) {
+        goto fail;
+    }
+
+    av_push(array_version, newSViv(1));
+    av_push(array_version, newSViv(1));
+
+    RC(nxt_perl_psgi_env_append_str(my_perl, hash_env, "PATH_INFO",
+                                    &path));
+    RC(nxt_perl_psgi_env_append(my_perl, hash_env, "SCRIPT_NAME",
+                                newSVpv("", 0)));
+    RC(nxt_perl_psgi_env_append(my_perl, hash_env, "psgi.run_once",
+                                newSVpv("", 0)));
+    RC(nxt_perl_psgi_env_append(my_perl, hash_env, "psgi.streaming",
+                                newSViv(0)));
+    RC(nxt_perl_psgi_env_append(my_perl, hash_env, "psgi.nonblocking",
+                                newSVpv("", 0)));
+    RC(nxt_perl_psgi_env_append(my_perl, hash_env, "psgi.multithread",
+                                newSVpv("", 0)));
+    RC(nxt_perl_psgi_env_append(my_perl, hash_env, "psgi.multiprocess",
+                                newSVpv("", 0)));
+    RC(nxt_perl_psgi_env_append(my_perl, hash_env, "psgi.url_scheme",
+                                newSVpv("http", 4)));
+    RC(nxt_perl_psgi_env_append(my_perl, hash_env, "psgi.input",
+                                SvREFCNT_inc(nxt_perl_psgi_arg_input.io)));
+    RC(nxt_perl_psgi_env_append(my_perl, hash_env, "psgi.errors",
+                                SvREFCNT_inc(nxt_perl_psgi_arg_error.io)));
+    RC(nxt_perl_psgi_env_append(my_perl, hash_env, "psgi.version",
+                                newRV_noinc((SV *) array_version)));
+
+    if (query_size > 0) {
+        query_size--;
+
+        if (nxt_slow_path(target.length < query_size)) {
+            goto fail;
+        }
+
+        str.start = &target.start[query_size];
+        str.length = target.length - query_size;
+
+        RC(nxt_perl_psgi_env_append_str(my_perl, hash_env,
+                                        "QUERY_STRING", &str));
+    }
+
+    GET_STR("SERVER_PROTOCOL");
+    GET_STR("REMOTE_ADDR");
+    GET_STR("SERVER_ADDR");
+
+    RC(nxt_app_msg_read_str(task, rmsg, &host));
+
+    if (host.length == 0) {
+        host = def_host;
+    }
+
+    colon = nxt_memchr(host.start, ':', host.length);
+    server_name = host;
+
+    if (colon != NULL) {
+        server_name.length = colon - host.start;
+
+        server_port.start = colon + 1;
+        server_port.length = host.length - server_name.length - 1;
+
+    } else {
+        server_port = def_port;
+    }
+
+    RC(nxt_perl_psgi_env_append_str(my_perl, hash_env,
+                                    "SERVER_NAME", &server_name));
+    RC(nxt_perl_psgi_env_append_str(my_perl, hash_env,
+                                    "SERVER_PORT", &server_port));
+
+    GET_STR("CONTENT_TYPE");
+    GET_STR("CONTENT_LENGTH");
+
+    for ( ;; ) {
+        rc = nxt_app_msg_read_str(task, rmsg, &str);
+
+        if (nxt_slow_path(rc != NXT_OK)) {
+            goto fail;
+        }
+
+        if (nxt_slow_path(str.length == 0)) {
+            break;
+        }
+
+        rc = nxt_app_msg_read_str(task, rmsg, &value);
+
+        if (nxt_slow_path(rc != NXT_OK)) {
+            break;
+        }
+
+        RC(nxt_perl_psgi_env_append_str(my_perl, hash_env,
+                                        (char *) str.start, &value));
+    }
+
+    RC(nxt_app_msg_read_size(task, rmsg, body_preread_size));
+
+#undef GET_STR
+#undef RC
+
+    return newRV_noinc((SV *) hash_env);
+
+fail:
+
+    SvREFCNT_dec(hash_env);
+
+    return NULL;
+}
+
+
+static nxt_str_t
+nxt_perl_psgi_result_status(PerlInterpreter *my_perl, SV *result)
+{
+    SV         **sv_status;
+    AV         *array;
+    nxt_str_t  status;
+
+    array = (AV *) SvRV(result);
+    sv_status = av_fetch(array, 0, 0);
+
+    status.start = (u_char *) SvPV(*sv_status, status.length);
+
+    return status;
+}
+
+
+static nxt_int_t
+nxt_perl_psgi_result_head(PerlInterpreter *my_perl, SV *sv_head,
+    nxt_task_t *task, nxt_app_wmsg_t *wmsg)
+{
+    AV         *array_head;
+    SV         **entry;
+    long       i, array_len;
+    nxt_int_t  rc;
+    nxt_str_t  body;
+
+    if (nxt_slow_path(SvROK(sv_head) == 0
+                      || SvTYPE(SvRV(sv_head)) != SVt_PVAV))
+    {
+        nxt_log_error(NXT_LOG_ERR, task->log,
+                      "PSGI: An unsupported format was received from "
+                      "Perl Application for head part");
+
+        return NXT_ERROR;
+    }
+
+    array_head = (AV *) SvRV(sv_head);
+    array_len = av_len(array_head);
+
+    if (array_len < 1) {
+        return NXT_OK;
+    }
+
+    if (nxt_slow_path((array_len % 2) == 0)) {
+        nxt_log_error(NXT_LOG_ERR, task->log,
+                      "PSGI: Bad format for head from "
+                      "Perl Application");
+
+        return NXT_ERROR;
+    }
+
+    for (i = 0; i <= array_len; i++) {
+        entry = av_fetch(array_head, i, 0);
+
+        if (nxt_fast_path(entry == NULL)) {
+            nxt_log_error(NXT_LOG_ERR, task->log,
+                          "PSGI: Failed to get head entry from "
+                          "Perl Application");
+
+            return NXT_ERROR;
+        }
+
+        body.start = (u_char *) SvPV(*entry, body.length);
+
+        rc = nxt_app_msg_write_raw(task, wmsg,
+                                   (u_char *) body.start, body.length);
+
+        if (nxt_slow_path(rc != NXT_OK)) {
+            nxt_log_error(NXT_LOG_ERR, task->log,
+                          "PSGI: Failed to write head "
+                          "from Perl Application");
+            return rc;
+        }
+
+        if ((i % 2) == 0) {
+            rc = nxt_app_msg_write_raw(task, wmsg,
+                                       (u_char *) ": ",
+                                       (sizeof(": ") - 1));
+        } else {
+            rc = nxt_app_msg_write_raw(task, wmsg,
+                                       (u_char *) "\r\n",
+                                       (sizeof("\r\n") - 1));
+        }
+
+        if (nxt_slow_path(rc != NXT_OK)) {
+            nxt_log_error(NXT_LOG_ERR, task->log,
+                          "PSGI: Failed to write head from "
+                          "Perl Application");
+            return rc;
+        }
+    }
+
+    return NXT_OK;
+}
+
+
+static nxt_int_t
+nxt_perl_psgi_result_body(PerlInterpreter *my_perl, SV *sv_body,
+    nxt_task_t *task, nxt_app_wmsg_t *wmsg)
+{
+    SV         **entry;
+    AV         *body_array;
+    long       i;
+    nxt_int_t  rc;
+    nxt_str_t  body;
+
+    if (nxt_slow_path(SvROK(sv_body) == 0
+                      || SvTYPE(SvRV(sv_body)) != SVt_PVAV))
+    {
+        nxt_log_error(NXT_LOG_ERR, task->log,
+                      "PSGI: An unsupported format was received from "
+                      "Perl Application for a body part");
+
+        return NXT_ERROR;
+    }
+
+    body_array = (AV *) SvRV(sv_body);
+
+    for (i = 0; i <= av_len(body_array); i++) {
+
+        entry = av_fetch(body_array, i, 0);
+
+        if (nxt_fast_path(entry == NULL)) {
+            nxt_log_error(NXT_LOG_ERR, task->log,
+                          "PSGI: Failed to get body entry from "
+                          "Perl Application");
+            return NXT_ERROR;
+        }
+
+        body.start = (u_char *) SvPV(*entry, body.length);
+
+        if (body.length == 0) {
+            continue;
+        }
+
+        rc = nxt_app_msg_write_raw(task, wmsg,
+                                   (u_char *) body.start, body.length);
+
+        if (nxt_slow_path(rc != NXT_OK)) {
+            nxt_log_error(NXT_LOG_ERR, task->log,
+                          "PSGI: Failed to write 'body' from "
+                          "Perl Application");
+            return rc;
+        }
+
+        rc = nxt_app_msg_flush(task, wmsg, 0);
+
+        if (nxt_slow_path(rc != NXT_OK)) {
+            nxt_log_error(NXT_LOG_ERR, task->log,
+                          "PSGI: Failed to flush data for a 'body' "
+                          "part from Perl Application");
+            return rc;
+        }
+    }
+
+    return NXT_OK;
+}
+
+
+static nxt_int_t
+nxt_perl_psgi_result_body_ref(PerlInterpreter *my_perl, SV *sv_body,
+    nxt_task_t *task, nxt_app_wmsg_t *wmsg)
+{
+    IO         *io;
+    PerlIO     *fp;
+    SSize_t    n;
+    nxt_int_t  rc;
+    u_char     vbuf[8192];
+
+    io = GvIO(SvRV(sv_body));
+    fp = IoIFP(io);
+
+    for ( ;; ) {
+        n = PerlIO_read(fp, vbuf, 8192);
+
+        if (n < 1) {
+            break;
+        }
+
+        rc = nxt_app_msg_write_raw(task, wmsg,
+                                   (u_char *) vbuf, (size_t) n);
+
+        if (nxt_slow_path(rc != NXT_OK)) {
+            nxt_log_error(NXT_LOG_ERR, task->log,
+                          "PSGI: Failed to write 'body' from "
+                          "Perl Application");
+
+            return rc;
+        }
+
+        rc = nxt_app_msg_flush(task, wmsg, 0);
+
+        if (nxt_slow_path(rc != NXT_OK)) {
+            nxt_log_error(NXT_LOG_ERR, task->log,
+                          "PSGI: Failed to flush data for a body "
+                          "part from Perl Application");
+
+            return rc;
+        }
+    }
+
+    return NXT_OK;
+}
+
+
+static nxt_int_t
+nxt_perl_psgi_result_array(PerlInterpreter *my_perl, SV *result,
+    nxt_task_t *task, nxt_app_wmsg_t *wmsg)
+{
+    AV         *array;
+    SV         **sv_temp;
+    long       array_len;
+    nxt_int_t  rc;
+    nxt_str_t  http_status;
+
+    array = (AV *) SvRV(result);
+    array_len = av_len(array);
+
+    if (nxt_slow_path(array_len < 0)) {
+        nxt_log_error(NXT_LOG_ERR, task->log,
+                      "PSGI: Invalid result format from Perl Application");
+
+        return NXT_ERROR;
+    }
+
+    http_status = nxt_perl_psgi_result_status(nxt_perl_psgi, result);
+
+    if (nxt_slow_path(http_status.start == NULL || http_status.length == 0)) {
+        nxt_log_error(NXT_LOG_ERR, task->log,
+                      "PSGI: An unexpected status was received "
+                      "from Perl Application");
+
+        return NXT_ERROR;
+    }
+
+    rc = nxt_perl_psgi_http_write_status_str(task, wmsg, &http_status);
+
+    if (nxt_slow_path(rc != NXT_OK)) {
+        nxt_log_error(NXT_LOG_ERR, task->log,
+                      "PSGI: Failed to write HTTP Status");
+
+        return rc;
+    }
+
+    if (array_len < 1) {
+        rc = nxt_app_msg_write_raw(task, wmsg, (u_char *) "\r\n",
+                                   (sizeof("\r\n") - 1));
+
+        if (nxt_slow_path(rc != NXT_OK)) {
+            nxt_log_error(NXT_LOG_ERR, task->log,
+                          "PSGI: Failed to write HTTP Headers");
+
+            return rc;
+        }
+
+        return NXT_OK;
+    }
+
+    sv_temp = av_fetch(array, 1, 0);
+
+    if (nxt_slow_path(sv_temp == NULL)) {
+        nxt_log_error(NXT_LOG_ERR, task->log,
+                      "PSGI: Failed to get head from Perl ARRAY variable");
+
+        return NXT_ERROR;
+    }
+
+    rc = nxt_perl_psgi_result_head(nxt_perl_psgi, *sv_temp, task, wmsg);
+
+    if (nxt_slow_path(rc != NXT_OK)) {
+        return rc;
+    }
+
+    rc = nxt_app_msg_write_raw(task, wmsg, (u_char *) "\r\n",
+                               (sizeof("\r\n") - 1));
+
+    if (nxt_slow_path(rc != NXT_OK)) {
+        nxt_log_error(NXT_LOG_ERR, task->log,
+                      "PSGI: Failed to write HTTP Headers");
+
+        return rc;
+    }
+
+    if (nxt_fast_path(array_len < 2)) {
+        return NXT_OK;
+    }
+
+    sv_temp = av_fetch(array, 2, 0);
+
+    if (nxt_slow_path(sv_temp == NULL)) {
+        nxt_log_error(NXT_LOG_ERR, task->log,
+                      "PSGI: Failed to get body from Perl ARRAY variable");
+
+        return NXT_ERROR;
+    }
+
+    if (SvTYPE(SvRV(*sv_temp)) == SVt_PVAV) {
+        rc = nxt_perl_psgi_result_body(nxt_perl_psgi, *sv_temp, task, wmsg);
+
+    } else {
+        rc = nxt_perl_psgi_result_body_ref(nxt_perl_psgi, *sv_temp,
+                                           task, wmsg);
+    }
+
+    if (nxt_slow_path(rc != NXT_OK)) {
+        return rc;
+    }
+
+    return NXT_OK;
+}
+
+
+static nxt_int_t
+nxt_perl_psgi_init(nxt_task_t *task, nxt_common_app_conf_t *conf)
+{
+    PerlInterpreter  *my_perl;
+
+    my_perl = nxt_perl_psgi_interpreter_init(task, conf->u.perl.script);
+
+    if (nxt_slow_path(my_perl == NULL)) {
+        return NXT_ERROR;
+    }
+
+    nxt_perl_psgi = my_perl;
+
+    return NXT_OK;
+}
+
+
+static nxt_int_t
+nxt_perl_psgi_run(nxt_task_t *task, nxt_app_rmsg_t *rmsg, nxt_app_wmsg_t *wmsg)
+{
+    SV                     *env, *result;
+    size_t                 body_preread_size;
+    nxt_int_t              rc;
+    nxt_perl_psgi_input_t  input;
+
+    dTHXa(nxt_perl_psgi);
+
+    /*
+     * Create environ variable for perl sub "application".
+     *  > sub application {
+     *  >     my ($environ) = @_;
+     */
+    env = nxt_perl_psgi_env_create(nxt_perl_psgi, task, rmsg,
+                                   &body_preread_size);
+
+    if (nxt_slow_path(env == NULL)) {
+        nxt_log_error(NXT_LOG_ERR, task->log,
+                      "PSGI: Failed to create 'env' for Perl Application");
+
+        return NXT_ERROR;
+    }
+
+    input.my_perl = nxt_perl_psgi;
+    input.task = task;
+    input.rmsg = rmsg;
+    input.wmsg = wmsg;
+    input.body_preread_size = body_preread_size;
+
+    nxt_perl_psgi_arg_input.ctx = &input;
+    nxt_perl_psgi_arg_error.ctx = &input;
+
+    /* Call perl sub and get result as SV*. */
+    result = nxt_perl_psgi_call_var_application(nxt_perl_psgi, env, task);
+
+    /*
+     * We expect ARRAY ref like a
+     * ['200', ['Content-Type' => "text/plain"], ["body"]]
+     */
+    if (nxt_slow_path(SvOK(result) == 0 || SvROK(result) == 0
+                      || SvTYPE(SvRV(result)) != SVt_PVAV))
+    {
+        nxt_log_error(NXT_LOG_ERR, task->log,
+                      "PSGI: An unexpected response was received from "
+                      "Perl Application");
+        goto fail;
+    }
+
+    rc = nxt_perl_psgi_result_array(nxt_perl_psgi, result, task, wmsg);
+
+    if (nxt_slow_path(rc != NXT_OK)) {
+        goto fail;
+    }
+
+    rc = nxt_app_msg_flush(task, wmsg, 1);
+
+    if (nxt_slow_path(rc != NXT_OK)) {
+        goto fail;
+    }
+
+    SvREFCNT_dec(result);
+    SvREFCNT_dec(env);
+
+    return NXT_OK;
+
+fail:
+
+    SvREFCNT_dec(result);
+    SvREFCNT_dec(env);
+
+    return NXT_ERROR;
+}
+
+
+static void
+nxt_perl_psgi_atexit(nxt_task_t *task)
+{
+    dTHXa(nxt_perl_psgi);
+
+    nxt_perl_psgi_layer_stream_io_destroy(aTHX_ nxt_perl_psgi_arg_input.io);
+    nxt_perl_psgi_layer_stream_fp_destroy(aTHX_ nxt_perl_psgi_arg_input.fp);
+
+    nxt_perl_psgi_layer_stream_io_destroy(aTHX_ nxt_perl_psgi_arg_error.io);
+    nxt_perl_psgi_layer_stream_fp_destroy(aTHX_ nxt_perl_psgi_arg_error.fp);
+
+    perl_destruct(nxt_perl_psgi);
+    perl_free(nxt_perl_psgi);
+    PERL_SYS_TERM();
+}