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