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