1 #line 2 "perl.c" 2 /* perl.c 3 * 4 * Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001 5 * 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012 6 * 2013, 2014, 2015, 2016, 2017 by Larry Wall and others 7 * 8 * You may distribute under the terms of either the GNU General Public 9 * License or the Artistic License, as specified in the README file. 10 * 11 */ 12 13 /* 14 * A ship then new they built for him 15 * of mithril and of elven-glass 16 * --from Bilbo's song of Eärendil 17 * 18 * [p.236 of _The Lord of the Rings_, II/i: "Many Meetings"] 19 */ 20 21 /* This file contains the top-level functions that are used to create, use 22 * and destroy a perl interpreter, plus the functions used by XS code to 23 * call back into perl. Note that it does not contain the actual main() 24 * function of the interpreter; that can be found in perlmain.c 25 */ 26 27 #if defined(PERL_IS_MINIPERL) && !defined(USE_SITECUSTOMIZE) 28 # define USE_SITECUSTOMIZE 29 #endif 30 31 #include "EXTERN.h" 32 #define PERL_IN_PERL_C 33 #include "perl.h" 34 #include "patchlevel.h" /* for local_patches */ 35 #include "XSUB.h" 36 37 #ifdef NETWARE 38 #include "nwutil.h" 39 #endif 40 41 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP 42 # ifdef I_SYSUIO 43 # include <sys/uio.h> 44 # endif 45 46 union control_un { 47 struct cmsghdr cm; 48 char control[CMSG_SPACE(sizeof(int))]; 49 }; 50 51 #endif 52 53 #ifndef HZ 54 # ifdef CLK_TCK 55 # define HZ CLK_TCK 56 # else 57 # define HZ 60 58 # endif 59 #endif 60 61 #if !defined(STANDARD_C) && !defined(HAS_GETENV_PROTOTYPE) && !defined(PERL_MICRO) 62 char *getenv (char *); /* Usually in <stdlib.h> */ 63 #endif 64 65 static I32 read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen); 66 67 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW 68 # define validate_suid(rsfp) NOOP 69 #else 70 # define validate_suid(rsfp) S_validate_suid(aTHX_ rsfp) 71 #endif 72 73 #define CALL_BODY_SUB(myop) \ 74 if (PL_op == (myop)) \ 75 PL_op = PL_ppaddr[OP_ENTERSUB](aTHX); \ 76 if (PL_op) \ 77 CALLRUNOPS(aTHX); 78 79 #define CALL_LIST_BODY(cv) \ 80 PUSHMARK(PL_stack_sp); \ 81 call_sv(MUTABLE_SV((cv)), G_EVAL|G_DISCARD|G_VOID); 82 83 static void 84 S_init_tls_and_interp(PerlInterpreter *my_perl) 85 { 86 dVAR; 87 if (!PL_curinterp) { 88 PERL_SET_INTERP(my_perl); 89 #if defined(USE_ITHREADS) 90 INIT_THREADS; 91 ALLOC_THREAD_KEY; 92 PERL_SET_THX(my_perl); 93 OP_REFCNT_INIT; 94 OP_CHECK_MUTEX_INIT; 95 HINTS_REFCNT_INIT; 96 LOCALE_INIT; 97 MUTEX_INIT(&PL_dollarzero_mutex); 98 MUTEX_INIT(&PL_my_ctx_mutex); 99 # endif 100 } 101 #if defined(USE_ITHREADS) 102 else 103 #else 104 /* This always happens for non-ithreads */ 105 #endif 106 { 107 PERL_SET_THX(my_perl); 108 } 109 } 110 111 112 /* these implement the PERL_SYS_INIT, PERL_SYS_INIT3, PERL_SYS_TERM macros */ 113 114 void 115 Perl_sys_init(int* argc, char*** argv) 116 { 117 dVAR; 118 119 PERL_ARGS_ASSERT_SYS_INIT; 120 121 PERL_UNUSED_ARG(argc); /* may not be used depending on _BODY macro */ 122 PERL_UNUSED_ARG(argv); 123 PERL_SYS_INIT_BODY(argc, argv); 124 } 125 126 void 127 Perl_sys_init3(int* argc, char*** argv, char*** env) 128 { 129 dVAR; 130 131 PERL_ARGS_ASSERT_SYS_INIT3; 132 133 PERL_UNUSED_ARG(argc); /* may not be used depending on _BODY macro */ 134 PERL_UNUSED_ARG(argv); 135 PERL_UNUSED_ARG(env); 136 PERL_SYS_INIT3_BODY(argc, argv, env); 137 } 138 139 void 140 Perl_sys_term(void) 141 { 142 dVAR; 143 if (!PL_veto_cleanup) { 144 PERL_SYS_TERM_BODY(); 145 } 146 } 147 148 149 #ifdef PERL_IMPLICIT_SYS 150 PerlInterpreter * 151 perl_alloc_using(struct IPerlMem* ipM, struct IPerlMem* ipMS, 152 struct IPerlMem* ipMP, struct IPerlEnv* ipE, 153 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO, 154 struct IPerlDir* ipD, struct IPerlSock* ipS, 155 struct IPerlProc* ipP) 156 { 157 PerlInterpreter *my_perl; 158 159 PERL_ARGS_ASSERT_PERL_ALLOC_USING; 160 161 /* Newx() needs interpreter, so call malloc() instead */ 162 my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter)); 163 S_init_tls_and_interp(my_perl); 164 Zero(my_perl, 1, PerlInterpreter); 165 PL_Mem = ipM; 166 PL_MemShared = ipMS; 167 PL_MemParse = ipMP; 168 PL_Env = ipE; 169 PL_StdIO = ipStd; 170 PL_LIO = ipLIO; 171 PL_Dir = ipD; 172 PL_Sock = ipS; 173 PL_Proc = ipP; 174 INIT_TRACK_MEMPOOL(PL_memory_debug_header, my_perl); 175 176 return my_perl; 177 } 178 #else 179 180 /* 181 =head1 Embedding Functions 182 183 =for apidoc perl_alloc 184 185 Allocates a new Perl interpreter. See L<perlembed>. 186 187 =cut 188 */ 189 190 PerlInterpreter * 191 perl_alloc(void) 192 { 193 PerlInterpreter *my_perl; 194 195 /* Newx() needs interpreter, so call malloc() instead */ 196 my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter)); 197 198 S_init_tls_and_interp(my_perl); 199 #ifndef PERL_TRACK_MEMPOOL 200 return (PerlInterpreter *) ZeroD(my_perl, 1, PerlInterpreter); 201 #else 202 Zero(my_perl, 1, PerlInterpreter); 203 INIT_TRACK_MEMPOOL(PL_memory_debug_header, my_perl); 204 return my_perl; 205 #endif 206 } 207 #endif /* PERL_IMPLICIT_SYS */ 208 209 /* 210 =for apidoc perl_construct 211 212 Initializes a new Perl interpreter. See L<perlembed>. 213 214 =cut 215 */ 216 217 void 218 perl_construct(pTHXx) 219 { 220 dVAR; 221 222 PERL_ARGS_ASSERT_PERL_CONSTRUCT; 223 224 #ifdef MULTIPLICITY 225 init_interp(); 226 PL_perl_destruct_level = 1; 227 #else 228 PERL_UNUSED_ARG(my_perl); 229 if (PL_perl_destruct_level > 0) 230 init_interp(); 231 #endif 232 PL_curcop = &PL_compiling; /* needed by ckWARN, right away */ 233 234 #ifdef PERL_TRACE_OPS 235 Zero(PL_op_exec_cnt, OP_max+2, UV); 236 #endif 237 238 init_constants(); 239 240 SvREADONLY_on(&PL_sv_placeholder); 241 SvREFCNT(&PL_sv_placeholder) = SvREFCNT_IMMORTAL; 242 243 PL_sighandlerp = (Sighandler_t) Perl_sighandler; 244 #ifdef PERL_USES_PL_PIDSTATUS 245 PL_pidstatus = newHV(); 246 #endif 247 248 PL_rs = newSVpvs("\n"); 249 250 init_stacks(); 251 252 init_ids(); 253 254 JMPENV_BOOTSTRAP; 255 STATUS_ALL_SUCCESS; 256 257 init_i18nl10n(1); 258 259 #if defined(LOCAL_PATCH_COUNT) 260 PL_localpatches = local_patches; /* For possible -v */ 261 #endif 262 263 #ifdef HAVE_INTERP_INTERN 264 sys_intern_init(); 265 #endif 266 267 PerlIO_init(aTHX); /* Hook to IO system */ 268 269 PL_fdpid = newAV(); /* for remembering popen pids by fd */ 270 PL_modglobal = newHV(); /* pointers to per-interpreter module globals */ 271 PL_errors = newSVpvs(""); 272 sv_setpvs(PERL_DEBUG_PAD(0), ""); /* For regex debugging. */ 273 sv_setpvs(PERL_DEBUG_PAD(1), ""); /* ext/re needs these */ 274 sv_setpvs(PERL_DEBUG_PAD(2), ""); /* even without DEBUGGING. */ 275 #ifdef USE_ITHREADS 276 /* First entry is a list of empty elements. It needs to be initialised 277 else all hell breaks loose in S_find_uninit_var(). */ 278 Perl_av_create_and_push(aTHX_ &PL_regex_padav, newSVpvs("")); 279 PL_regex_pad = AvARRAY(PL_regex_padav); 280 Newxz(PL_stashpad, PL_stashpadmax, HV *); 281 #endif 282 #ifdef USE_REENTRANT_API 283 Perl_reentrant_init(aTHX); 284 #endif 285 #if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT) 286 /* [perl #22371] Algorimic Complexity Attack on Perl 5.6.1, 5.8.0 287 * This MUST be done before any hash stores or fetches take place. 288 * If you set PL_hash_seed (and presumably also PL_hash_seed_set) 289 * yourself, it is your responsibility to provide a good random seed! 290 * You can also define PERL_HASH_SEED in compile time, see hv.h. 291 * 292 * XXX: fix this comment */ 293 if (PL_hash_seed_set == FALSE) { 294 Perl_get_hash_seed(aTHX_ PL_hash_seed); 295 PL_hash_seed_set= TRUE; 296 } 297 #endif /* #if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT) */ 298 299 /* Note that strtab is a rather special HV. Assumptions are made 300 about not iterating on it, and not adding tie magic to it. 301 It is properly deallocated in perl_destruct() */ 302 PL_strtab = newHV(); 303 304 HvSHAREKEYS_off(PL_strtab); /* mandatory */ 305 hv_ksplit(PL_strtab, 512); 306 307 Zero(PL_sv_consts, SV_CONSTS_COUNT, SV*); 308 309 #ifndef PERL_MICRO 310 # ifdef USE_ENVIRON_ARRAY 311 PL_origenviron = environ; 312 # endif 313 #endif 314 315 /* Use sysconf(_SC_CLK_TCK) if available, if not 316 * available or if the sysconf() fails, use the HZ. 317 * The HZ if not originally defined has been by now 318 * been defined as CLK_TCK, if available. */ 319 #if defined(HAS_SYSCONF) && defined(_SC_CLK_TCK) 320 PL_clocktick = sysconf(_SC_CLK_TCK); 321 if (PL_clocktick <= 0) 322 #endif 323 PL_clocktick = HZ; 324 325 PL_stashcache = newHV(); 326 327 PL_patchlevel = newSVpvs("v" PERL_VERSION_STRING); 328 329 #ifdef HAS_MMAP 330 if (!PL_mmap_page_size) { 331 #if defined(HAS_SYSCONF) && (defined(_SC_PAGESIZE) || defined(_SC_MMAP_PAGE_SIZE)) 332 { 333 SETERRNO(0, SS_NORMAL); 334 # ifdef _SC_PAGESIZE 335 PL_mmap_page_size = sysconf(_SC_PAGESIZE); 336 # else 337 PL_mmap_page_size = sysconf(_SC_MMAP_PAGE_SIZE); 338 # endif 339 if ((long) PL_mmap_page_size < 0) { 340 if (errno) { 341 SV * const error = ERRSV; 342 SvUPGRADE(error, SVt_PV); 343 Perl_croak(aTHX_ "panic: sysconf: %s", SvPV_nolen_const(error)); 344 } 345 else 346 Perl_croak(aTHX_ "panic: sysconf: pagesize unknown"); 347 } 348 } 349 #else 350 # ifdef HAS_GETPAGESIZE 351 PL_mmap_page_size = getpagesize(); 352 # else 353 # if defined(I_SYS_PARAM) && defined(PAGESIZE) 354 PL_mmap_page_size = PAGESIZE; /* compiletime, bad */ 355 # endif 356 # endif 357 #endif 358 if (PL_mmap_page_size <= 0) 359 Perl_croak(aTHX_ "panic: bad pagesize %" IVdf, 360 (IV) PL_mmap_page_size); 361 } 362 #endif /* HAS_MMAP */ 363 364 #if defined(HAS_TIMES) && defined(PERL_NEED_TIMESBASE) 365 PL_timesbase.tms_utime = 0; 366 PL_timesbase.tms_stime = 0; 367 PL_timesbase.tms_cutime = 0; 368 PL_timesbase.tms_cstime = 0; 369 #endif 370 371 PL_osname = Perl_savepvn(aTHX_ STR_WITH_LEN(OSNAME)); 372 373 PL_registered_mros = newHV(); 374 /* Start with 1 bucket, for DFS. It's unlikely we'll need more. */ 375 HvMAX(PL_registered_mros) = 0; 376 377 PL_XPosix_ptrs[_CC_ASCII] = _new_invlist_C_array(ASCII_invlist); 378 PL_XPosix_ptrs[_CC_ALPHANUMERIC] = _new_invlist_C_array(XPosixAlnum_invlist); 379 PL_XPosix_ptrs[_CC_ALPHA] = _new_invlist_C_array(XPosixAlpha_invlist); 380 PL_XPosix_ptrs[_CC_BLANK] = _new_invlist_C_array(XPosixBlank_invlist); 381 PL_XPosix_ptrs[_CC_CASED] = _new_invlist_C_array(Cased_invlist); 382 PL_XPosix_ptrs[_CC_CNTRL] = _new_invlist_C_array(XPosixCntrl_invlist); 383 PL_XPosix_ptrs[_CC_DIGIT] = _new_invlist_C_array(XPosixDigit_invlist); 384 PL_XPosix_ptrs[_CC_GRAPH] = _new_invlist_C_array(XPosixGraph_invlist); 385 PL_XPosix_ptrs[_CC_LOWER] = _new_invlist_C_array(XPosixLower_invlist); 386 PL_XPosix_ptrs[_CC_PRINT] = _new_invlist_C_array(XPosixPrint_invlist); 387 PL_XPosix_ptrs[_CC_PUNCT] = _new_invlist_C_array(XPosixPunct_invlist); 388 PL_XPosix_ptrs[_CC_SPACE] = _new_invlist_C_array(XPerlSpace_invlist); 389 PL_XPosix_ptrs[_CC_UPPER] = _new_invlist_C_array(XPosixUpper_invlist); 390 PL_XPosix_ptrs[_CC_VERTSPACE] = _new_invlist_C_array(VertSpace_invlist); 391 PL_XPosix_ptrs[_CC_WORDCHAR] = _new_invlist_C_array(XPosixWord_invlist); 392 PL_XPosix_ptrs[_CC_XDIGIT] = _new_invlist_C_array(XPosixXDigit_invlist); 393 PL_GCB_invlist = _new_invlist_C_array(_Perl_GCB_invlist); 394 PL_SB_invlist = _new_invlist_C_array(_Perl_SB_invlist); 395 PL_WB_invlist = _new_invlist_C_array(_Perl_WB_invlist); 396 PL_LB_invlist = _new_invlist_C_array(_Perl_LB_invlist); 397 398 ENTER; 399 } 400 401 /* 402 =for apidoc nothreadhook 403 404 Stub that provides thread hook for perl_destruct when there are 405 no threads. 406 407 =cut 408 */ 409 410 int 411 Perl_nothreadhook(pTHX) 412 { 413 PERL_UNUSED_CONTEXT; 414 return 0; 415 } 416 417 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP 418 void 419 Perl_dump_sv_child(pTHX_ SV *sv) 420 { 421 ssize_t got; 422 const int sock = PL_dumper_fd; 423 const int debug_fd = PerlIO_fileno(Perl_debug_log); 424 union control_un control; 425 struct msghdr msg; 426 struct iovec vec[2]; 427 struct cmsghdr *cmptr; 428 int returned_errno; 429 unsigned char buffer[256]; 430 431 PERL_ARGS_ASSERT_DUMP_SV_CHILD; 432 433 if(sock == -1 || debug_fd == -1) 434 return; 435 436 PerlIO_flush(Perl_debug_log); 437 438 /* All these shenanigans are to pass a file descriptor over to our child for 439 it to dump out to. We can't let it hold open the file descriptor when it 440 forks, as the file descriptor it will dump to can turn out to be one end 441 of pipe that some other process will wait on for EOF. (So as it would 442 be open, the wait would be forever.) */ 443 444 msg.msg_control = control.control; 445 msg.msg_controllen = sizeof(control.control); 446 /* We're a connected socket so we don't need a destination */ 447 msg.msg_name = NULL; 448 msg.msg_namelen = 0; 449 msg.msg_iov = vec; 450 msg.msg_iovlen = 1; 451 452 cmptr = CMSG_FIRSTHDR(&msg); 453 cmptr->cmsg_len = CMSG_LEN(sizeof(int)); 454 cmptr->cmsg_level = SOL_SOCKET; 455 cmptr->cmsg_type = SCM_RIGHTS; 456 *((int *)CMSG_DATA(cmptr)) = 1; 457 458 vec[0].iov_base = (void*)&sv; 459 vec[0].iov_len = sizeof(sv); 460 got = sendmsg(sock, &msg, 0); 461 462 if(got < 0) { 463 perror("Debug leaking scalars parent sendmsg failed"); 464 abort(); 465 } 466 if(got < sizeof(sv)) { 467 perror("Debug leaking scalars parent short sendmsg"); 468 abort(); 469 } 470 471 /* Return protocol is 472 int: errno value 473 unsigned char: length of location string (0 for empty) 474 unsigned char*: string (not terminated) 475 */ 476 vec[0].iov_base = (void*)&returned_errno; 477 vec[0].iov_len = sizeof(returned_errno); 478 vec[1].iov_base = buffer; 479 vec[1].iov_len = 1; 480 481 got = readv(sock, vec, 2); 482 483 if(got < 0) { 484 perror("Debug leaking scalars parent read failed"); 485 PerlIO_flush(PerlIO_stderr()); 486 abort(); 487 } 488 if(got < sizeof(returned_errno) + 1) { 489 perror("Debug leaking scalars parent short read"); 490 PerlIO_flush(PerlIO_stderr()); 491 abort(); 492 } 493 494 if (*buffer) { 495 got = read(sock, buffer + 1, *buffer); 496 if(got < 0) { 497 perror("Debug leaking scalars parent read 2 failed"); 498 PerlIO_flush(PerlIO_stderr()); 499 abort(); 500 } 501 502 if(got < *buffer) { 503 perror("Debug leaking scalars parent short read 2"); 504 PerlIO_flush(PerlIO_stderr()); 505 abort(); 506 } 507 } 508 509 if (returned_errno || *buffer) { 510 Perl_warn(aTHX_ "Debug leaking scalars child failed%s%.*s with errno" 511 " %d: %s", (*buffer ? " at " : ""), (int) *buffer, buffer + 1, 512 returned_errno, Strerror(returned_errno)); 513 } 514 } 515 #endif 516 517 /* 518 =for apidoc perl_destruct 519 520 Shuts down a Perl interpreter. See L<perlembed>. 521 522 =cut 523 */ 524 525 int 526 perl_destruct(pTHXx) 527 { 528 dVAR; 529 VOL signed char destruct_level; /* see possible values in intrpvar.h */ 530 HV *hv; 531 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP 532 pid_t child; 533 #endif 534 int i; 535 536 PERL_ARGS_ASSERT_PERL_DESTRUCT; 537 #ifndef MULTIPLICITY 538 PERL_UNUSED_ARG(my_perl); 539 #endif 540 541 assert(PL_scopestack_ix == 1); 542 543 /* wait for all pseudo-forked children to finish */ 544 PERL_WAIT_FOR_CHILDREN; 545 546 destruct_level = PL_perl_destruct_level; 547 #if defined(DEBUGGING) || defined(PERL_TRACK_MEMPOOL) 548 { 549 const char * const s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL"); 550 if (s) { 551 int i; 552 if (strEQ(s, "-1")) { /* Special case: modperl folklore. */ 553 i = -1; 554 } else { 555 UV uv; 556 if (grok_atoUV(s, &uv, NULL) && uv <= INT_MAX) 557 i = (int)uv; 558 else 559 i = 0; 560 } 561 #ifdef DEBUGGING 562 if (destruct_level < i) destruct_level = i; 563 #endif 564 #ifdef PERL_TRACK_MEMPOOL 565 /* RT #114496, for perl_free */ 566 PL_perl_destruct_level = i; 567 #endif 568 } 569 } 570 #endif 571 572 if (PL_exit_flags & PERL_EXIT_DESTRUCT_END) { 573 dJMPENV; 574 int x = 0; 575 576 JMPENV_PUSH(x); 577 PERL_UNUSED_VAR(x); 578 if (PL_endav && !PL_minus_c) { 579 PERL_SET_PHASE(PERL_PHASE_END); 580 call_list(PL_scopestack_ix, PL_endav); 581 } 582 JMPENV_POP; 583 } 584 LEAVE; 585 FREETMPS; 586 assert(PL_scopestack_ix == 0); 587 588 /* Need to flush since END blocks can produce output */ 589 /* flush stdout separately, since we can identify it */ 590 #ifdef USE_PERLIO 591 { 592 PerlIO *stdo = PerlIO_stdout(); 593 if (*stdo && PerlIO_flush(stdo)) { 594 PerlIO_restore_errno(stdo); 595 PerlIO_printf(PerlIO_stderr(), "Unable to flush stdout: %s", 596 Strerror(errno)); 597 if (!STATUS_UNIX) 598 STATUS_ALL_FAILURE; 599 } 600 } 601 #endif 602 my_fflush_all(); 603 604 #ifdef PERL_TRACE_OPS 605 /* If we traced all Perl OP usage, report and clean up */ 606 PerlIO_printf(Perl_debug_log, "Trace of all OPs executed:\n"); 607 for (i = 0; i <= OP_max; ++i) { 608 PerlIO_printf(Perl_debug_log, " %s: %"UVuf"\n", PL_op_name[i], PL_op_exec_cnt[i]); 609 PL_op_exec_cnt[i] = 0; 610 } 611 /* Utility slot for easily doing little tracing experiments in the runloop: */ 612 if (PL_op_exec_cnt[OP_max+1] != 0) 613 PerlIO_printf(Perl_debug_log, " SPECIAL: %"UVuf"\n", PL_op_exec_cnt[OP_max+1]); 614 PerlIO_printf(Perl_debug_log, "\n"); 615 #endif 616 617 618 if (PL_threadhook(aTHX)) { 619 /* Threads hook has vetoed further cleanup */ 620 PL_veto_cleanup = TRUE; 621 return STATUS_EXIT; 622 } 623 624 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP 625 if (destruct_level != 0) { 626 /* Fork here to create a child. Our child's job is to preserve the 627 state of scalars prior to destruction, so that we can instruct it 628 to dump any scalars that we later find have leaked. 629 There's no subtlety in this code - it assumes POSIX, and it doesn't 630 fail gracefully */ 631 int fd[2]; 632 633 if(socketpair(AF_UNIX, SOCK_STREAM, 0, fd)) { 634 perror("Debug leaking scalars socketpair failed"); 635 abort(); 636 } 637 638 child = fork(); 639 if(child == -1) { 640 perror("Debug leaking scalars fork failed"); 641 abort(); 642 } 643 if (!child) { 644 /* We are the child */ 645 const int sock = fd[1]; 646 const int debug_fd = PerlIO_fileno(Perl_debug_log); 647 int f; 648 const char *where; 649 /* Our success message is an integer 0, and a char 0 */ 650 static const char success[sizeof(int) + 1] = {0}; 651 652 close(fd[0]); 653 654 /* We need to close all other file descriptors otherwise we end up 655 with interesting hangs, where the parent closes its end of a 656 pipe, and sits waiting for (another) child to terminate. Only 657 that child never terminates, because it never gets EOF, because 658 we also have the far end of the pipe open. We even need to 659 close the debugging fd, because sometimes it happens to be one 660 end of a pipe, and a process is waiting on the other end for 661 EOF. Normally it would be closed at some point earlier in 662 destruction, but if we happen to cause the pipe to remain open, 663 EOF never occurs, and we get an infinite hang. Hence all the 664 games to pass in a file descriptor if it's actually needed. */ 665 666 f = sysconf(_SC_OPEN_MAX); 667 if(f < 0) { 668 where = "sysconf failed"; 669 goto abort; 670 } 671 while (f--) { 672 if (f == sock) 673 continue; 674 close(f); 675 } 676 677 while (1) { 678 SV *target; 679 union control_un control; 680 struct msghdr msg; 681 struct iovec vec[1]; 682 struct cmsghdr *cmptr; 683 ssize_t got; 684 int got_fd; 685 686 msg.msg_control = control.control; 687 msg.msg_controllen = sizeof(control.control); 688 /* We're a connected socket so we don't need a source */ 689 msg.msg_name = NULL; 690 msg.msg_namelen = 0; 691 msg.msg_iov = vec; 692 msg.msg_iovlen = C_ARRAY_LENGTH(vec); 693 694 vec[0].iov_base = (void*)⌖ 695 vec[0].iov_len = sizeof(target); 696 697 got = recvmsg(sock, &msg, 0); 698 699 if(got == 0) 700 break; 701 if(got < 0) { 702 where = "recv failed"; 703 goto abort; 704 } 705 if(got < sizeof(target)) { 706 where = "short recv"; 707 goto abort; 708 } 709 710 if(!(cmptr = CMSG_FIRSTHDR(&msg))) { 711 where = "no cmsg"; 712 goto abort; 713 } 714 if(cmptr->cmsg_len != CMSG_LEN(sizeof(int))) { 715 where = "wrong cmsg_len"; 716 goto abort; 717 } 718 if(cmptr->cmsg_level != SOL_SOCKET) { 719 where = "wrong cmsg_level"; 720 goto abort; 721 } 722 if(cmptr->cmsg_type != SCM_RIGHTS) { 723 where = "wrong cmsg_type"; 724 goto abort; 725 } 726 727 got_fd = *(int*)CMSG_DATA(cmptr); 728 /* For our last little bit of trickery, put the file descriptor 729 back into Perl_debug_log, as if we never actually closed it 730 */ 731 if(got_fd != debug_fd) { 732 if (dup2(got_fd, debug_fd) == -1) { 733 where = "dup2"; 734 goto abort; 735 } 736 } 737 sv_dump(target); 738 739 PerlIO_flush(Perl_debug_log); 740 741 got = write(sock, &success, sizeof(success)); 742 743 if(got < 0) { 744 where = "write failed"; 745 goto abort; 746 } 747 if(got < sizeof(success)) { 748 where = "short write"; 749 goto abort; 750 } 751 } 752 _exit(0); 753 abort: 754 { 755 int send_errno = errno; 756 unsigned char length = (unsigned char) strlen(where); 757 struct iovec failure[3] = { 758 {(void*)&send_errno, sizeof(send_errno)}, 759 {&length, 1}, 760 {(void*)where, length} 761 }; 762 int got = writev(sock, failure, 3); 763 /* Bad news travels fast. Faster than data. We'll get a SIGPIPE 764 in the parent if we try to read from the socketpair after the 765 child has exited, even if there was data to read. 766 So sleep a bit to give the parent a fighting chance of 767 reading the data. */ 768 sleep(2); 769 _exit((got == -1) ? errno : 0); 770 } 771 /* End of child. */ 772 } 773 PL_dumper_fd = fd[0]; 774 close(fd[1]); 775 } 776 #endif 777 778 /* We must account for everything. */ 779 780 /* Destroy the main CV and syntax tree */ 781 /* Set PL_curcop now, because destroying ops can cause new SVs 782 to be generated in Perl_pad_swipe, and when running with 783 -DDEBUG_LEAKING_SCALARS they expect PL_curcop to point to a valid 784 op from which the filename structure member is copied. */ 785 PL_curcop = &PL_compiling; 786 if (PL_main_root) { 787 /* ensure comppad/curpad to refer to main's pad */ 788 if (CvPADLIST(PL_main_cv)) { 789 PAD_SET_CUR_NOSAVE(CvPADLIST(PL_main_cv), 1); 790 PL_comppad_name = PadlistNAMES(CvPADLIST(PL_main_cv)); 791 } 792 op_free(PL_main_root); 793 PL_main_root = NULL; 794 } 795 PL_main_start = NULL; 796 /* note that PL_main_cv isn't usually actually freed at this point, 797 * due to the CvOUTSIDE refs from subs compiled within it. It will 798 * get freed once all the subs are freed in sv_clean_all(), for 799 * destruct_level > 0 */ 800 SvREFCNT_dec(PL_main_cv); 801 PL_main_cv = NULL; 802 PERL_SET_PHASE(PERL_PHASE_DESTRUCT); 803 804 /* Tell PerlIO we are about to tear things apart in case 805 we have layers which are using resources that should 806 be cleaned up now. 807 */ 808 809 PerlIO_destruct(aTHX); 810 811 /* 812 * Try to destruct global references. We do this first so that the 813 * destructors and destructees still exist. Some sv's might remain. 814 * Non-referenced objects are on their own. 815 */ 816 sv_clean_objs(); 817 818 /* unhook hooks which will soon be, or use, destroyed data */ 819 SvREFCNT_dec(PL_warnhook); 820 PL_warnhook = NULL; 821 SvREFCNT_dec(PL_diehook); 822 PL_diehook = NULL; 823 824 /* call exit list functions */ 825 while (PL_exitlistlen-- > 0) 826 PL_exitlist[PL_exitlistlen].fn(aTHX_ PL_exitlist[PL_exitlistlen].ptr); 827 828 Safefree(PL_exitlist); 829 830 PL_exitlist = NULL; 831 PL_exitlistlen = 0; 832 833 SvREFCNT_dec(PL_registered_mros); 834 835 /* jettison our possibly duplicated environment */ 836 /* if PERL_USE_SAFE_PUTENV is defined environ will not have been copied 837 * so we certainly shouldn't free it here 838 */ 839 #ifndef PERL_MICRO 840 #if defined(USE_ENVIRON_ARRAY) && !defined(PERL_USE_SAFE_PUTENV) 841 if (environ != PL_origenviron && !PL_use_safe_putenv 842 #ifdef USE_ITHREADS 843 /* only main thread can free environ[0] contents */ 844 && PL_curinterp == aTHX 845 #endif 846 ) 847 { 848 I32 i; 849 850 for (i = 0; environ[i]; i++) 851 safesysfree(environ[i]); 852 853 /* Must use safesysfree() when working with environ. */ 854 safesysfree(environ); 855 856 environ = PL_origenviron; 857 } 858 #endif 859 #endif /* !PERL_MICRO */ 860 861 if (destruct_level == 0) { 862 863 DEBUG_P(debprofdump()); 864 865 #if defined(PERLIO_LAYERS) 866 /* No more IO - including error messages ! */ 867 PerlIO_cleanup(aTHX); 868 #endif 869 870 CopFILE_free(&PL_compiling); 871 872 /* The exit() function will do everything that needs doing. */ 873 return STATUS_EXIT; 874 } 875 876 /* Below, do clean up for when PERL_DESTRUCT_LEVEL is not 0 */ 877 878 #ifdef USE_ITHREADS 879 /* the syntax tree is shared between clones 880 * so op_free(PL_main_root) only ReREFCNT_dec's 881 * REGEXPs in the parent interpreter 882 * we need to manually ReREFCNT_dec for the clones 883 */ 884 { 885 I32 i = AvFILLp(PL_regex_padav); 886 SV **ary = AvARRAY(PL_regex_padav); 887 888 for (; i; i--) { 889 SvREFCNT_dec(ary[i]); 890 ary[i] = &PL_sv_undef; 891 } 892 } 893 #endif 894 895 896 SvREFCNT_dec(MUTABLE_SV(PL_stashcache)); 897 PL_stashcache = NULL; 898 899 /* loosen bonds of global variables */ 900 901 /* XXX can PL_parser still be non-null here? */ 902 if(PL_parser && PL_parser->rsfp) { 903 (void)PerlIO_close(PL_parser->rsfp); 904 PL_parser->rsfp = NULL; 905 } 906 907 if (PL_minus_F) { 908 Safefree(PL_splitstr); 909 PL_splitstr = NULL; 910 } 911 912 /* switches */ 913 PL_minus_n = FALSE; 914 PL_minus_p = FALSE; 915 PL_minus_l = FALSE; 916 PL_minus_a = FALSE; 917 PL_minus_F = FALSE; 918 PL_doswitches = FALSE; 919 PL_dowarn = G_WARN_OFF; 920 #ifdef PERL_SAWAMPERSAND 921 PL_sawampersand = 0; /* must save all match strings */ 922 #endif 923 PL_unsafe = FALSE; 924 925 Safefree(PL_inplace); 926 PL_inplace = NULL; 927 SvREFCNT_dec(PL_patchlevel); 928 929 if (PL_e_script) { 930 SvREFCNT_dec(PL_e_script); 931 PL_e_script = NULL; 932 } 933 934 PL_perldb = 0; 935 936 /* magical thingies */ 937 938 SvREFCNT_dec(PL_ofsgv); /* *, */ 939 PL_ofsgv = NULL; 940 941 SvREFCNT_dec(PL_ors_sv); /* $\ */ 942 PL_ors_sv = NULL; 943 944 SvREFCNT_dec(PL_rs); /* $/ */ 945 PL_rs = NULL; 946 947 Safefree(PL_osname); /* $^O */ 948 PL_osname = NULL; 949 950 SvREFCNT_dec(PL_statname); 951 PL_statname = NULL; 952 PL_statgv = NULL; 953 954 /* defgv, aka *_ should be taken care of elsewhere */ 955 956 /* float buffer */ 957 Safefree(PL_efloatbuf); 958 PL_efloatbuf = NULL; 959 PL_efloatsize = 0; 960 961 /* startup and shutdown function lists */ 962 SvREFCNT_dec(PL_beginav); 963 SvREFCNT_dec(PL_beginav_save); 964 SvREFCNT_dec(PL_endav); 965 SvREFCNT_dec(PL_checkav); 966 SvREFCNT_dec(PL_checkav_save); 967 SvREFCNT_dec(PL_unitcheckav); 968 SvREFCNT_dec(PL_unitcheckav_save); 969 SvREFCNT_dec(PL_initav); 970 PL_beginav = NULL; 971 PL_beginav_save = NULL; 972 PL_endav = NULL; 973 PL_checkav = NULL; 974 PL_checkav_save = NULL; 975 PL_unitcheckav = NULL; 976 PL_unitcheckav_save = NULL; 977 PL_initav = NULL; 978 979 /* shortcuts just get cleared */ 980 PL_hintgv = NULL; 981 PL_errgv = NULL; 982 PL_argvoutgv = NULL; 983 PL_stdingv = NULL; 984 PL_stderrgv = NULL; 985 PL_last_in_gv = NULL; 986 PL_DBsingle = NULL; 987 PL_DBtrace = NULL; 988 PL_DBsignal = NULL; 989 PL_DBsingle_iv = 0; 990 PL_DBtrace_iv = 0; 991 PL_DBsignal_iv = 0; 992 PL_DBcv = NULL; 993 PL_dbargs = NULL; 994 PL_debstash = NULL; 995 996 SvREFCNT_dec(PL_envgv); 997 SvREFCNT_dec(PL_incgv); 998 SvREFCNT_dec(PL_argvgv); 999 SvREFCNT_dec(PL_replgv); 1000 SvREFCNT_dec(PL_DBgv); 1001 SvREFCNT_dec(PL_DBline); 1002 SvREFCNT_dec(PL_DBsub); 1003 PL_envgv = NULL; 1004 PL_incgv = NULL; 1005 PL_argvgv = NULL; 1006 PL_replgv = NULL; 1007 PL_DBgv = NULL; 1008 PL_DBline = NULL; 1009 PL_DBsub = NULL; 1010 1011 SvREFCNT_dec(PL_argvout_stack); 1012 PL_argvout_stack = NULL; 1013 1014 SvREFCNT_dec(PL_modglobal); 1015 PL_modglobal = NULL; 1016 SvREFCNT_dec(PL_preambleav); 1017 PL_preambleav = NULL; 1018 SvREFCNT_dec(PL_subname); 1019 PL_subname = NULL; 1020 #ifdef PERL_USES_PL_PIDSTATUS 1021 SvREFCNT_dec(PL_pidstatus); 1022 PL_pidstatus = NULL; 1023 #endif 1024 SvREFCNT_dec(PL_toptarget); 1025 PL_toptarget = NULL; 1026 SvREFCNT_dec(PL_bodytarget); 1027 PL_bodytarget = NULL; 1028 PL_formtarget = NULL; 1029 1030 /* free locale stuff */ 1031 #ifdef USE_LOCALE_COLLATE 1032 Safefree(PL_collation_name); 1033 PL_collation_name = NULL; 1034 #endif 1035 1036 #ifdef USE_LOCALE_NUMERIC 1037 Safefree(PL_numeric_name); 1038 PL_numeric_name = NULL; 1039 SvREFCNT_dec(PL_numeric_radix_sv); 1040 PL_numeric_radix_sv = NULL; 1041 #endif 1042 1043 /* clear character classes */ 1044 for (i = 0; i < POSIX_SWASH_COUNT; i++) { 1045 SvREFCNT_dec(PL_utf8_swash_ptrs[i]); 1046 PL_utf8_swash_ptrs[i] = NULL; 1047 } 1048 SvREFCNT_dec(PL_utf8_mark); 1049 SvREFCNT_dec(PL_utf8_toupper); 1050 SvREFCNT_dec(PL_utf8_totitle); 1051 SvREFCNT_dec(PL_utf8_tolower); 1052 SvREFCNT_dec(PL_utf8_tofold); 1053 SvREFCNT_dec(PL_utf8_idstart); 1054 SvREFCNT_dec(PL_utf8_idcont); 1055 SvREFCNT_dec(PL_utf8_foldable); 1056 SvREFCNT_dec(PL_utf8_foldclosures); 1057 SvREFCNT_dec(PL_AboveLatin1); 1058 SvREFCNT_dec(PL_InBitmap); 1059 SvREFCNT_dec(PL_UpperLatin1); 1060 SvREFCNT_dec(PL_Latin1); 1061 SvREFCNT_dec(PL_NonL1NonFinalFold); 1062 SvREFCNT_dec(PL_HasMultiCharFold); 1063 #ifdef USE_LOCALE_CTYPE 1064 SvREFCNT_dec(PL_warn_locale); 1065 #endif 1066 PL_utf8_mark = NULL; 1067 PL_utf8_toupper = NULL; 1068 PL_utf8_totitle = NULL; 1069 PL_utf8_tolower = NULL; 1070 PL_utf8_tofold = NULL; 1071 PL_utf8_idstart = NULL; 1072 PL_utf8_idcont = NULL; 1073 PL_utf8_foldclosures = NULL; 1074 PL_AboveLatin1 = NULL; 1075 PL_InBitmap = NULL; 1076 PL_HasMultiCharFold = NULL; 1077 #ifdef USE_LOCALE_CTYPE 1078 PL_warn_locale = NULL; 1079 #endif 1080 PL_Latin1 = NULL; 1081 PL_NonL1NonFinalFold = NULL; 1082 PL_UpperLatin1 = NULL; 1083 for (i = 0; i < POSIX_CC_COUNT; i++) { 1084 SvREFCNT_dec(PL_XPosix_ptrs[i]); 1085 PL_XPosix_ptrs[i] = NULL; 1086 } 1087 PL_GCB_invlist = NULL; 1088 PL_LB_invlist = NULL; 1089 PL_SB_invlist = NULL; 1090 PL_WB_invlist = NULL; 1091 1092 if (!specialWARN(PL_compiling.cop_warnings)) 1093 PerlMemShared_free(PL_compiling.cop_warnings); 1094 PL_compiling.cop_warnings = NULL; 1095 cophh_free(CopHINTHASH_get(&PL_compiling)); 1096 CopHINTHASH_set(&PL_compiling, cophh_new_empty()); 1097 CopFILE_free(&PL_compiling); 1098 1099 /* Prepare to destruct main symbol table. */ 1100 1101 hv = PL_defstash; 1102 /* break ref loop *:: <=> %:: */ 1103 (void)hv_delete(hv, "main::", 6, G_DISCARD); 1104 PL_defstash = 0; 1105 SvREFCNT_dec(hv); 1106 SvREFCNT_dec(PL_curstname); 1107 PL_curstname = NULL; 1108 1109 /* clear queued errors */ 1110 SvREFCNT_dec(PL_errors); 1111 PL_errors = NULL; 1112 1113 SvREFCNT_dec(PL_isarev); 1114 1115 FREETMPS; 1116 if (destruct_level >= 2) { 1117 if (PL_scopestack_ix != 0) 1118 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), 1119 "Unbalanced scopes: %ld more ENTERs than LEAVEs\n", 1120 (long)PL_scopestack_ix); 1121 if (PL_savestack_ix != 0) 1122 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), 1123 "Unbalanced saves: %ld more saves than restores\n", 1124 (long)PL_savestack_ix); 1125 if (PL_tmps_floor != -1) 1126 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),"Unbalanced tmps: %ld more allocs than frees\n", 1127 (long)PL_tmps_floor + 1); 1128 if (cxstack_ix != -1) 1129 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),"Unbalanced context: %ld more PUSHes than POPs\n", 1130 (long)cxstack_ix + 1); 1131 } 1132 1133 #ifdef USE_ITHREADS 1134 SvREFCNT_dec(PL_regex_padav); 1135 PL_regex_padav = NULL; 1136 PL_regex_pad = NULL; 1137 #endif 1138 1139 #ifdef PERL_IMPLICIT_CONTEXT 1140 /* the entries in this list are allocated via SV PVX's, so get freed 1141 * in sv_clean_all */ 1142 Safefree(PL_my_cxt_list); 1143 #endif 1144 1145 /* Now absolutely destruct everything, somehow or other, loops or no. */ 1146 1147 /* the 2 is for PL_fdpid and PL_strtab */ 1148 while (sv_clean_all() > 2) 1149 ; 1150 1151 #ifdef USE_ITHREADS 1152 Safefree(PL_stashpad); /* must come after sv_clean_all */ 1153 #endif 1154 1155 AvREAL_off(PL_fdpid); /* no surviving entries */ 1156 SvREFCNT_dec(PL_fdpid); /* needed in io_close() */ 1157 PL_fdpid = NULL; 1158 1159 #ifdef HAVE_INTERP_INTERN 1160 sys_intern_clear(); 1161 #endif 1162 1163 /* constant strings */ 1164 for (i = 0; i < SV_CONSTS_COUNT; i++) { 1165 SvREFCNT_dec(PL_sv_consts[i]); 1166 PL_sv_consts[i] = NULL; 1167 } 1168 1169 /* Destruct the global string table. */ 1170 { 1171 /* Yell and reset the HeVAL() slots that are still holding refcounts, 1172 * so that sv_free() won't fail on them. 1173 * Now that the global string table is using a single hunk of memory 1174 * for both HE and HEK, we either need to explicitly unshare it the 1175 * correct way, or actually free things here. 1176 */ 1177 I32 riter = 0; 1178 const I32 max = HvMAX(PL_strtab); 1179 HE * const * const array = HvARRAY(PL_strtab); 1180 HE *hent = array[0]; 1181 1182 for (;;) { 1183 if (hent && ckWARN_d(WARN_INTERNAL)) { 1184 HE * const next = HeNEXT(hent); 1185 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), 1186 "Unbalanced string table refcount: (%ld) for \"%s\"", 1187 (long)hent->he_valu.hent_refcount, HeKEY(hent)); 1188 Safefree(hent); 1189 hent = next; 1190 } 1191 if (!hent) { 1192 if (++riter > max) 1193 break; 1194 hent = array[riter]; 1195 } 1196 } 1197 1198 Safefree(array); 1199 HvARRAY(PL_strtab) = 0; 1200 HvTOTALKEYS(PL_strtab) = 0; 1201 } 1202 SvREFCNT_dec(PL_strtab); 1203 1204 #ifdef USE_ITHREADS 1205 /* free the pointer tables used for cloning */ 1206 ptr_table_free(PL_ptr_table); 1207 PL_ptr_table = (PTR_TBL_t*)NULL; 1208 #endif 1209 1210 /* free special SVs */ 1211 1212 SvREFCNT(&PL_sv_yes) = 0; 1213 sv_clear(&PL_sv_yes); 1214 SvANY(&PL_sv_yes) = NULL; 1215 SvFLAGS(&PL_sv_yes) = 0; 1216 1217 SvREFCNT(&PL_sv_no) = 0; 1218 sv_clear(&PL_sv_no); 1219 SvANY(&PL_sv_no) = NULL; 1220 SvFLAGS(&PL_sv_no) = 0; 1221 1222 { 1223 int i; 1224 for (i=0; i<=2; i++) { 1225 SvREFCNT(PERL_DEBUG_PAD(i)) = 0; 1226 sv_clear(PERL_DEBUG_PAD(i)); 1227 SvANY(PERL_DEBUG_PAD(i)) = NULL; 1228 SvFLAGS(PERL_DEBUG_PAD(i)) = 0; 1229 } 1230 } 1231 1232 if (PL_sv_count != 0 && ckWARN_d(WARN_INTERNAL)) 1233 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Scalars leaked: %ld\n", (long)PL_sv_count); 1234 1235 #ifdef DEBUG_LEAKING_SCALARS 1236 if (PL_sv_count != 0) { 1237 SV* sva; 1238 SV* sv; 1239 SV* svend; 1240 1241 for (sva = PL_sv_arenaroot; sva; sva = MUTABLE_SV(SvANY(sva))) { 1242 svend = &sva[SvREFCNT(sva)]; 1243 for (sv = sva + 1; sv < svend; ++sv) { 1244 if (SvTYPE(sv) != (svtype)SVTYPEMASK) { 1245 PerlIO_printf(Perl_debug_log, "leaked: sv=0x%p" 1246 " flags=0x%"UVxf 1247 " refcnt=%"UVuf pTHX__FORMAT "\n" 1248 "\tallocated at %s:%d %s %s (parent 0x%"UVxf");" 1249 "serial %"UVuf"\n", 1250 (void*)sv, (UV)sv->sv_flags, (UV)sv->sv_refcnt 1251 pTHX__VALUE, 1252 sv->sv_debug_file ? sv->sv_debug_file : "(unknown)", 1253 sv->sv_debug_line, 1254 sv->sv_debug_inpad ? "for" : "by", 1255 sv->sv_debug_optype ? 1256 PL_op_name[sv->sv_debug_optype]: "(none)", 1257 PTR2UV(sv->sv_debug_parent), 1258 sv->sv_debug_serial 1259 ); 1260 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP 1261 Perl_dump_sv_child(aTHX_ sv); 1262 #endif 1263 } 1264 } 1265 } 1266 } 1267 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP 1268 { 1269 int status; 1270 fd_set rset; 1271 /* Wait for up to 4 seconds for child to terminate. 1272 This seems to be the least effort way of timing out on reaping 1273 its exit status. */ 1274 struct timeval waitfor = {4, 0}; 1275 int sock = PL_dumper_fd; 1276 1277 shutdown(sock, 1); 1278 FD_ZERO(&rset); 1279 FD_SET(sock, &rset); 1280 select(sock + 1, &rset, NULL, NULL, &waitfor); 1281 waitpid(child, &status, WNOHANG); 1282 close(sock); 1283 } 1284 #endif 1285 #endif 1286 #ifdef DEBUG_LEAKING_SCALARS_ABORT 1287 if (PL_sv_count) 1288 abort(); 1289 #endif 1290 PL_sv_count = 0; 1291 1292 #if defined(PERLIO_LAYERS) 1293 /* No more IO - including error messages ! */ 1294 PerlIO_cleanup(aTHX); 1295 #endif 1296 1297 /* sv_undef needs to stay immortal until after PerlIO_cleanup 1298 as currently layers use it rather than NULL as a marker 1299 for no arg - and will try and SvREFCNT_dec it. 1300 */ 1301 SvREFCNT(&PL_sv_undef) = 0; 1302 SvREADONLY_off(&PL_sv_undef); 1303 1304 Safefree(PL_origfilename); 1305 PL_origfilename = NULL; 1306 Safefree(PL_reg_curpm); 1307 free_tied_hv_pool(); 1308 Safefree(PL_op_mask); 1309 Safefree(PL_psig_name); 1310 PL_psig_name = (SV**)NULL; 1311 PL_psig_ptr = (SV**)NULL; 1312 { 1313 /* We need to NULL PL_psig_pend first, so that 1314 signal handlers know not to use it */ 1315 int *psig_save = PL_psig_pend; 1316 PL_psig_pend = (int*)NULL; 1317 Safefree(psig_save); 1318 } 1319 nuke_stacks(); 1320 TAINTING_set(FALSE); 1321 TAINT_WARN_set(FALSE); 1322 PL_hints = 0; /* Reset hints. Should hints be per-interpreter ? */ 1323 1324 DEBUG_P(debprofdump()); 1325 1326 PL_debug = 0; 1327 1328 #ifdef USE_REENTRANT_API 1329 Perl_reentrant_free(aTHX); 1330 #endif 1331 1332 /* These all point to HVs that are about to be blown away. 1333 Code in core and on CPAN assumes that if the interpreter is re-started 1334 that they will be cleanly NULL or pointing to a valid HV. */ 1335 PL_custom_op_names = NULL; 1336 PL_custom_op_descs = NULL; 1337 PL_custom_ops = NULL; 1338 1339 sv_free_arenas(); 1340 1341 while (PL_regmatch_slab) { 1342 regmatch_slab *s = PL_regmatch_slab; 1343 PL_regmatch_slab = PL_regmatch_slab->next; 1344 Safefree(s); 1345 } 1346 1347 /* As the absolutely last thing, free the non-arena SV for mess() */ 1348 1349 if (PL_mess_sv) { 1350 /* we know that type == SVt_PVMG */ 1351 1352 /* it could have accumulated taint magic */ 1353 MAGIC* mg; 1354 MAGIC* moremagic; 1355 for (mg = SvMAGIC(PL_mess_sv); mg; mg = moremagic) { 1356 moremagic = mg->mg_moremagic; 1357 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global 1358 && mg->mg_len >= 0) 1359 Safefree(mg->mg_ptr); 1360 Safefree(mg); 1361 } 1362 1363 /* we know that type >= SVt_PV */ 1364 SvPV_free(PL_mess_sv); 1365 Safefree(SvANY(PL_mess_sv)); 1366 Safefree(PL_mess_sv); 1367 PL_mess_sv = NULL; 1368 } 1369 return STATUS_EXIT; 1370 } 1371 1372 /* 1373 =for apidoc perl_free 1374 1375 Releases a Perl interpreter. See L<perlembed>. 1376 1377 =cut 1378 */ 1379 1380 void 1381 perl_free(pTHXx) 1382 { 1383 dVAR; 1384 1385 PERL_ARGS_ASSERT_PERL_FREE; 1386 1387 if (PL_veto_cleanup) 1388 return; 1389 1390 #ifdef PERL_TRACK_MEMPOOL 1391 { 1392 /* 1393 * Don't free thread memory if PERL_DESTRUCT_LEVEL is set to a non-zero 1394 * value as we're probably hunting memory leaks then 1395 */ 1396 if (PL_perl_destruct_level == 0) { 1397 const U32 old_debug = PL_debug; 1398 /* Emulate the PerlHost behaviour of free()ing all memory allocated in this 1399 thread at thread exit. */ 1400 if (DEBUG_m_TEST) { 1401 PerlIO_puts(Perl_debug_log, "Disabling memory debugging as we " 1402 "free this thread's memory\n"); 1403 PL_debug &= ~ DEBUG_m_FLAG; 1404 } 1405 while(aTHXx->Imemory_debug_header.next != &(aTHXx->Imemory_debug_header)){ 1406 char * next = (char *)(aTHXx->Imemory_debug_header.next); 1407 Malloc_t ptr = PERL_MEMORY_DEBUG_HEADER_SIZE + next; 1408 safesysfree(ptr); 1409 } 1410 PL_debug = old_debug; 1411 } 1412 } 1413 #endif 1414 1415 #if defined(WIN32) || defined(NETWARE) 1416 # if defined(PERL_IMPLICIT_SYS) 1417 { 1418 # ifdef NETWARE 1419 void *host = nw_internal_host; 1420 PerlMem_free(aTHXx); 1421 nw_delete_internal_host(host); 1422 # else 1423 void *host = w32_internal_host; 1424 PerlMem_free(aTHXx); 1425 win32_delete_internal_host(host); 1426 # endif 1427 } 1428 # else 1429 PerlMem_free(aTHXx); 1430 # endif 1431 #else 1432 PerlMem_free(aTHXx); 1433 #endif 1434 } 1435 1436 #if defined(USE_ITHREADS) 1437 /* provide destructors to clean up the thread key when libperl is unloaded */ 1438 #ifndef WIN32 /* handled during DLL_PROCESS_DETACH in win32/perllib.c */ 1439 1440 #if defined(__hpux) && !(defined(__ux_version) && __ux_version <= 1020) && !defined(__GNUC__) 1441 #pragma fini "perl_fini" 1442 #elif defined(__sun) && !defined(__GNUC__) 1443 #pragma fini (perl_fini) 1444 #endif 1445 1446 static void 1447 #if defined(__GNUC__) 1448 __attribute__((destructor)) 1449 #endif 1450 perl_fini(void) 1451 { 1452 dVAR; 1453 if ( 1454 #ifdef PERL_GLOBAL_STRUCT_PRIVATE 1455 my_vars && 1456 #endif 1457 PL_curinterp && !PL_veto_cleanup) 1458 FREE_THREAD_KEY; 1459 } 1460 1461 #endif /* WIN32 */ 1462 #endif /* THREADS */ 1463 1464 void 1465 Perl_call_atexit(pTHX_ ATEXIT_t fn, void *ptr) 1466 { 1467 Renew(PL_exitlist, PL_exitlistlen+1, PerlExitListEntry); 1468 PL_exitlist[PL_exitlistlen].fn = fn; 1469 PL_exitlist[PL_exitlistlen].ptr = ptr; 1470 ++PL_exitlistlen; 1471 } 1472 1473 /* 1474 =for apidoc perl_parse 1475 1476 Tells a Perl interpreter to parse a Perl script. See L<perlembed>. 1477 1478 =cut 1479 */ 1480 1481 #define SET_CURSTASH(newstash) \ 1482 if (PL_curstash != newstash) { \ 1483 SvREFCNT_dec(PL_curstash); \ 1484 PL_curstash = (HV *)SvREFCNT_inc(newstash); \ 1485 } 1486 1487 int 1488 perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env) 1489 { 1490 dVAR; 1491 I32 oldscope; 1492 int ret; 1493 dJMPENV; 1494 1495 PERL_ARGS_ASSERT_PERL_PARSE; 1496 #ifndef MULTIPLICITY 1497 PERL_UNUSED_ARG(my_perl); 1498 #endif 1499 #if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT) || defined(USE_HASH_SEED_DEBUG) 1500 { 1501 const char * const s = PerlEnv_getenv("PERL_HASH_SEED_DEBUG"); 1502 1503 if (s && strEQ(s, "1")) { 1504 const unsigned char *seed= PERL_HASH_SEED; 1505 const unsigned char *seed_end= PERL_HASH_SEED + PERL_HASH_SEED_BYTES; 1506 PerlIO_printf(Perl_debug_log, "HASH_FUNCTION = %s HASH_SEED = 0x", PERL_HASH_FUNC); 1507 while (seed < seed_end) { 1508 PerlIO_printf(Perl_debug_log, "%02x", *seed++); 1509 } 1510 #ifdef PERL_HASH_RANDOMIZE_KEYS 1511 PerlIO_printf(Perl_debug_log, " PERTURB_KEYS = %d (%s)", 1512 PL_HASH_RAND_BITS_ENABLED, 1513 PL_HASH_RAND_BITS_ENABLED == 0 ? "NO" : PL_HASH_RAND_BITS_ENABLED == 1 ? "RANDOM" : "DETERMINISTIC"); 1514 #endif 1515 PerlIO_printf(Perl_debug_log, "\n"); 1516 } 1517 } 1518 #endif /* #if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT) */ 1519 1520 #ifdef __amigaos4__ 1521 { 1522 struct NameTranslationInfo nti; 1523 __translate_amiga_to_unix_path_name(&argv[0],&nti); 1524 } 1525 #endif 1526 1527 PL_origargc = argc; 1528 PL_origargv = argv; 1529 1530 if (PL_origalen != 0) { 1531 PL_origalen = 1; /* don't use old PL_origalen if perl_parse() is called again */ 1532 } 1533 else { 1534 /* Set PL_origalen be the sum of the contiguous argv[] 1535 * elements plus the size of the env in case that it is 1536 * contiguous with the argv[]. This is used in mg.c:Perl_magic_set() 1537 * as the maximum modifiable length of $0. In the worst case 1538 * the area we are able to modify is limited to the size of 1539 * the original argv[0]. (See below for 'contiguous', though.) 1540 * --jhi */ 1541 const char *s = NULL; 1542 int i; 1543 const UV mask = ~(UV)(PTRSIZE-1); 1544 /* Do the mask check only if the args seem like aligned. */ 1545 const UV aligned = 1546 (mask < ~(UV)0) && ((PTR2UV(argv[0]) & mask) == PTR2UV(argv[0])); 1547 1548 /* See if all the arguments are contiguous in memory. Note 1549 * that 'contiguous' is a loose term because some platforms 1550 * align the argv[] and the envp[]. If the arguments look 1551 * like non-aligned, assume that they are 'strictly' or 1552 * 'traditionally' contiguous. If the arguments look like 1553 * aligned, we just check that they are within aligned 1554 * PTRSIZE bytes. As long as no system has something bizarre 1555 * like the argv[] interleaved with some other data, we are 1556 * fine. (Did I just evoke Murphy's Law?) --jhi */ 1557 if (PL_origargv && PL_origargc >= 1 && (s = PL_origargv[0])) { 1558 while (*s) s++; 1559 for (i = 1; i < PL_origargc; i++) { 1560 if ((PL_origargv[i] == s + 1 1561 #ifdef OS2 1562 || PL_origargv[i] == s + 2 1563 #endif 1564 ) 1565 || 1566 (aligned && 1567 (PL_origargv[i] > s && 1568 PL_origargv[i] <= 1569 INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask))) 1570 ) 1571 { 1572 s = PL_origargv[i]; 1573 while (*s) s++; 1574 } 1575 else 1576 break; 1577 } 1578 } 1579 1580 #ifndef PERL_USE_SAFE_PUTENV 1581 /* Can we grab env area too to be used as the area for $0? */ 1582 if (s && PL_origenviron && !PL_use_safe_putenv) { 1583 if ((PL_origenviron[0] == s + 1) 1584 || 1585 (aligned && 1586 (PL_origenviron[0] > s && 1587 PL_origenviron[0] <= 1588 INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask))) 1589 ) 1590 { 1591 #ifndef OS2 /* ENVIRON is read by the kernel too. */ 1592 s = PL_origenviron[0]; 1593 while (*s) s++; 1594 #endif 1595 my_setenv("NoNe SuCh", NULL); 1596 /* Force copy of environment. */ 1597 for (i = 1; PL_origenviron[i]; i++) { 1598 if (PL_origenviron[i] == s + 1 1599 || 1600 (aligned && 1601 (PL_origenviron[i] > s && 1602 PL_origenviron[i] <= 1603 INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask))) 1604 ) 1605 { 1606 s = PL_origenviron[i]; 1607 while (*s) s++; 1608 } 1609 else 1610 break; 1611 } 1612 } 1613 } 1614 #endif /* !defined(PERL_USE_SAFE_PUTENV) */ 1615 1616 PL_origalen = s ? s - PL_origargv[0] + 1 : 0; 1617 } 1618 1619 if (PL_do_undump) { 1620 1621 /* Come here if running an undumped a.out. */ 1622 1623 PL_origfilename = savepv(argv[0]); 1624 PL_do_undump = FALSE; 1625 cxstack_ix = -1; /* start label stack again */ 1626 init_ids(); 1627 assert (!TAINT_get); 1628 TAINT; 1629 set_caret_X(); 1630 TAINT_NOT; 1631 init_postdump_symbols(argc,argv,env); 1632 return 0; 1633 } 1634 1635 if (PL_main_root) { 1636 op_free(PL_main_root); 1637 PL_main_root = NULL; 1638 } 1639 PL_main_start = NULL; 1640 SvREFCNT_dec(PL_main_cv); 1641 PL_main_cv = NULL; 1642 1643 time(&PL_basetime); 1644 oldscope = PL_scopestack_ix; 1645 PL_dowarn = G_WARN_OFF; 1646 1647 JMPENV_PUSH(ret); 1648 switch (ret) { 1649 case 0: 1650 parse_body(env,xsinit); 1651 if (PL_unitcheckav) { 1652 call_list(oldscope, PL_unitcheckav); 1653 } 1654 if (PL_checkav) { 1655 PERL_SET_PHASE(PERL_PHASE_CHECK); 1656 call_list(oldscope, PL_checkav); 1657 } 1658 ret = 0; 1659 break; 1660 case 1: 1661 STATUS_ALL_FAILURE; 1662 /* FALLTHROUGH */ 1663 case 2: 1664 /* my_exit() was called */ 1665 while (PL_scopestack_ix > oldscope) 1666 LEAVE; 1667 FREETMPS; 1668 SET_CURSTASH(PL_defstash); 1669 if (PL_unitcheckav) { 1670 call_list(oldscope, PL_unitcheckav); 1671 } 1672 if (PL_checkav) { 1673 PERL_SET_PHASE(PERL_PHASE_CHECK); 1674 call_list(oldscope, PL_checkav); 1675 } 1676 ret = STATUS_EXIT; 1677 break; 1678 case 3: 1679 PerlIO_printf(Perl_error_log, "panic: top_env\n"); 1680 ret = 1; 1681 break; 1682 } 1683 JMPENV_POP; 1684 return ret; 1685 } 1686 1687 /* This needs to stay in perl.c, as perl.c is compiled with different flags for 1688 miniperl, and we need to see those flags reflected in the values here. */ 1689 1690 /* What this returns is subject to change. Use the public interface in Config. 1691 */ 1692 static void 1693 S_Internals_V(pTHX_ CV *cv) 1694 { 1695 dXSARGS; 1696 #ifdef LOCAL_PATCH_COUNT 1697 const int local_patch_count = LOCAL_PATCH_COUNT; 1698 #else 1699 const int local_patch_count = 0; 1700 #endif 1701 const int entries = 3 + local_patch_count; 1702 int i; 1703 static const char non_bincompat_options[] = 1704 # ifdef DEBUGGING 1705 " DEBUGGING" 1706 # endif 1707 # ifdef NO_MATHOMS 1708 " NO_MATHOMS" 1709 # endif 1710 # ifdef NO_HASH_SEED 1711 " NO_HASH_SEED" 1712 # endif 1713 # ifdef NO_TAINT_SUPPORT 1714 " NO_TAINT_SUPPORT" 1715 # endif 1716 # ifdef PERL_BOOL_AS_CHAR 1717 " PERL_BOOL_AS_CHAR" 1718 # endif 1719 # ifdef PERL_COPY_ON_WRITE 1720 " PERL_COPY_ON_WRITE" 1721 # endif 1722 # ifdef PERL_DISABLE_PMC 1723 " PERL_DISABLE_PMC" 1724 # endif 1725 # ifdef PERL_DONT_CREATE_GVSV 1726 " PERL_DONT_CREATE_GVSV" 1727 # endif 1728 # ifdef PERL_EXTERNAL_GLOB 1729 " PERL_EXTERNAL_GLOB" 1730 # endif 1731 # ifdef PERL_HASH_FUNC_SIPHASH 1732 " PERL_HASH_FUNC_SIPHASH" 1733 # endif 1734 # ifdef PERL_HASH_FUNC_SDBM 1735 " PERL_HASH_FUNC_SDBM" 1736 # endif 1737 # ifdef PERL_HASH_FUNC_DJB2 1738 " PERL_HASH_FUNC_DJB2" 1739 # endif 1740 # ifdef PERL_HASH_FUNC_SUPERFAST 1741 " PERL_HASH_FUNC_SUPERFAST" 1742 # endif 1743 # ifdef PERL_HASH_FUNC_MURMUR3 1744 " PERL_HASH_FUNC_MURMUR3" 1745 # endif 1746 # ifdef PERL_HASH_FUNC_ONE_AT_A_TIME 1747 " PERL_HASH_FUNC_ONE_AT_A_TIME" 1748 # endif 1749 # ifdef PERL_HASH_FUNC_ONE_AT_A_TIME_HARD 1750 " PERL_HASH_FUNC_ONE_AT_A_TIME_HARD" 1751 # endif 1752 # ifdef PERL_HASH_FUNC_ONE_AT_A_TIME_OLD 1753 " PERL_HASH_FUNC_ONE_AT_A_TIME_OLD" 1754 # endif 1755 # ifdef PERL_IS_MINIPERL 1756 " PERL_IS_MINIPERL" 1757 # endif 1758 # ifdef PERL_MALLOC_WRAP 1759 " PERL_MALLOC_WRAP" 1760 # endif 1761 # ifdef PERL_MEM_LOG 1762 " PERL_MEM_LOG" 1763 # endif 1764 # ifdef PERL_MEM_LOG_NOIMPL 1765 " PERL_MEM_LOG_NOIMPL" 1766 # endif 1767 # ifdef PERL_PERTURB_KEYS_DETERMINISTIC 1768 " PERL_PERTURB_KEYS_DETERMINISTIC" 1769 # endif 1770 # ifdef PERL_PERTURB_KEYS_DISABLED 1771 " PERL_PERTURB_KEYS_DISABLED" 1772 # endif 1773 # ifdef PERL_PERTURB_KEYS_RANDOM 1774 " PERL_PERTURB_KEYS_RANDOM" 1775 # endif 1776 # ifdef PERL_PRESERVE_IVUV 1777 " PERL_PRESERVE_IVUV" 1778 # endif 1779 # ifdef PERL_RELOCATABLE_INCPUSH 1780 " PERL_RELOCATABLE_INCPUSH" 1781 # endif 1782 # ifdef PERL_USE_DEVEL 1783 " PERL_USE_DEVEL" 1784 # endif 1785 # ifdef PERL_USE_SAFE_PUTENV 1786 " PERL_USE_SAFE_PUTENV" 1787 # endif 1788 # ifdef SILENT_NO_TAINT_SUPPORT 1789 " SILENT_NO_TAINT_SUPPORT" 1790 # endif 1791 # ifdef UNLINK_ALL_VERSIONS 1792 " UNLINK_ALL_VERSIONS" 1793 # endif 1794 # ifdef USE_ATTRIBUTES_FOR_PERLIO 1795 " USE_ATTRIBUTES_FOR_PERLIO" 1796 # endif 1797 # ifdef USE_FAST_STDIO 1798 " USE_FAST_STDIO" 1799 # endif 1800 # ifdef USE_HASH_SEED_EXPLICIT 1801 " USE_HASH_SEED_EXPLICIT" 1802 # endif 1803 # ifdef USE_LOCALE 1804 " USE_LOCALE" 1805 # endif 1806 # ifdef USE_LOCALE_CTYPE 1807 " USE_LOCALE_CTYPE" 1808 # endif 1809 # ifdef WIN32_NO_REGISTRY 1810 " USE_NO_REGISTRY" 1811 # endif 1812 # ifdef USE_PERL_ATOF 1813 " USE_PERL_ATOF" 1814 # endif 1815 # ifdef USE_SITECUSTOMIZE 1816 " USE_SITECUSTOMIZE" 1817 # endif 1818 ; 1819 PERL_UNUSED_ARG(cv); 1820 PERL_UNUSED_VAR(items); 1821 1822 EXTEND(SP, entries); 1823 1824 PUSHs(sv_2mortal(newSVpv(PL_bincompat_options, 0))); 1825 PUSHs(Perl_newSVpvn_flags(aTHX_ non_bincompat_options, 1826 sizeof(non_bincompat_options) - 1, SVs_TEMP)); 1827 1828 #ifndef PERL_BUILD_DATE 1829 # ifdef __DATE__ 1830 # ifdef __TIME__ 1831 # define PERL_BUILD_DATE __DATE__ " " __TIME__ 1832 # else 1833 # define PERL_BUILD_DATE __DATE__ 1834 # endif 1835 # endif 1836 #endif 1837 1838 #ifdef PERL_BUILD_DATE 1839 PUSHs(Perl_newSVpvn_flags(aTHX_ 1840 STR_WITH_LEN("Compiled at " PERL_BUILD_DATE), 1841 SVs_TEMP)); 1842 #else 1843 PUSHs(&PL_sv_undef); 1844 #endif 1845 1846 for (i = 1; i <= local_patch_count; i++) { 1847 /* This will be an undef, if PL_localpatches[i] is NULL. */ 1848 PUSHs(sv_2mortal(newSVpv(PL_localpatches[i], 0))); 1849 } 1850 1851 XSRETURN(entries); 1852 } 1853 1854 #define INCPUSH_UNSHIFT 0x01 1855 #define INCPUSH_ADD_OLD_VERS 0x02 1856 #define INCPUSH_ADD_VERSIONED_SUB_DIRS 0x04 1857 #define INCPUSH_ADD_ARCHONLY_SUB_DIRS 0x08 1858 #define INCPUSH_NOT_BASEDIR 0x10 1859 #define INCPUSH_CAN_RELOCATE 0x20 1860 #define INCPUSH_ADD_SUB_DIRS \ 1861 (INCPUSH_ADD_VERSIONED_SUB_DIRS|INCPUSH_ADD_ARCHONLY_SUB_DIRS) 1862 1863 STATIC void * 1864 S_parse_body(pTHX_ char **env, XSINIT_t xsinit) 1865 { 1866 dVAR; 1867 PerlIO *rsfp; 1868 int argc = PL_origargc; 1869 char **argv = PL_origargv; 1870 const char *scriptname = NULL; 1871 bool dosearch = FALSE; 1872 char c; 1873 bool doextract = FALSE; 1874 const char *cddir = NULL; 1875 #ifdef USE_SITECUSTOMIZE 1876 bool minus_f = FALSE; 1877 #endif 1878 SV *linestr_sv = NULL; 1879 bool add_read_e_script = FALSE; 1880 U32 lex_start_flags = 0; 1881 1882 PERL_SET_PHASE(PERL_PHASE_START); 1883 1884 init_main_stash(); 1885 1886 { 1887 const char *s; 1888 for (argc--,argv++; argc > 0; argc--,argv++) { 1889 if (argv[0][0] != '-' || !argv[0][1]) 1890 break; 1891 s = argv[0]+1; 1892 reswitch: 1893 switch ((c = *s)) { 1894 case 'C': 1895 #ifndef PERL_STRICT_CR 1896 case '\r': 1897 #endif 1898 case ' ': 1899 case '0': 1900 case 'F': 1901 case 'a': 1902 case 'c': 1903 case 'd': 1904 case 'D': 1905 case 'h': 1906 case 'i': 1907 case 'l': 1908 case 'M': 1909 case 'm': 1910 case 'n': 1911 case 'p': 1912 case 's': 1913 case 'u': 1914 case 'U': 1915 case 'v': 1916 case 'W': 1917 case 'X': 1918 case 'w': 1919 if ((s = moreswitches(s))) 1920 goto reswitch; 1921 break; 1922 1923 case 't': 1924 #if defined(SILENT_NO_TAINT_SUPPORT) 1925 /* silently ignore */ 1926 #elif defined(NO_TAINT_SUPPORT) 1927 Perl_croak_nocontext("This perl was compiled without taint support. " 1928 "Cowardly refusing to run with -t or -T flags"); 1929 #else 1930 CHECK_MALLOC_TOO_LATE_FOR('t'); 1931 if( !TAINTING_get ) { 1932 TAINT_WARN_set(TRUE); 1933 TAINTING_set(TRUE); 1934 } 1935 #endif 1936 s++; 1937 goto reswitch; 1938 case 'T': 1939 #if defined(SILENT_NO_TAINT_SUPPORT) 1940 /* silently ignore */ 1941 #elif defined(NO_TAINT_SUPPORT) 1942 Perl_croak_nocontext("This perl was compiled without taint support. " 1943 "Cowardly refusing to run with -t or -T flags"); 1944 #else 1945 CHECK_MALLOC_TOO_LATE_FOR('T'); 1946 TAINTING_set(TRUE); 1947 TAINT_WARN_set(FALSE); 1948 #endif 1949 s++; 1950 goto reswitch; 1951 1952 case 'E': 1953 PL_minus_E = TRUE; 1954 /* FALLTHROUGH */ 1955 case 'e': 1956 forbid_setid('e', FALSE); 1957 if (!PL_e_script) { 1958 PL_e_script = newSVpvs(""); 1959 add_read_e_script = TRUE; 1960 } 1961 if (*++s) 1962 sv_catpv(PL_e_script, s); 1963 else if (argv[1]) { 1964 sv_catpv(PL_e_script, argv[1]); 1965 argc--,argv++; 1966 } 1967 else 1968 Perl_croak(aTHX_ "No code specified for -%c", c); 1969 sv_catpvs(PL_e_script, "\n"); 1970 break; 1971 1972 case 'f': 1973 #ifdef USE_SITECUSTOMIZE 1974 minus_f = TRUE; 1975 #endif 1976 s++; 1977 goto reswitch; 1978 1979 case 'I': /* -I handled both here and in moreswitches() */ 1980 forbid_setid('I', FALSE); 1981 if (!*++s && (s=argv[1]) != NULL) { 1982 argc--,argv++; 1983 } 1984 if (s && *s) { 1985 STRLEN len = strlen(s); 1986 incpush(s, len, INCPUSH_ADD_SUB_DIRS|INCPUSH_ADD_OLD_VERS); 1987 } 1988 else 1989 Perl_croak(aTHX_ "No directory specified for -I"); 1990 break; 1991 case 'S': 1992 forbid_setid('S', FALSE); 1993 dosearch = TRUE; 1994 s++; 1995 goto reswitch; 1996 case 'V': 1997 { 1998 SV *opts_prog; 1999 2000 if (*++s != ':') { 2001 opts_prog = newSVpvs("use Config; Config::_V()"); 2002 } 2003 else { 2004 ++s; 2005 opts_prog = Perl_newSVpvf(aTHX_ 2006 "use Config; Config::config_vars(qw%c%s%c)", 2007 0, s, 0); 2008 s += strlen(s); 2009 } 2010 Perl_av_create_and_push(aTHX_ &PL_preambleav, opts_prog); 2011 /* don't look for script or read stdin */ 2012 scriptname = BIT_BUCKET; 2013 goto reswitch; 2014 } 2015 case 'x': 2016 doextract = TRUE; 2017 s++; 2018 if (*s) 2019 cddir = s; 2020 break; 2021 case 0: 2022 break; 2023 case '-': 2024 if (!*++s || isSPACE(*s)) { 2025 argc--,argv++; 2026 goto switch_end; 2027 } 2028 /* catch use of gnu style long options. 2029 Both of these exit immediately. */ 2030 if (strEQ(s, "version")) 2031 minus_v(); 2032 if (strEQ(s, "help")) 2033 usage(); 2034 s--; 2035 /* FALLTHROUGH */ 2036 default: 2037 Perl_croak(aTHX_ "Unrecognized switch: -%s (-h will show valid options)",s); 2038 } 2039 } 2040 } 2041 2042 switch_end: 2043 2044 { 2045 char *s; 2046 2047 if ( 2048 #ifndef SECURE_INTERNAL_GETENV 2049 !TAINTING_get && 2050 #endif 2051 (s = PerlEnv_getenv("PERL5OPT"))) 2052 { 2053 /* s points to static memory in getenv(), which may be overwritten at 2054 * any time; use a mortal copy instead */ 2055 s = SvPVX(sv_2mortal(newSVpv(s, 0))); 2056 2057 while (isSPACE(*s)) 2058 s++; 2059 if (*s == '-' && *(s+1) == 'T') { 2060 #if defined(SILENT_NO_TAINT_SUPPORT) 2061 /* silently ignore */ 2062 #elif defined(NO_TAINT_SUPPORT) 2063 Perl_croak_nocontext("This perl was compiled without taint support. " 2064 "Cowardly refusing to run with -t or -T flags"); 2065 #else 2066 CHECK_MALLOC_TOO_LATE_FOR('T'); 2067 TAINTING_set(TRUE); 2068 TAINT_WARN_set(FALSE); 2069 #endif 2070 } 2071 else { 2072 char *popt_copy = NULL; 2073 while (s && *s) { 2074 const char *d; 2075 while (isSPACE(*s)) 2076 s++; 2077 if (*s == '-') { 2078 s++; 2079 if (isSPACE(*s)) 2080 continue; 2081 } 2082 d = s; 2083 if (!*s) 2084 break; 2085 if (!strchr("CDIMUdmtwW", *s)) 2086 Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s); 2087 while (++s && *s) { 2088 if (isSPACE(*s)) { 2089 if (!popt_copy) { 2090 popt_copy = SvPVX(sv_2mortal(newSVpv(d,0))); 2091 s = popt_copy + (s - d); 2092 d = popt_copy; 2093 } 2094 *s++ = '\0'; 2095 break; 2096 } 2097 } 2098 if (*d == 't') { 2099 #if defined(SILENT_NO_TAINT_SUPPORT) 2100 /* silently ignore */ 2101 #elif defined(NO_TAINT_SUPPORT) 2102 Perl_croak_nocontext("This perl was compiled without taint support. " 2103 "Cowardly refusing to run with -t or -T flags"); 2104 #else 2105 if( !TAINTING_get) { 2106 TAINT_WARN_set(TRUE); 2107 TAINTING_set(TRUE); 2108 } 2109 #endif 2110 } else { 2111 moreswitches(d); 2112 } 2113 } 2114 } 2115 } 2116 } 2117 2118 /* Set $^X early so that it can be used for relocatable paths in @INC */ 2119 /* and for SITELIB_EXP in USE_SITECUSTOMIZE */ 2120 assert (!TAINT_get); 2121 TAINT; 2122 set_caret_X(); 2123 TAINT_NOT; 2124 2125 #if defined(USE_SITECUSTOMIZE) 2126 if (!minus_f) { 2127 /* The games with local $! are to avoid setting errno if there is no 2128 sitecustomize script. "q%c...%c", 0, ..., 0 becomes "q\0...\0", 2129 ie a q() operator with a NUL byte as a the delimiter. This avoids 2130 problems with pathnames containing (say) ' */ 2131 # ifdef PERL_IS_MINIPERL 2132 AV *const inc = GvAV(PL_incgv); 2133 SV **const inc0 = inc ? av_fetch(inc, 0, FALSE) : NULL; 2134 2135 if (inc0) { 2136 /* if lib/buildcustomize.pl exists, it should not fail. If it does, 2137 it should be reported immediately as a build failure. */ 2138 (void)Perl_av_create_and_unshift_one(aTHX_ &PL_preambleav, 2139 Perl_newSVpvf(aTHX_ 2140 "BEGIN { my $f = q%c%s%"SVf"/buildcustomize.pl%c; " 2141 "do {local $!; -f $f }" 2142 " and do $f || die $@ || qq '$f: $!' }", 2143 0, (TAINTING_get ? "./" : ""), SVfARG(*inc0), 0)); 2144 } 2145 # else 2146 /* SITELIB_EXP is a function call on Win32. */ 2147 const char *const raw_sitelib = SITELIB_EXP; 2148 if (raw_sitelib) { 2149 /* process .../.. if PERL_RELOCATABLE_INC is defined */ 2150 SV *sitelib_sv = mayberelocate(raw_sitelib, strlen(raw_sitelib), 2151 INCPUSH_CAN_RELOCATE); 2152 const char *const sitelib = SvPVX(sitelib_sv); 2153 (void)Perl_av_create_and_unshift_one(aTHX_ &PL_preambleav, 2154 Perl_newSVpvf(aTHX_ 2155 "BEGIN { do {local $!; -f q%c%s/sitecustomize.pl%c} && do q%c%s/sitecustomize.pl%c }", 2156 0, SVfARG(sitelib), 0, 2157 0, SVfARG(sitelib), 0)); 2158 assert (SvREFCNT(sitelib_sv) == 1); 2159 SvREFCNT_dec(sitelib_sv); 2160 } 2161 # endif 2162 } 2163 #endif 2164 2165 if (!scriptname) 2166 scriptname = argv[0]; 2167 if (PL_e_script) { 2168 argc++,argv--; 2169 scriptname = BIT_BUCKET; /* don't look for script or read stdin */ 2170 } 2171 else if (scriptname == NULL) { 2172 #ifdef MSDOS 2173 if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) ) 2174 moreswitches("h"); 2175 #endif 2176 scriptname = "-"; 2177 } 2178 2179 assert (!TAINT_get); 2180 init_perllib(); 2181 2182 { 2183 bool suidscript = FALSE; 2184 2185 rsfp = open_script(scriptname, dosearch, &suidscript); 2186 if (!rsfp) { 2187 rsfp = PerlIO_stdin(); 2188 lex_start_flags = LEX_DONT_CLOSE_RSFP; 2189 } 2190 2191 validate_suid(rsfp); 2192 2193 #ifndef PERL_MICRO 2194 # if defined(SIGCHLD) || defined(SIGCLD) 2195 { 2196 # ifndef SIGCHLD 2197 # define SIGCHLD SIGCLD 2198 # endif 2199 Sighandler_t sigstate = rsignal_state(SIGCHLD); 2200 if (sigstate == (Sighandler_t) SIG_IGN) { 2201 Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), 2202 "Can't ignore signal CHLD, forcing to default"); 2203 (void)rsignal(SIGCHLD, (Sighandler_t)SIG_DFL); 2204 } 2205 } 2206 # endif 2207 #endif 2208 2209 if (doextract) { 2210 2211 /* This will croak if suidscript is true, as -x cannot be used with 2212 setuid scripts. */ 2213 forbid_setid('x', suidscript); 2214 /* Hence you can't get here if suidscript is true */ 2215 2216 linestr_sv = newSV_type(SVt_PV); 2217 lex_start_flags |= LEX_START_COPIED; 2218 find_beginning(linestr_sv, rsfp); 2219 if (cddir && PerlDir_chdir( (char *)cddir ) < 0) 2220 Perl_croak(aTHX_ "Can't chdir to %s",cddir); 2221 } 2222 } 2223 2224 PL_main_cv = PL_compcv = MUTABLE_CV(newSV_type(SVt_PVCV)); 2225 CvUNIQUE_on(PL_compcv); 2226 2227 CvPADLIST_set(PL_compcv, pad_new(0)); 2228 2229 PL_isarev = newHV(); 2230 2231 boot_core_PerlIO(); 2232 boot_core_UNIVERSAL(); 2233 boot_core_mro(); 2234 newXS("Internals::V", S_Internals_V, __FILE__); 2235 2236 if (xsinit) 2237 (*xsinit)(aTHX); /* in case linked C routines want magical variables */ 2238 #ifndef PERL_MICRO 2239 #if defined(VMS) || defined(WIN32) || defined(DJGPP) || defined(__CYGWIN__) || defined(SYMBIAN) 2240 init_os_extras(); 2241 #endif 2242 #endif 2243 2244 #ifdef USE_SOCKS 2245 # ifdef HAS_SOCKS5_INIT 2246 socks5_init(argv[0]); 2247 # else 2248 SOCKSinit(argv[0]); 2249 # endif 2250 #endif 2251 2252 init_predump_symbols(); 2253 /* init_postdump_symbols not currently designed to be called */ 2254 /* more than once (ENV isn't cleared first, for example) */ 2255 /* But running with -u leaves %ENV & @ARGV undefined! XXX */ 2256 if (!PL_do_undump) 2257 init_postdump_symbols(argc,argv,env); 2258 2259 /* PL_unicode is turned on by -C, or by $ENV{PERL_UNICODE}, 2260 * or explicitly in some platforms. 2261 * locale.c:Perl_init_i18nl10n() if the environment 2262 * look like the user wants to use UTF-8. */ 2263 #if defined(__SYMBIAN32__) 2264 PL_unicode = PERL_UNICODE_STD_FLAG; /* See PERL_SYMBIAN_CONSOLE_UTF8. */ 2265 #endif 2266 # ifndef PERL_IS_MINIPERL 2267 if (PL_unicode) { 2268 /* Requires init_predump_symbols(). */ 2269 if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) { 2270 IO* io; 2271 PerlIO* fp; 2272 SV* sv; 2273 2274 /* Turn on UTF-8-ness on STDIN, STDOUT, STDERR 2275 * and the default open disciplines. */ 2276 if ((PL_unicode & PERL_UNICODE_STDIN_FLAG) && 2277 PL_stdingv && (io = GvIO(PL_stdingv)) && 2278 (fp = IoIFP(io))) 2279 PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8"); 2280 if ((PL_unicode & PERL_UNICODE_STDOUT_FLAG) && 2281 PL_defoutgv && (io = GvIO(PL_defoutgv)) && 2282 (fp = IoOFP(io))) 2283 PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8"); 2284 if ((PL_unicode & PERL_UNICODE_STDERR_FLAG) && 2285 PL_stderrgv && (io = GvIO(PL_stderrgv)) && 2286 (fp = IoOFP(io))) 2287 PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8"); 2288 if ((PL_unicode & PERL_UNICODE_INOUT_FLAG) && 2289 (sv = GvSV(gv_fetchpvs("\017PEN", GV_ADD|GV_NOTQUAL, 2290 SVt_PV)))) { 2291 U32 in = PL_unicode & PERL_UNICODE_IN_FLAG; 2292 U32 out = PL_unicode & PERL_UNICODE_OUT_FLAG; 2293 if (in) { 2294 if (out) 2295 sv_setpvs(sv, ":utf8\0:utf8"); 2296 else 2297 sv_setpvs(sv, ":utf8\0"); 2298 } 2299 else if (out) 2300 sv_setpvs(sv, "\0:utf8"); 2301 SvSETMAGIC(sv); 2302 } 2303 } 2304 } 2305 #endif 2306 2307 { 2308 const char *s; 2309 if ((s = PerlEnv_getenv("PERL_SIGNALS"))) { 2310 if (strEQ(s, "unsafe")) 2311 PL_signals |= PERL_SIGNALS_UNSAFE_FLAG; 2312 else if (strEQ(s, "safe")) 2313 PL_signals &= ~PERL_SIGNALS_UNSAFE_FLAG; 2314 else 2315 Perl_croak(aTHX_ "PERL_SIGNALS illegal: \"%s\"", s); 2316 } 2317 } 2318 2319 2320 lex_start(linestr_sv, rsfp, lex_start_flags); 2321 SvREFCNT_dec(linestr_sv); 2322 2323 PL_subname = newSVpvs("main"); 2324 2325 if (add_read_e_script) 2326 filter_add(read_e_script, NULL); 2327 2328 /* now parse the script */ 2329 2330 SETERRNO(0,SS_NORMAL); 2331 if (yyparse(GRAMPROG) || PL_parser->error_count) { 2332 if (PL_minus_c) 2333 Perl_croak(aTHX_ "%s had compilation errors.\n", PL_origfilename); 2334 else { 2335 Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n", 2336 PL_origfilename); 2337 } 2338 } 2339 CopLINE_set(PL_curcop, 0); 2340 SET_CURSTASH(PL_defstash); 2341 if (PL_e_script) { 2342 SvREFCNT_dec(PL_e_script); 2343 PL_e_script = NULL; 2344 } 2345 2346 if (PL_do_undump) 2347 my_unexec(); 2348 2349 if (isWARN_ONCE) { 2350 SAVECOPFILE(PL_curcop); 2351 SAVECOPLINE(PL_curcop); 2352 gv_check(PL_defstash); 2353 } 2354 2355 LEAVE; 2356 FREETMPS; 2357 2358 #ifdef MYMALLOC 2359 { 2360 const char *s; 2361 UV uv; 2362 s = PerlEnv_getenv("PERL_DEBUG_MSTATS"); 2363 if (s && grok_atoUV(s, &uv, NULL) && uv >= 2) 2364 dump_mstats("after compilation:"); 2365 } 2366 #endif 2367 2368 ENTER; 2369 PL_restartjmpenv = NULL; 2370 PL_restartop = 0; 2371 return NULL; 2372 } 2373 2374 /* 2375 =for apidoc perl_run 2376 2377 Tells a Perl interpreter to run. See L<perlembed>. 2378 2379 =cut 2380 */ 2381 2382 int 2383 perl_run(pTHXx) 2384 { 2385 I32 oldscope; 2386 int ret = 0; 2387 dJMPENV; 2388 2389 PERL_ARGS_ASSERT_PERL_RUN; 2390 #ifndef MULTIPLICITY 2391 PERL_UNUSED_ARG(my_perl); 2392 #endif 2393 2394 oldscope = PL_scopestack_ix; 2395 #ifdef VMS 2396 VMSISH_HUSHED = 0; 2397 #endif 2398 2399 JMPENV_PUSH(ret); 2400 switch (ret) { 2401 case 1: 2402 cxstack_ix = -1; /* start context stack again */ 2403 goto redo_body; 2404 case 0: /* normal completion */ 2405 redo_body: 2406 run_body(oldscope); 2407 /* FALLTHROUGH */ 2408 case 2: /* my_exit() */ 2409 while (PL_scopestack_ix > oldscope) 2410 LEAVE; 2411 FREETMPS; 2412 SET_CURSTASH(PL_defstash); 2413 if (!(PL_exit_flags & PERL_EXIT_DESTRUCT_END) && 2414 PL_endav && !PL_minus_c) { 2415 PERL_SET_PHASE(PERL_PHASE_END); 2416 call_list(oldscope, PL_endav); 2417 } 2418 #ifdef MYMALLOC 2419 if (PerlEnv_getenv("PERL_DEBUG_MSTATS")) 2420 dump_mstats("after execution: "); 2421 #endif 2422 ret = STATUS_EXIT; 2423 break; 2424 case 3: 2425 if (PL_restartop) { 2426 POPSTACK_TO(PL_mainstack); 2427 goto redo_body; 2428 } 2429 PerlIO_printf(Perl_error_log, "panic: restartop in perl_run\n"); 2430 FREETMPS; 2431 ret = 1; 2432 break; 2433 } 2434 2435 JMPENV_POP; 2436 return ret; 2437 } 2438 2439 STATIC void 2440 S_run_body(pTHX_ I32 oldscope) 2441 { 2442 DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support (0x%x).\n", 2443 PL_sawampersand ? "Enabling" : "Omitting", 2444 (unsigned int)(PL_sawampersand))); 2445 2446 if (!PL_restartop) { 2447 #ifdef DEBUGGING 2448 if (DEBUG_x_TEST || DEBUG_B_TEST) 2449 dump_all_perl(!DEBUG_B_TEST); 2450 if (!DEBUG_q_TEST) 2451 PERL_DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n")); 2452 #endif 2453 2454 if (PL_minus_c) { 2455 PerlIO_printf(Perl_error_log, "%s syntax OK\n", PL_origfilename); 2456 my_exit(0); 2457 } 2458 if (PERLDB_SINGLE && PL_DBsingle) 2459 PL_DBsingle_iv = 1; 2460 if (PL_initav) { 2461 PERL_SET_PHASE(PERL_PHASE_INIT); 2462 call_list(oldscope, PL_initav); 2463 } 2464 #ifdef PERL_DEBUG_READONLY_OPS 2465 if (PL_main_root && PL_main_root->op_slabbed) 2466 Slab_to_ro(OpSLAB(PL_main_root)); 2467 #endif 2468 } 2469 2470 /* do it */ 2471 2472 PERL_SET_PHASE(PERL_PHASE_RUN); 2473 2474 if (PL_restartop) { 2475 PL_restartjmpenv = NULL; 2476 PL_op = PL_restartop; 2477 PL_restartop = 0; 2478 CALLRUNOPS(aTHX); 2479 } 2480 else if (PL_main_start) { 2481 CvDEPTH(PL_main_cv) = 1; 2482 PL_op = PL_main_start; 2483 CALLRUNOPS(aTHX); 2484 } 2485 my_exit(0); 2486 NOT_REACHED; /* NOTREACHED */ 2487 } 2488 2489 /* 2490 =head1 SV Manipulation Functions 2491 2492 =for apidoc p||get_sv 2493 2494 Returns the SV of the specified Perl scalar. C<flags> are passed to 2495 C<gv_fetchpv>. If C<GV_ADD> is set and the 2496 Perl variable does not exist then it will be created. If C<flags> is zero 2497 and the variable does not exist then NULL is returned. 2498 2499 =cut 2500 */ 2501 2502 SV* 2503 Perl_get_sv(pTHX_ const char *name, I32 flags) 2504 { 2505 GV *gv; 2506 2507 PERL_ARGS_ASSERT_GET_SV; 2508 2509 gv = gv_fetchpv(name, flags, SVt_PV); 2510 if (gv) 2511 return GvSV(gv); 2512 return NULL; 2513 } 2514 2515 /* 2516 =head1 Array Manipulation Functions 2517 2518 =for apidoc p||get_av 2519 2520 Returns the AV of the specified Perl global or package array with the given 2521 name (so it won't work on lexical variables). C<flags> are passed 2522 to C<gv_fetchpv>. If C<GV_ADD> is set and the 2523 Perl variable does not exist then it will be created. If C<flags> is zero 2524 and the variable does not exist then NULL is returned. 2525 2526 Perl equivalent: C<@{"$name"}>. 2527 2528 =cut 2529 */ 2530 2531 AV* 2532 Perl_get_av(pTHX_ const char *name, I32 flags) 2533 { 2534 GV* const gv = gv_fetchpv(name, flags, SVt_PVAV); 2535 2536 PERL_ARGS_ASSERT_GET_AV; 2537 2538 if (flags) 2539 return GvAVn(gv); 2540 if (gv) 2541 return GvAV(gv); 2542 return NULL; 2543 } 2544 2545 /* 2546 =head1 Hash Manipulation Functions 2547 2548 =for apidoc p||get_hv 2549 2550 Returns the HV of the specified Perl hash. C<flags> are passed to 2551 C<gv_fetchpv>. If C<GV_ADD> is set and the 2552 Perl variable does not exist then it will be created. If C<flags> is zero 2553 and the variable does not exist then C<NULL> is returned. 2554 2555 =cut 2556 */ 2557 2558 HV* 2559 Perl_get_hv(pTHX_ const char *name, I32 flags) 2560 { 2561 GV* const gv = gv_fetchpv(name, flags, SVt_PVHV); 2562 2563 PERL_ARGS_ASSERT_GET_HV; 2564 2565 if (flags) 2566 return GvHVn(gv); 2567 if (gv) 2568 return GvHV(gv); 2569 return NULL; 2570 } 2571 2572 /* 2573 =head1 CV Manipulation Functions 2574 2575 =for apidoc p||get_cvn_flags 2576 2577 Returns the CV of the specified Perl subroutine. C<flags> are passed to 2578 C<gv_fetchpvn_flags>. If C<GV_ADD> is set and the Perl subroutine does not 2579 exist then it will be declared (which has the same effect as saying 2580 C<sub name;>). If C<GV_ADD> is not set and the subroutine does not exist 2581 then NULL is returned. 2582 2583 =for apidoc p||get_cv 2584 2585 Uses C<strlen> to get the length of C<name>, then calls C<get_cvn_flags>. 2586 2587 =cut 2588 */ 2589 2590 CV* 2591 Perl_get_cvn_flags(pTHX_ const char *name, STRLEN len, I32 flags) 2592 { 2593 GV* const gv = gv_fetchpvn_flags(name, len, flags, SVt_PVCV); 2594 2595 PERL_ARGS_ASSERT_GET_CVN_FLAGS; 2596 2597 /* XXX this is probably not what they think they're getting. 2598 * It has the same effect as "sub name;", i.e. just a forward 2599 * declaration! */ 2600 if ((flags & ~GV_NOADD_MASK) && !GvCVu(gv)) { 2601 return newSTUB(gv,0); 2602 } 2603 if (gv) 2604 return GvCVu(gv); 2605 return NULL; 2606 } 2607 2608 /* Nothing in core calls this now, but we can't replace it with a macro and 2609 move it to mathoms.c as a macro would evaluate name twice. */ 2610 CV* 2611 Perl_get_cv(pTHX_ const char *name, I32 flags) 2612 { 2613 PERL_ARGS_ASSERT_GET_CV; 2614 2615 return get_cvn_flags(name, strlen(name), flags); 2616 } 2617 2618 /* Be sure to refetch the stack pointer after calling these routines. */ 2619 2620 /* 2621 2622 =head1 Callback Functions 2623 2624 =for apidoc p||call_argv 2625 2626 Performs a callback to the specified named and package-scoped Perl subroutine 2627 with C<argv> (a C<NULL>-terminated array of strings) as arguments. See 2628 L<perlcall>. 2629 2630 Approximate Perl equivalent: C<&{"$sub_name"}(@$argv)>. 2631 2632 =cut 2633 */ 2634 2635 I32 2636 Perl_call_argv(pTHX_ const char *sub_name, I32 flags, char **argv) 2637 2638 /* See G_* flags in cop.h */ 2639 /* null terminated arg list */ 2640 { 2641 dSP; 2642 2643 PERL_ARGS_ASSERT_CALL_ARGV; 2644 2645 PUSHMARK(SP); 2646 while (*argv) { 2647 mXPUSHs(newSVpv(*argv,0)); 2648 argv++; 2649 } 2650 PUTBACK; 2651 return call_pv(sub_name, flags); 2652 } 2653 2654 /* 2655 =for apidoc p||call_pv 2656 2657 Performs a callback to the specified Perl sub. See L<perlcall>. 2658 2659 =cut 2660 */ 2661 2662 I32 2663 Perl_call_pv(pTHX_ const char *sub_name, I32 flags) 2664 /* name of the subroutine */ 2665 /* See G_* flags in cop.h */ 2666 { 2667 PERL_ARGS_ASSERT_CALL_PV; 2668 2669 return call_sv(MUTABLE_SV(get_cv(sub_name, GV_ADD)), flags); 2670 } 2671 2672 /* 2673 =for apidoc p||call_method 2674 2675 Performs a callback to the specified Perl method. The blessed object must 2676 be on the stack. See L<perlcall>. 2677 2678 =cut 2679 */ 2680 2681 I32 2682 Perl_call_method(pTHX_ const char *methname, I32 flags) 2683 /* name of the subroutine */ 2684 /* See G_* flags in cop.h */ 2685 { 2686 STRLEN len; 2687 SV* sv; 2688 PERL_ARGS_ASSERT_CALL_METHOD; 2689 2690 len = strlen(methname); 2691 sv = flags & G_METHOD_NAMED 2692 ? sv_2mortal(newSVpvn_share(methname, len,0)) 2693 : newSVpvn_flags(methname, len, SVs_TEMP); 2694 2695 return call_sv(sv, flags | G_METHOD); 2696 } 2697 2698 /* May be called with any of a CV, a GV, or an SV containing the name. */ 2699 /* 2700 =for apidoc p||call_sv 2701 2702 Performs a callback to the Perl sub specified by the SV. 2703 2704 If neither the C<G_METHOD> nor C<G_METHOD_NAMED> flag is supplied, the 2705 SV may be any of a CV, a GV, a reference to a CV, a reference to a GV 2706 or C<SvPV(sv)> will be used as the name of the sub to call. 2707 2708 If the C<G_METHOD> flag is supplied, the SV may be a reference to a CV or 2709 C<SvPV(sv)> will be used as the name of the method to call. 2710 2711 If the C<G_METHOD_NAMED> flag is supplied, C<SvPV(sv)> will be used as 2712 the name of the method to call. 2713 2714 Some other values are treated specially for internal use and should 2715 not be depended on. 2716 2717 See L<perlcall>. 2718 2719 =cut 2720 */ 2721 2722 I32 2723 Perl_call_sv(pTHX_ SV *sv, VOL I32 flags) 2724 /* See G_* flags in cop.h */ 2725 { 2726 dVAR; 2727 LOGOP myop; /* fake syntax tree node */ 2728 METHOP method_op; 2729 I32 oldmark; 2730 VOL I32 retval = 0; 2731 bool oldcatch = CATCH_GET; 2732 int ret; 2733 OP* const oldop = PL_op; 2734 dJMPENV; 2735 2736 PERL_ARGS_ASSERT_CALL_SV; 2737 2738 if (flags & G_DISCARD) { 2739 ENTER; 2740 SAVETMPS; 2741 } 2742 if (!(flags & G_WANT)) { 2743 /* Backwards compatibility - as G_SCALAR was 0, it could be omitted. 2744 */ 2745 flags |= G_SCALAR; 2746 } 2747 2748 Zero(&myop, 1, LOGOP); 2749 if (!(flags & G_NOARGS)) 2750 myop.op_flags |= OPf_STACKED; 2751 myop.op_flags |= OP_GIMME_REVERSE(flags); 2752 SAVEOP(); 2753 PL_op = (OP*)&myop; 2754 2755 if (!(flags & G_METHOD_NAMED)) { 2756 dSP; 2757 EXTEND(SP, 1); 2758 PUSHs(sv); 2759 PUTBACK; 2760 } 2761 oldmark = TOPMARK; 2762 2763 if (PERLDB_SUB && PL_curstash != PL_debstash 2764 /* Handle first BEGIN of -d. */ 2765 && (PL_DBcv || (PL_DBcv = GvCV(PL_DBsub))) 2766 /* Try harder, since this may have been a sighandler, thus 2767 * curstash may be meaningless. */ 2768 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((const CV *)sv) != PL_debstash) 2769 && !(flags & G_NODEBUG)) 2770 myop.op_private |= OPpENTERSUB_DB; 2771 2772 if (flags & (G_METHOD|G_METHOD_NAMED)) { 2773 Zero(&method_op, 1, METHOP); 2774 method_op.op_next = (OP*)&myop; 2775 PL_op = (OP*)&method_op; 2776 if ( flags & G_METHOD_NAMED ) { 2777 method_op.op_ppaddr = PL_ppaddr[OP_METHOD_NAMED]; 2778 method_op.op_type = OP_METHOD_NAMED; 2779 method_op.op_u.op_meth_sv = sv; 2780 } else { 2781 method_op.op_ppaddr = PL_ppaddr[OP_METHOD]; 2782 method_op.op_type = OP_METHOD; 2783 } 2784 myop.op_ppaddr = PL_ppaddr[OP_ENTERSUB]; 2785 myop.op_type = OP_ENTERSUB; 2786 } 2787 2788 if (!(flags & G_EVAL)) { 2789 CATCH_SET(TRUE); 2790 CALL_BODY_SUB((OP*)&myop); 2791 retval = PL_stack_sp - (PL_stack_base + oldmark); 2792 CATCH_SET(oldcatch); 2793 } 2794 else { 2795 I32 old_cxix; 2796 myop.op_other = (OP*)&myop; 2797 (void)POPMARK; 2798 old_cxix = cxstack_ix; 2799 create_eval_scope(NULL, flags|G_FAKINGEVAL); 2800 (void)INCMARK; 2801 2802 JMPENV_PUSH(ret); 2803 2804 switch (ret) { 2805 case 0: 2806 redo_body: 2807 CALL_BODY_SUB((OP*)&myop); 2808 retval = PL_stack_sp - (PL_stack_base + oldmark); 2809 if (!(flags & G_KEEPERR)) { 2810 CLEAR_ERRSV(); 2811 } 2812 break; 2813 case 1: 2814 STATUS_ALL_FAILURE; 2815 /* FALLTHROUGH */ 2816 case 2: 2817 /* my_exit() was called */ 2818 SET_CURSTASH(PL_defstash); 2819 FREETMPS; 2820 JMPENV_POP; 2821 my_exit_jump(); 2822 NOT_REACHED; /* NOTREACHED */ 2823 case 3: 2824 if (PL_restartop) { 2825 PL_restartjmpenv = NULL; 2826 PL_op = PL_restartop; 2827 PL_restartop = 0; 2828 goto redo_body; 2829 } 2830 PL_stack_sp = PL_stack_base + oldmark; 2831 if ((flags & G_WANT) == G_ARRAY) 2832 retval = 0; 2833 else { 2834 retval = 1; 2835 *++PL_stack_sp = &PL_sv_undef; 2836 } 2837 break; 2838 } 2839 2840 /* if we croaked, depending on how we croaked the eval scope 2841 * may or may not have already been popped */ 2842 if (cxstack_ix > old_cxix) { 2843 assert(cxstack_ix == old_cxix + 1); 2844 assert(CxTYPE(CX_CUR()) == CXt_EVAL); 2845 delete_eval_scope(); 2846 } 2847 JMPENV_POP; 2848 } 2849 2850 if (flags & G_DISCARD) { 2851 PL_stack_sp = PL_stack_base + oldmark; 2852 retval = 0; 2853 FREETMPS; 2854 LEAVE; 2855 } 2856 PL_op = oldop; 2857 return retval; 2858 } 2859 2860 /* Eval a string. The G_EVAL flag is always assumed. */ 2861 2862 /* 2863 =for apidoc p||eval_sv 2864 2865 Tells Perl to C<eval> the string in the SV. It supports the same flags 2866 as C<call_sv>, with the obvious exception of C<G_EVAL>. See L<perlcall>. 2867 2868 =cut 2869 */ 2870 2871 I32 2872 Perl_eval_sv(pTHX_ SV *sv, I32 flags) 2873 2874 /* See G_* flags in cop.h */ 2875 { 2876 dVAR; 2877 UNOP myop; /* fake syntax tree node */ 2878 VOL I32 oldmark; 2879 VOL I32 retval = 0; 2880 int ret; 2881 OP* const oldop = PL_op; 2882 dJMPENV; 2883 2884 PERL_ARGS_ASSERT_EVAL_SV; 2885 2886 if (flags & G_DISCARD) { 2887 ENTER; 2888 SAVETMPS; 2889 } 2890 2891 SAVEOP(); 2892 PL_op = (OP*)&myop; 2893 Zero(&myop, 1, UNOP); 2894 { 2895 dSP; 2896 oldmark = SP - PL_stack_base; 2897 EXTEND(SP, 1); 2898 PUSHs(sv); 2899 PUTBACK; 2900 } 2901 2902 if (!(flags & G_NOARGS)) 2903 myop.op_flags = OPf_STACKED; 2904 myop.op_type = OP_ENTEREVAL; 2905 myop.op_flags |= OP_GIMME_REVERSE(flags); 2906 if (flags & G_KEEPERR) 2907 myop.op_flags |= OPf_SPECIAL; 2908 2909 if (flags & G_RE_REPARSING) 2910 myop.op_private = (OPpEVAL_COPHH | OPpEVAL_RE_REPARSING); 2911 2912 /* fail now; otherwise we could fail after the JMPENV_PUSH but 2913 * before a cx_pusheval(), which corrupts the stack after a croak */ 2914 TAINT_PROPER("eval_sv()"); 2915 2916 JMPENV_PUSH(ret); 2917 switch (ret) { 2918 case 0: 2919 redo_body: 2920 if (PL_op == (OP*)(&myop)) { 2921 PL_op = PL_ppaddr[OP_ENTEREVAL](aTHX); 2922 if (!PL_op) 2923 goto fail; /* failed in compilation */ 2924 } 2925 CALLRUNOPS(aTHX); 2926 retval = PL_stack_sp - (PL_stack_base + oldmark); 2927 if (!(flags & G_KEEPERR)) { 2928 CLEAR_ERRSV(); 2929 } 2930 break; 2931 case 1: 2932 STATUS_ALL_FAILURE; 2933 /* FALLTHROUGH */ 2934 case 2: 2935 /* my_exit() was called */ 2936 SET_CURSTASH(PL_defstash); 2937 FREETMPS; 2938 JMPENV_POP; 2939 my_exit_jump(); 2940 NOT_REACHED; /* NOTREACHED */ 2941 case 3: 2942 if (PL_restartop) { 2943 PL_restartjmpenv = NULL; 2944 PL_op = PL_restartop; 2945 PL_restartop = 0; 2946 goto redo_body; 2947 } 2948 fail: 2949 PL_stack_sp = PL_stack_base + oldmark; 2950 if ((flags & G_WANT) == G_ARRAY) 2951 retval = 0; 2952 else { 2953 retval = 1; 2954 *++PL_stack_sp = &PL_sv_undef; 2955 } 2956 break; 2957 } 2958 2959 JMPENV_POP; 2960 if (flags & G_DISCARD) { 2961 PL_stack_sp = PL_stack_base + oldmark; 2962 retval = 0; 2963 FREETMPS; 2964 LEAVE; 2965 } 2966 PL_op = oldop; 2967 return retval; 2968 } 2969 2970 /* 2971 =for apidoc p||eval_pv 2972 2973 Tells Perl to C<eval> the given string in scalar context and return an SV* result. 2974 2975 =cut 2976 */ 2977 2978 SV* 2979 Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error) 2980 { 2981 SV* sv = newSVpv(p, 0); 2982 2983 PERL_ARGS_ASSERT_EVAL_PV; 2984 2985 eval_sv(sv, G_SCALAR); 2986 SvREFCNT_dec(sv); 2987 2988 { 2989 dSP; 2990 sv = POPs; 2991 PUTBACK; 2992 } 2993 2994 /* just check empty string or undef? */ 2995 if (croak_on_error) { 2996 SV * const errsv = ERRSV; 2997 if(SvTRUE_NN(errsv)) 2998 /* replace with croak_sv? */ 2999 Perl_croak_nocontext("%s", SvPV_nolen_const(errsv)); 3000 } 3001 3002 return sv; 3003 } 3004 3005 /* Require a module. */ 3006 3007 /* 3008 =head1 Embedding Functions 3009 3010 =for apidoc p||require_pv 3011 3012 Tells Perl to C<require> the file named by the string argument. It is 3013 analogous to the Perl code C<eval "require '$file'">. It's even 3014 implemented that way; consider using load_module instead. 3015 3016 =cut */ 3017 3018 void 3019 Perl_require_pv(pTHX_ const char *pv) 3020 { 3021 dSP; 3022 SV* sv; 3023 3024 PERL_ARGS_ASSERT_REQUIRE_PV; 3025 3026 PUSHSTACKi(PERLSI_REQUIRE); 3027 sv = Perl_newSVpvf(aTHX_ "require q%c%s%c", 0, pv, 0); 3028 eval_sv(sv_2mortal(sv), G_DISCARD); 3029 POPSTACK; 3030 } 3031 3032 STATIC void 3033 S_usage(pTHX) /* XXX move this out into a module ? */ 3034 { 3035 /* This message really ought to be max 23 lines. 3036 * Removed -h because the user already knows that option. Others? */ 3037 3038 /* Grouped as 6 lines per C string literal, to keep under the ANSI C 89 3039 minimum of 509 character string literals. */ 3040 static const char * const usage_msg[] = { 3041 " -0[octal] specify record separator (\\0, if no argument)\n" 3042 " -a autosplit mode with -n or -p (splits $_ into @F)\n" 3043 " -C[number/list] enables the listed Unicode features\n" 3044 " -c check syntax only (runs BEGIN and CHECK blocks)\n" 3045 " -d[:debugger] run program under debugger\n" 3046 " -D[number/list] set debugging flags (argument is a bit mask or alphabets)\n", 3047 " -e program one line of program (several -e's allowed, omit programfile)\n" 3048 " -E program like -e, but enables all optional features\n" 3049 " -f don't do $sitelib/sitecustomize.pl at startup\n" 3050 " -F/pattern/ split() pattern for -a switch (//'s are optional)\n" 3051 " -i[extension] edit <> files in place (makes backup if extension supplied)\n" 3052 " -Idirectory specify @INC/#include directory (several -I's allowed)\n", 3053 " -l[octal] enable line ending processing, specifies line terminator\n" 3054 " -[mM][-]module execute \"use/no module...\" before executing program\n" 3055 " -n assume \"while (<>) { ... }\" loop around program\n" 3056 " -p assume loop like -n but print line also, like sed\n" 3057 " -s enable rudimentary parsing for switches after programfile\n" 3058 " -S look for programfile using PATH environment variable\n", 3059 " -t enable tainting warnings\n" 3060 " -T enable tainting checks\n" 3061 " -u dump core after parsing program\n" 3062 " -U allow unsafe operations\n" 3063 " -v print version, patchlevel and license\n" 3064 " -V[:variable] print configuration summary (or a single Config.pm variable)\n", 3065 " -w enable many useful warnings\n" 3066 " -W enable all warnings\n" 3067 " -x[directory] ignore text before #!perl line (optionally cd to directory)\n" 3068 " -X disable all warnings\n" 3069 " \n" 3070 "Run 'perldoc perl' for more help with Perl.\n\n", 3071 NULL 3072 }; 3073 const char * const *p = usage_msg; 3074 PerlIO *out = PerlIO_stdout(); 3075 3076 PerlIO_printf(out, 3077 "\nUsage: %s [switches] [--] [programfile] [arguments]\n", 3078 PL_origargv[0]); 3079 while (*p) 3080 PerlIO_puts(out, *p++); 3081 my_exit(0); 3082 } 3083 3084 /* convert a string of -D options (or digits) into an int. 3085 * sets *s to point to the char after the options */ 3086 3087 #ifdef DEBUGGING 3088 int 3089 Perl_get_debug_opts(pTHX_ const char **s, bool givehelp) 3090 { 3091 static const char * const usage_msgd[] = { 3092 " Debugging flag values: (see also -d)\n" 3093 " p Tokenizing and parsing (with v, displays parse stack)\n" 3094 " s Stack snapshots (with v, displays all stacks)\n" 3095 " l Context (loop) stack processing\n" 3096 " t Trace execution\n" 3097 " o Method and overloading resolution\n", 3098 " c String/numeric conversions\n" 3099 " P Print profiling info, source file input state\n" 3100 " m Memory and SV allocation\n" 3101 " f Format processing\n" 3102 " r Regular expression parsing and execution\n" 3103 " x Syntax tree dump\n", 3104 " u Tainting checks\n" 3105 " H Hash dump -- usurps values()\n" 3106 " X Scratchpad allocation\n" 3107 " D Cleaning up\n" 3108 " S Op slab allocation\n" 3109 " T Tokenising\n" 3110 " R Include reference counts of dumped variables (eg when using -Ds)\n", 3111 " J Do not s,t,P-debug (Jump over) opcodes within package DB\n" 3112 " v Verbose: use in conjunction with other flags\n" 3113 " C Copy On Write\n" 3114 " A Consistency checks on internal structures\n" 3115 " q quiet - currently only suppresses the 'EXECUTING' message\n" 3116 " M trace smart match resolution\n" 3117 " B dump suBroutine definitions, including special Blocks like BEGIN\n", 3118 " L trace some locale setting information--for Perl core development\n", 3119 " i trace PerlIO layer processing\n", 3120 NULL 3121 }; 3122 UV uv = 0; 3123 3124 PERL_ARGS_ASSERT_GET_DEBUG_OPTS; 3125 3126 if (isALPHA(**s)) { 3127 /* if adding extra options, remember to update DEBUG_MASK */ 3128 static const char debopts[] = "psltocPmfrxuUHXDSTRJvCAqMBLi"; 3129 3130 for (; isWORDCHAR(**s); (*s)++) { 3131 const char * const d = strchr(debopts,**s); 3132 if (d) 3133 uv |= 1 << (d - debopts); 3134 else if (ckWARN_d(WARN_DEBUGGING)) 3135 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING), 3136 "invalid option -D%c, use -D'' to see choices\n", **s); 3137 } 3138 } 3139 else if (isDIGIT(**s)) { 3140 const char* e; 3141 if (grok_atoUV(*s, &uv, &e)) 3142 *s = e; 3143 for (; isWORDCHAR(**s); (*s)++) ; 3144 } 3145 else if (givehelp) { 3146 const char *const *p = usage_msgd; 3147 while (*p) PerlIO_puts(PerlIO_stdout(), *p++); 3148 } 3149 return (int)uv; /* ignore any UV->int conversion loss */ 3150 } 3151 #endif 3152 3153 /* This routine handles any switches that can be given during run */ 3154 3155 const char * 3156 Perl_moreswitches(pTHX_ const char *s) 3157 { 3158 dVAR; 3159 UV rschar; 3160 const char option = *s; /* used to remember option in -m/-M code */ 3161 3162 PERL_ARGS_ASSERT_MORESWITCHES; 3163 3164 switch (*s) { 3165 case '0': 3166 { 3167 I32 flags = 0; 3168 STRLEN numlen; 3169 3170 SvREFCNT_dec(PL_rs); 3171 if (s[1] == 'x' && s[2]) { 3172 const char *e = s+=2; 3173 U8 *tmps; 3174 3175 while (*e) 3176 e++; 3177 numlen = e - s; 3178 flags = PERL_SCAN_SILENT_ILLDIGIT; 3179 rschar = (U32)grok_hex(s, &numlen, &flags, NULL); 3180 if (s + numlen < e) { 3181 rschar = 0; /* Grandfather -0xFOO as -0 -xFOO. */ 3182 numlen = 0; 3183 s--; 3184 } 3185 PL_rs = newSVpvs(""); 3186 SvGROW(PL_rs, (STRLEN)(UVCHR_SKIP(rschar) + 1)); 3187 tmps = (U8*)SvPVX(PL_rs); 3188 uvchr_to_utf8(tmps, rschar); 3189 SvCUR_set(PL_rs, UVCHR_SKIP(rschar)); 3190 SvUTF8_on(PL_rs); 3191 } 3192 else { 3193 numlen = 4; 3194 rschar = (U32)grok_oct(s, &numlen, &flags, NULL); 3195 if (rschar & ~((U8)~0)) 3196 PL_rs = &PL_sv_undef; 3197 else if (!rschar && numlen >= 2) 3198 PL_rs = newSVpvs(""); 3199 else { 3200 char ch = (char)rschar; 3201 PL_rs = newSVpvn(&ch, 1); 3202 } 3203 } 3204 sv_setsv(get_sv("/", GV_ADD), PL_rs); 3205 return s + numlen; 3206 } 3207 case 'C': 3208 s++; 3209 PL_unicode = parse_unicode_opts( (const char **)&s ); 3210 if (PL_unicode & PERL_UNICODE_UTF8CACHEASSERT_FLAG) 3211 PL_utf8cache = -1; 3212 return s; 3213 case 'F': 3214 PL_minus_a = TRUE; 3215 PL_minus_F = TRUE; 3216 PL_minus_n = TRUE; 3217 PL_splitstr = ++s; 3218 while (*s && !isSPACE(*s)) ++s; 3219 PL_splitstr = savepvn(PL_splitstr, s - PL_splitstr); 3220 return s; 3221 case 'a': 3222 PL_minus_a = TRUE; 3223 PL_minus_n = TRUE; 3224 s++; 3225 return s; 3226 case 'c': 3227 PL_minus_c = TRUE; 3228 s++; 3229 return s; 3230 case 'd': 3231 forbid_setid('d', FALSE); 3232 s++; 3233 3234 /* -dt indicates to the debugger that threads will be used */ 3235 if (*s == 't' && !isWORDCHAR(s[1])) { 3236 ++s; 3237 my_setenv("PERL5DB_THREADED", "1"); 3238 } 3239 3240 /* The following permits -d:Mod to accepts arguments following an = 3241 in the fashion that -MSome::Mod does. */ 3242 if (*s == ':' || *s == '=') { 3243 const char *start; 3244 const char *end; 3245 SV *sv; 3246 3247 if (*++s == '-') { 3248 ++s; 3249 sv = newSVpvs("no Devel::"); 3250 } else { 3251 sv = newSVpvs("use Devel::"); 3252 } 3253 3254 start = s; 3255 end = s + strlen(s); 3256 3257 /* We now allow -d:Module=Foo,Bar and -d:-Module */ 3258 while(isWORDCHAR(*s) || *s==':') ++s; 3259 if (*s != '=') 3260 sv_catpvn(sv, start, end - start); 3261 else { 3262 sv_catpvn(sv, start, s-start); 3263 /* Don't use NUL as q// delimiter here, this string goes in the 3264 * environment. */ 3265 Perl_sv_catpvf(aTHX_ sv, " split(/,/,q{%s});", ++s); 3266 } 3267 s = end; 3268 my_setenv("PERL5DB", SvPV_nolen_const(sv)); 3269 SvREFCNT_dec(sv); 3270 } 3271 if (!PL_perldb) { 3272 PL_perldb = PERLDB_ALL; 3273 init_debugger(); 3274 } 3275 return s; 3276 case 'D': 3277 { 3278 #ifdef DEBUGGING 3279 forbid_setid('D', FALSE); 3280 s++; 3281 PL_debug = get_debug_opts( (const char **)&s, 1) | DEBUG_TOP_FLAG; 3282 #else /* !DEBUGGING */ 3283 if (ckWARN_d(WARN_DEBUGGING)) 3284 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING), 3285 "Recompile perl with -DDEBUGGING to use -D switch (did you mean -d ?)\n"); 3286 for (s++; isWORDCHAR(*s); s++) ; 3287 #endif 3288 return s; 3289 NOT_REACHED; /* NOTREACHED */ 3290 } 3291 case 'h': 3292 usage(); 3293 NOT_REACHED; /* NOTREACHED */ 3294 3295 case 'i': 3296 Safefree(PL_inplace); 3297 #if defined(__CYGWIN__) /* do backup extension automagically */ 3298 if (*(s+1) == '\0') { 3299 PL_inplace = savepvs(".bak"); 3300 return s+1; 3301 } 3302 #endif /* __CYGWIN__ */ 3303 { 3304 const char * const start = ++s; 3305 while (*s && !isSPACE(*s)) 3306 ++s; 3307 3308 PL_inplace = savepvn(start, s - start); 3309 } 3310 if (*s) { 3311 ++s; 3312 if (*s == '-') /* Additional switches on #! line. */ 3313 s++; 3314 } 3315 return s; 3316 case 'I': /* -I handled both here and in parse_body() */ 3317 forbid_setid('I', FALSE); 3318 ++s; 3319 while (*s && isSPACE(*s)) 3320 ++s; 3321 if (*s) { 3322 const char *e, *p; 3323 p = s; 3324 /* ignore trailing spaces (possibly followed by other switches) */ 3325 do { 3326 for (e = p; *e && !isSPACE(*e); e++) ; 3327 p = e; 3328 while (isSPACE(*p)) 3329 p++; 3330 } while (*p && *p != '-'); 3331 incpush(s, e-s, 3332 INCPUSH_ADD_SUB_DIRS|INCPUSH_ADD_OLD_VERS|INCPUSH_UNSHIFT); 3333 s = p; 3334 if (*s == '-') 3335 s++; 3336 } 3337 else 3338 Perl_croak(aTHX_ "No directory specified for -I"); 3339 return s; 3340 case 'l': 3341 PL_minus_l = TRUE; 3342 s++; 3343 if (PL_ors_sv) { 3344 SvREFCNT_dec(PL_ors_sv); 3345 PL_ors_sv = NULL; 3346 } 3347 if (isDIGIT(*s)) { 3348 I32 flags = 0; 3349 STRLEN numlen; 3350 PL_ors_sv = newSVpvs("\n"); 3351 numlen = 3 + (*s == '0'); 3352 *SvPVX(PL_ors_sv) = (char)grok_oct(s, &numlen, &flags, NULL); 3353 s += numlen; 3354 } 3355 else { 3356 if (RsPARA(PL_rs)) { 3357 PL_ors_sv = newSVpvs("\n\n"); 3358 } 3359 else { 3360 PL_ors_sv = newSVsv(PL_rs); 3361 } 3362 } 3363 return s; 3364 case 'M': 3365 forbid_setid('M', FALSE); /* XXX ? */ 3366 /* FALLTHROUGH */ 3367 case 'm': 3368 forbid_setid('m', FALSE); /* XXX ? */ 3369 if (*++s) { 3370 const char *start; 3371 const char *end; 3372 SV *sv; 3373 const char *use = "use "; 3374 bool colon = FALSE; 3375 /* -M-foo == 'no foo' */ 3376 /* Leading space on " no " is deliberate, to make both 3377 possibilities the same length. */ 3378 if (*s == '-') { use = " no "; ++s; } 3379 sv = newSVpvn(use,4); 3380 start = s; 3381 /* We allow -M'Module qw(Foo Bar)' */ 3382 while(isWORDCHAR(*s) || *s==':') { 3383 if( *s++ == ':' ) { 3384 if( *s == ':' ) 3385 s++; 3386 else 3387 colon = TRUE; 3388 } 3389 } 3390 if (s == start) 3391 Perl_croak(aTHX_ "Module name required with -%c option", 3392 option); 3393 if (colon) 3394 Perl_croak(aTHX_ "Invalid module name %.*s with -%c option: " 3395 "contains single ':'", 3396 (int)(s - start), start, option); 3397 end = s + strlen(s); 3398 if (*s != '=') { 3399 sv_catpvn(sv, start, end - start); 3400 if (option == 'm') { 3401 if (*s != '\0') 3402 Perl_croak(aTHX_ "Can't use '%c' after -mname", *s); 3403 sv_catpvs( sv, " ()"); 3404 } 3405 } else { 3406 sv_catpvn(sv, start, s-start); 3407 /* Use NUL as q''-delimiter. */ 3408 sv_catpvs(sv, " split(/,/,q\0"); 3409 ++s; 3410 sv_catpvn(sv, s, end - s); 3411 sv_catpvs(sv, "\0)"); 3412 } 3413 s = end; 3414 Perl_av_create_and_push(aTHX_ &PL_preambleav, sv); 3415 } 3416 else 3417 Perl_croak(aTHX_ "Missing argument to -%c", option); 3418 return s; 3419 case 'n': 3420 PL_minus_n = TRUE; 3421 s++; 3422 return s; 3423 case 'p': 3424 PL_minus_p = TRUE; 3425 s++; 3426 return s; 3427 case 's': 3428 forbid_setid('s', FALSE); 3429 PL_doswitches = TRUE; 3430 s++; 3431 return s; 3432 case 't': 3433 case 'T': 3434 #if defined(SILENT_NO_TAINT_SUPPORT) 3435 /* silently ignore */ 3436 #elif defined(NO_TAINT_SUPPORT) 3437 Perl_croak_nocontext("This perl was compiled without taint support. " 3438 "Cowardly refusing to run with -t or -T flags"); 3439 #else 3440 if (!TAINTING_get) 3441 TOO_LATE_FOR(*s); 3442 #endif 3443 s++; 3444 return s; 3445 case 'u': 3446 PL_do_undump = TRUE; 3447 s++; 3448 return s; 3449 case 'U': 3450 PL_unsafe = TRUE; 3451 s++; 3452 return s; 3453 case 'v': 3454 minus_v(); 3455 case 'w': 3456 if (! (PL_dowarn & G_WARN_ALL_MASK)) { 3457 PL_dowarn |= G_WARN_ON; 3458 } 3459 s++; 3460 return s; 3461 case 'W': 3462 PL_dowarn = G_WARN_ALL_ON|G_WARN_ON; 3463 if (!specialWARN(PL_compiling.cop_warnings)) 3464 PerlMemShared_free(PL_compiling.cop_warnings); 3465 PL_compiling.cop_warnings = pWARN_ALL ; 3466 s++; 3467 return s; 3468 case 'X': 3469 PL_dowarn = G_WARN_ALL_OFF; 3470 if (!specialWARN(PL_compiling.cop_warnings)) 3471 PerlMemShared_free(PL_compiling.cop_warnings); 3472 PL_compiling.cop_warnings = pWARN_NONE ; 3473 s++; 3474 return s; 3475 case '*': 3476 case ' ': 3477 while( *s == ' ' ) 3478 ++s; 3479 if (s[0] == '-') /* Additional switches on #! line. */ 3480 return s+1; 3481 break; 3482 case '-': 3483 case 0: 3484 #if defined(WIN32) || !defined(PERL_STRICT_CR) 3485 case '\r': 3486 #endif 3487 case '\n': 3488 case '\t': 3489 break; 3490 #ifdef ALTERNATE_SHEBANG 3491 case 'S': /* OS/2 needs -S on "extproc" line. */ 3492 break; 3493 #endif 3494 case 'e': case 'f': case 'x': case 'E': 3495 #ifndef ALTERNATE_SHEBANG 3496 case 'S': 3497 #endif 3498 case 'V': 3499 Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s); 3500 default: 3501 Perl_croak(aTHX_ 3502 "Unrecognized switch: -%.1s (-h will show valid options)",s 3503 ); 3504 } 3505 return NULL; 3506 } 3507 3508 3509 STATIC void 3510 S_minus_v(pTHX) 3511 { 3512 PerlIO * PIO_stdout; 3513 { 3514 const char * const level_str = "v" PERL_VERSION_STRING; 3515 const STRLEN level_len = sizeof("v" PERL_VERSION_STRING)-1; 3516 #ifdef PERL_PATCHNUM 3517 SV* level; 3518 # ifdef PERL_GIT_UNCOMMITTED_CHANGES 3519 static const char num [] = PERL_PATCHNUM "*"; 3520 # else 3521 static const char num [] = PERL_PATCHNUM; 3522 # endif 3523 { 3524 const STRLEN num_len = sizeof(num)-1; 3525 /* A very advanced compiler would fold away the strnEQ 3526 and this whole conditional, but most (all?) won't do it. 3527 SV level could also be replaced by with preprocessor 3528 catenation. 3529 */ 3530 if (num_len >= level_len && strnEQ(num,level_str,level_len)) { 3531 /* per 46807d8e80, PERL_PATCHNUM is outside of the control 3532 of the interp so it might contain format characters 3533 */ 3534 level = newSVpvn(num, num_len); 3535 } else { 3536 level = Perl_newSVpvf_nocontext("%s (%s)", level_str, num); 3537 } 3538 } 3539 #else 3540 SV* level = newSVpvn(level_str, level_len); 3541 #endif /* #ifdef PERL_PATCHNUM */ 3542 PIO_stdout = PerlIO_stdout(); 3543 PerlIO_printf(PIO_stdout, 3544 "\nThis is perl " STRINGIFY(PERL_REVISION) 3545 ", version " STRINGIFY(PERL_VERSION) 3546 ", subversion " STRINGIFY(PERL_SUBVERSION) 3547 " (%"SVf") built for " ARCHNAME, SVfARG(level) 3548 ); 3549 SvREFCNT_dec_NN(level); 3550 } 3551 #if defined(LOCAL_PATCH_COUNT) 3552 if (LOCAL_PATCH_COUNT > 0) 3553 PerlIO_printf(PIO_stdout, 3554 "\n(with %d registered patch%s, " 3555 "see perl -V for more detail)", 3556 LOCAL_PATCH_COUNT, 3557 (LOCAL_PATCH_COUNT!=1) ? "es" : ""); 3558 #endif 3559 3560 PerlIO_printf(PIO_stdout, 3561 "\n\nCopyright 1987-2017, Larry Wall\n"); 3562 #ifdef MSDOS 3563 PerlIO_printf(PIO_stdout, 3564 "\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n"); 3565 #endif 3566 #ifdef DJGPP 3567 PerlIO_printf(PIO_stdout, 3568 "djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n" 3569 "djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n"); 3570 #endif 3571 #ifdef OS2 3572 PerlIO_printf(PIO_stdout, 3573 "\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n" 3574 "Version 5 port Copyright (c) 1994-2002, Andreas Kaiser, Ilya Zakharevich\n"); 3575 #endif 3576 #ifdef OEMVS 3577 PerlIO_printf(PIO_stdout, 3578 "MVS (OS390) port by Mortice Kern Systems, 1997-1999\n"); 3579 #endif 3580 #ifdef __VOS__ 3581 PerlIO_printf(PIO_stdout, 3582 "Stratus OpenVOS port by Paul.Green@stratus.com, 1997-2013\n"); 3583 #endif 3584 #ifdef POSIX_BC 3585 PerlIO_printf(PIO_stdout, 3586 "BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n"); 3587 #endif 3588 #ifdef UNDER_CE 3589 PerlIO_printf(PIO_stdout, 3590 "WINCE port by Rainer Keuchel, 2001-2002\n" 3591 "Built on " __DATE__ " " __TIME__ "\n\n"); 3592 wce_hitreturn(); 3593 #endif 3594 #ifdef __SYMBIAN32__ 3595 PerlIO_printf(PIO_stdout, 3596 "Symbian port by Nokia, 2004-2005\n"); 3597 #endif 3598 #ifdef BINARY_BUILD_NOTICE 3599 BINARY_BUILD_NOTICE; 3600 #endif 3601 PerlIO_printf(PIO_stdout, 3602 "\n\ 3603 Perl may be copied only under the terms of either the Artistic License or the\n\ 3604 GNU General Public License, which may be found in the Perl 5 source kit.\n\n\ 3605 Complete documentation for Perl, including FAQ lists, should be found on\n\ 3606 this system using \"man perl\" or \"perldoc perl\". If you have access to the\n\ 3607 Internet, point your browser at http://www.perl.org/, the Perl Home Page.\n\n"); 3608 my_exit(0); 3609 } 3610 3611 /* compliments of Tom Christiansen */ 3612 3613 /* unexec() can be found in the Gnu emacs distribution */ 3614 /* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */ 3615 3616 #ifdef VMS 3617 #include <lib$routines.h> 3618 #endif 3619 3620 void 3621 Perl_my_unexec(pTHX) 3622 { 3623 #ifdef UNEXEC 3624 SV * prog = newSVpv(BIN_EXP, 0); 3625 SV * file = newSVpv(PL_origfilename, 0); 3626 int status = 1; 3627 extern int etext; 3628 3629 sv_catpvs(prog, "/perl"); 3630 sv_catpvs(file, ".perldump"); 3631 3632 unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0); 3633 /* unexec prints msg to stderr in case of failure */ 3634 PerlProc_exit(status); 3635 #else 3636 PERL_UNUSED_CONTEXT; 3637 # ifdef VMS 3638 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */ 3639 # elif defined(WIN32) || defined(__CYGWIN__) 3640 Perl_croak_nocontext("dump is not supported"); 3641 # else 3642 ABORT(); /* for use with undump */ 3643 # endif 3644 #endif 3645 } 3646 3647 /* initialize curinterp */ 3648 STATIC void 3649 S_init_interp(pTHX) 3650 { 3651 #ifdef MULTIPLICITY 3652 # define PERLVAR(prefix,var,type) 3653 # define PERLVARA(prefix,var,n,type) 3654 # if defined(PERL_IMPLICIT_CONTEXT) 3655 # define PERLVARI(prefix,var,type,init) aTHX->prefix##var = init; 3656 # define PERLVARIC(prefix,var,type,init) aTHX->prefix##var = init; 3657 # else 3658 # define PERLVARI(prefix,var,type,init) PERL_GET_INTERP->var = init; 3659 # define PERLVARIC(prefix,var,type,init) PERL_GET_INTERP->var = init; 3660 # endif 3661 # include "intrpvar.h" 3662 # undef PERLVAR 3663 # undef PERLVARA 3664 # undef PERLVARI 3665 # undef PERLVARIC 3666 #else 3667 # define PERLVAR(prefix,var,type) 3668 # define PERLVARA(prefix,var,n,type) 3669 # define PERLVARI(prefix,var,type,init) PL_##var = init; 3670 # define PERLVARIC(prefix,var,type,init) PL_##var = init; 3671 # include "intrpvar.h" 3672 # undef PERLVAR 3673 # undef PERLVARA 3674 # undef PERLVARI 3675 # undef PERLVARIC 3676 #endif 3677 3678 } 3679 3680 STATIC void 3681 S_init_main_stash(pTHX) 3682 { 3683 GV *gv; 3684 3685 PL_curstash = PL_defstash = (HV *)SvREFCNT_inc_simple_NN(newHV()); 3686 /* We know that the string "main" will be in the global shared string 3687 table, so it's a small saving to use it rather than allocate another 3688 8 bytes. */ 3689 PL_curstname = newSVpvs_share("main"); 3690 gv = gv_fetchpvs("main::", GV_ADD|GV_NOTQUAL, SVt_PVHV); 3691 /* If we hadn't caused another reference to "main" to be in the shared 3692 string table above, then it would be worth reordering these two, 3693 because otherwise all we do is delete "main" from it as a consequence 3694 of the SvREFCNT_dec, only to add it again with hv_name_set */ 3695 SvREFCNT_dec(GvHV(gv)); 3696 hv_name_set(PL_defstash, "main", 4, 0); 3697 GvHV(gv) = MUTABLE_HV(SvREFCNT_inc_simple(PL_defstash)); 3698 SvREADONLY_on(gv); 3699 PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpvs("INC", GV_ADD|GV_NOTQUAL, 3700 SVt_PVAV))); 3701 SvREFCNT_inc_simple_void(PL_incgv); /* Don't allow it to be freed */ 3702 GvMULTI_on(PL_incgv); 3703 PL_hintgv = gv_fetchpvs("\010", GV_ADD|GV_NOTQUAL, SVt_PV); /* ^H */ 3704 SvREFCNT_inc_simple_void(PL_hintgv); 3705 GvMULTI_on(PL_hintgv); 3706 PL_defgv = gv_fetchpvs("_", GV_ADD|GV_NOTQUAL, SVt_PVAV); 3707 SvREFCNT_inc_simple_void(PL_defgv); 3708 PL_errgv = gv_fetchpvs("@", GV_ADD|GV_NOTQUAL, SVt_PV); 3709 SvREFCNT_inc_simple_void(PL_errgv); 3710 GvMULTI_on(PL_errgv); 3711 PL_replgv = gv_fetchpvs("\022", GV_ADD|GV_NOTQUAL, SVt_PV); /* ^R */ 3712 SvREFCNT_inc_simple_void(PL_replgv); 3713 GvMULTI_on(PL_replgv); 3714 (void)Perl_form(aTHX_ "%240s",""); /* Preallocate temp - for immediate signals. */ 3715 #ifdef PERL_DONT_CREATE_GVSV 3716 (void)gv_SVadd(PL_errgv); 3717 #endif 3718 sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */ 3719 CLEAR_ERRSV(); 3720 SET_CURSTASH(PL_defstash); 3721 CopSTASH_set(&PL_compiling, PL_defstash); 3722 PL_debstash = GvHV(gv_fetchpvs("DB::", GV_ADDMULTI, SVt_PVHV)); 3723 PL_globalstash = GvHV(gv_fetchpvs("CORE::GLOBAL::", GV_ADDMULTI, 3724 SVt_PVHV)); 3725 /* We must init $/ before switches are processed. */ 3726 sv_setpvs(get_sv("/", GV_ADD), "\n"); 3727 } 3728 3729 STATIC PerlIO * 3730 S_open_script(pTHX_ const char *scriptname, bool dosearch, bool *suidscript) 3731 { 3732 int fdscript = -1; 3733 PerlIO *rsfp = NULL; 3734 Stat_t tmpstatbuf; 3735 int fd; 3736 3737 PERL_ARGS_ASSERT_OPEN_SCRIPT; 3738 3739 if (PL_e_script) { 3740 PL_origfilename = savepvs("-e"); 3741 } 3742 else { 3743 const char *s; 3744 UV uv; 3745 /* if find_script() returns, it returns a malloc()-ed value */ 3746 scriptname = PL_origfilename = find_script(scriptname, dosearch, NULL, 1); 3747 3748 if (strnEQ(scriptname, "/dev/fd/", 8) 3749 && isDIGIT(scriptname[8]) 3750 && grok_atoUV(scriptname + 8, &uv, &s) 3751 && uv <= PERL_INT_MAX 3752 ) { 3753 fdscript = (int)uv; 3754 if (*s) { 3755 /* PSz 18 Feb 04 3756 * Tell apart "normal" usage of fdscript, e.g. 3757 * with bash on FreeBSD: 3758 * perl <( echo '#!perl -DA'; echo 'print "$0\n"') 3759 * from usage in suidperl. 3760 * Does any "normal" usage leave garbage after the number??? 3761 * Is it a mistake to use a similar /dev/fd/ construct for 3762 * suidperl? 3763 */ 3764 *suidscript = TRUE; 3765 /* PSz 20 Feb 04 3766 * Be supersafe and do some sanity-checks. 3767 * Still, can we be sure we got the right thing? 3768 */ 3769 if (*s != '/') { 3770 Perl_croak(aTHX_ "Wrong syntax (suid) fd script name \"%s\"\n", s); 3771 } 3772 if (! *(s+1)) { 3773 Perl_croak(aTHX_ "Missing (suid) fd script name\n"); 3774 } 3775 scriptname = savepv(s + 1); 3776 Safefree(PL_origfilename); 3777 PL_origfilename = (char *)scriptname; 3778 } 3779 } 3780 } 3781 3782 CopFILE_free(PL_curcop); 3783 CopFILE_set(PL_curcop, PL_origfilename); 3784 if (*PL_origfilename == '-' && PL_origfilename[1] == '\0') 3785 scriptname = (char *)""; 3786 if (fdscript >= 0) { 3787 rsfp = PerlIO_fdopen(fdscript,PERL_SCRIPT_MODE); 3788 } 3789 else if (!*scriptname) { 3790 forbid_setid(0, *suidscript); 3791 return NULL; 3792 } 3793 else { 3794 #ifdef FAKE_BIT_BUCKET 3795 /* This hack allows one not to have /dev/null (or BIT_BUCKET as it 3796 * is called) and still have the "-e" work. (Believe it or not, 3797 * a /dev/null is required for the "-e" to work because source 3798 * filter magic is used to implement it. ) This is *not* a general 3799 * replacement for a /dev/null. What we do here is create a temp 3800 * file (an empty file), open up that as the script, and then 3801 * immediately close and unlink it. Close enough for jazz. */ 3802 #define FAKE_BIT_BUCKET_PREFIX "/tmp/perlnull-" 3803 #define FAKE_BIT_BUCKET_SUFFIX "XXXXXXXX" 3804 #define FAKE_BIT_BUCKET_TEMPLATE FAKE_BIT_BUCKET_PREFIX FAKE_BIT_BUCKET_SUFFIX 3805 char tmpname[sizeof(FAKE_BIT_BUCKET_TEMPLATE)] = { 3806 FAKE_BIT_BUCKET_TEMPLATE 3807 }; 3808 const char * const err = "Failed to create a fake bit bucket"; 3809 if (strEQ(scriptname, BIT_BUCKET)) { 3810 #ifdef HAS_MKSTEMP /* Hopefully mkstemp() is safe here. */ 3811 int old_umask = umask(0177); 3812 int tmpfd = mkstemp(tmpname); 3813 umask(old_umask); 3814 if (tmpfd > -1) { 3815 scriptname = tmpname; 3816 close(tmpfd); 3817 } else 3818 Perl_croak(aTHX_ err); 3819 #else 3820 # ifdef HAS_MKTEMP 3821 scriptname = mktemp(tmpname); 3822 if (!scriptname) 3823 Perl_croak(aTHX_ err); 3824 # endif 3825 #endif 3826 } 3827 #endif 3828 rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE); 3829 #ifdef FAKE_BIT_BUCKET 3830 if (memEQ(scriptname, FAKE_BIT_BUCKET_PREFIX, 3831 sizeof(FAKE_BIT_BUCKET_PREFIX) - 1) 3832 && strlen(scriptname) == sizeof(tmpname) - 1) { 3833 unlink(scriptname); 3834 } 3835 scriptname = BIT_BUCKET; 3836 #endif 3837 } 3838 if (!rsfp) { 3839 /* PSz 16 Sep 03 Keep neat error message */ 3840 if (PL_e_script) 3841 Perl_croak(aTHX_ "Can't open "BIT_BUCKET": %s\n", Strerror(errno)); 3842 else 3843 Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n", 3844 CopFILE(PL_curcop), Strerror(errno)); 3845 } 3846 fd = PerlIO_fileno(rsfp); 3847 #if defined(HAS_FCNTL) && defined(F_SETFD) && defined(FD_CLOEXEC) 3848 if (fd >= 0) { 3849 /* ensure close-on-exec */ 3850 if (fcntl(fd, F_SETFD, FD_CLOEXEC) < 0) { 3851 Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n", 3852 CopFILE(PL_curcop), Strerror(errno)); 3853 } 3854 } 3855 #endif 3856 3857 if (fd < 0 || 3858 (PerlLIO_fstat(fd, &tmpstatbuf) >= 0 3859 && S_ISDIR(tmpstatbuf.st_mode))) 3860 Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n", 3861 CopFILE(PL_curcop), 3862 Strerror(EISDIR)); 3863 3864 return rsfp; 3865 } 3866 3867 /* Mention 3868 * I_SYSSTATVFS HAS_FSTATVFS 3869 * I_SYSMOUNT 3870 * I_STATFS HAS_FSTATFS HAS_GETFSSTAT 3871 * I_MNTENT HAS_GETMNTENT HAS_HASMNTOPT 3872 * here so that metaconfig picks them up. */ 3873 3874 3875 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW 3876 /* Don't even need this function. */ 3877 #else 3878 STATIC void 3879 S_validate_suid(pTHX_ PerlIO *rsfp) 3880 { 3881 const Uid_t my_uid = PerlProc_getuid(); 3882 const Uid_t my_euid = PerlProc_geteuid(); 3883 const Gid_t my_gid = PerlProc_getgid(); 3884 const Gid_t my_egid = PerlProc_getegid(); 3885 3886 PERL_ARGS_ASSERT_VALIDATE_SUID; 3887 3888 if (my_euid != my_uid || my_egid != my_gid) { /* (suidperl doesn't exist, in fact) */ 3889 dVAR; 3890 int fd = PerlIO_fileno(rsfp); 3891 Stat_t statbuf; 3892 if (fd < 0 || PerlLIO_fstat(fd, &statbuf) < 0) { /* may be either wrapped or real suid */ 3893 Perl_croak_nocontext( "Illegal suidscript"); 3894 } 3895 if ((my_euid != my_uid && my_euid == statbuf.st_uid && statbuf.st_mode & S_ISUID) 3896 || 3897 (my_egid != my_gid && my_egid == statbuf.st_gid && statbuf.st_mode & S_ISGID) 3898 ) 3899 if (!PL_do_undump) 3900 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\ 3901 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n"); 3902 /* not set-id, must be wrapped */ 3903 } 3904 } 3905 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */ 3906 3907 STATIC void 3908 S_find_beginning(pTHX_ SV* linestr_sv, PerlIO *rsfp) 3909 { 3910 const char *s; 3911 const char *s2; 3912 3913 PERL_ARGS_ASSERT_FIND_BEGINNING; 3914 3915 /* skip forward in input to the real script? */ 3916 3917 do { 3918 if ((s = sv_gets(linestr_sv, rsfp, 0)) == NULL) 3919 Perl_croak(aTHX_ "No Perl script found in input\n"); 3920 s2 = s; 3921 } while (!(*s == '#' && s[1] == '!' && ((s = instr(s,"perl")) || (s = instr(s2,"PERL"))))); 3922 PerlIO_ungetc(rsfp, '\n'); /* to keep line count right */ 3923 while (*s && !(isSPACE (*s) || *s == '#')) s++; 3924 s2 = s; 3925 while (*s == ' ' || *s == '\t') s++; 3926 if (*s++ == '-') { 3927 while (isDIGIT(s2[-1]) || s2[-1] == '-' || s2[-1] == '.' 3928 || s2[-1] == '_') s2--; 3929 if (strnEQ(s2-4,"perl",4)) 3930 while ((s = moreswitches(s))) 3931 ; 3932 } 3933 } 3934 3935 3936 STATIC void 3937 S_init_ids(pTHX) 3938 { 3939 /* no need to do anything here any more if we don't 3940 * do tainting. */ 3941 #ifndef NO_TAINT_SUPPORT 3942 const Uid_t my_uid = PerlProc_getuid(); 3943 const Uid_t my_euid = PerlProc_geteuid(); 3944 const Gid_t my_gid = PerlProc_getgid(); 3945 const Gid_t my_egid = PerlProc_getegid(); 3946 3947 PERL_UNUSED_CONTEXT; 3948 3949 /* Should not happen: */ 3950 CHECK_MALLOC_TAINT(my_uid && (my_euid != my_uid || my_egid != my_gid)); 3951 TAINTING_set( TAINTING_get | (my_uid && (my_euid != my_uid || my_egid != my_gid)) ); 3952 #endif 3953 /* BUG */ 3954 /* PSz 27 Feb 04 3955 * Should go by suidscript, not uid!=euid: why disallow 3956 * system("ls") in scripts run from setuid things? 3957 * Or, is this run before we check arguments and set suidscript? 3958 * What about SETUID_SCRIPTS_ARE_SECURE_NOW: could we use fdscript then? 3959 * (We never have suidscript, can we be sure to have fdscript?) 3960 * Or must then go by UID checks? See comments in forbid_setid also. 3961 */ 3962 } 3963 3964 /* This is used very early in the lifetime of the program, 3965 * before even the options are parsed, so PL_tainting has 3966 * not been initialized properly. */ 3967 bool 3968 Perl_doing_taint(int argc, char *argv[], char *envp[]) 3969 { 3970 #ifndef PERL_IMPLICIT_SYS 3971 /* If we have PERL_IMPLICIT_SYS we can't call getuid() et alia 3972 * before we have an interpreter-- and the whole point of this 3973 * function is to be called at such an early stage. If you are on 3974 * a system with PERL_IMPLICIT_SYS but you do have a concept of 3975 * "tainted because running with altered effective ids', you'll 3976 * have to add your own checks somewhere in here. The two most 3977 * known samples of 'implicitness' are Win32 and NetWare, neither 3978 * of which has much of concept of 'uids'. */ 3979 Uid_t uid = PerlProc_getuid(); 3980 Uid_t euid = PerlProc_geteuid(); 3981 Gid_t gid = PerlProc_getgid(); 3982 Gid_t egid = PerlProc_getegid(); 3983 (void)envp; 3984 3985 #ifdef VMS 3986 uid |= gid << 16; 3987 euid |= egid << 16; 3988 #endif 3989 if (uid && (euid != uid || egid != gid)) 3990 return 1; 3991 #endif /* !PERL_IMPLICIT_SYS */ 3992 /* This is a really primitive check; environment gets ignored only 3993 * if -T are the first chars together; otherwise one gets 3994 * "Too late" message. */ 3995 if ( argc > 1 && argv[1][0] == '-' 3996 && isALPHA_FOLD_EQ(argv[1][1], 't')) 3997 return 1; 3998 return 0; 3999 } 4000 4001 /* Passing the flag as a single char rather than a string is a slight space 4002 optimisation. The only message that isn't /^-.$/ is 4003 "program input from stdin", which is substituted in place of '\0', which 4004 could never be a command line flag. */ 4005 STATIC void 4006 S_forbid_setid(pTHX_ const char flag, const bool suidscript) /* g */ 4007 { 4008 char string[3] = "-x"; 4009 const char *message = "program input from stdin"; 4010 4011 PERL_UNUSED_CONTEXT; 4012 if (flag) { 4013 string[1] = flag; 4014 message = string; 4015 } 4016 4017 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW 4018 if (PerlProc_getuid() != PerlProc_geteuid()) 4019 Perl_croak(aTHX_ "No %s allowed while running setuid", message); 4020 if (PerlProc_getgid() != PerlProc_getegid()) 4021 Perl_croak(aTHX_ "No %s allowed while running setgid", message); 4022 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */ 4023 if (suidscript) 4024 Perl_croak(aTHX_ "No %s allowed with (suid) fdscript", message); 4025 } 4026 4027 void 4028 Perl_init_dbargs(pTHX) 4029 { 4030 AV *const args = PL_dbargs = GvAV(gv_AVadd((gv_fetchpvs("DB::args", 4031 GV_ADDMULTI, 4032 SVt_PVAV)))); 4033 4034 if (AvREAL(args)) { 4035 /* Someone has already created it. 4036 It might have entries, and if we just turn off AvREAL(), they will 4037 "leak" until global destruction. */ 4038 av_clear(args); 4039 if (SvTIED_mg((const SV *)args, PERL_MAGIC_tied)) 4040 Perl_croak(aTHX_ "Cannot set tied @DB::args"); 4041 } 4042 AvREIFY_only(PL_dbargs); 4043 } 4044 4045 void 4046 Perl_init_debugger(pTHX) 4047 { 4048 HV * const ostash = PL_curstash; 4049 MAGIC *mg; 4050 4051 PL_curstash = (HV *)SvREFCNT_inc_simple(PL_debstash); 4052 4053 Perl_init_dbargs(aTHX); 4054 PL_DBgv = MUTABLE_GV( 4055 SvREFCNT_inc(gv_fetchpvs("DB::DB", GV_ADDMULTI, SVt_PVGV)) 4056 ); 4057 PL_DBline = MUTABLE_GV( 4058 SvREFCNT_inc(gv_fetchpvs("DB::dbline", GV_ADDMULTI, SVt_PVAV)) 4059 ); 4060 PL_DBsub = MUTABLE_GV(SvREFCNT_inc( 4061 gv_HVadd(gv_fetchpvs("DB::sub", GV_ADDMULTI, SVt_PVHV)) 4062 )); 4063 PL_DBsingle = GvSV((gv_fetchpvs("DB::single", GV_ADDMULTI, SVt_PV))); 4064 if (!SvIOK(PL_DBsingle)) 4065 sv_setiv(PL_DBsingle, 0); 4066 mg = sv_magicext(PL_DBsingle, NULL, PERL_MAGIC_debugvar, &PL_vtbl_debugvar, 0, 0); 4067 mg->mg_private = DBVARMG_SINGLE; 4068 SvSETMAGIC(PL_DBsingle); 4069 4070 PL_DBtrace = GvSV((gv_fetchpvs("DB::trace", GV_ADDMULTI, SVt_PV))); 4071 if (!SvIOK(PL_DBtrace)) 4072 sv_setiv(PL_DBtrace, 0); 4073 mg = sv_magicext(PL_DBtrace, NULL, PERL_MAGIC_debugvar, &PL_vtbl_debugvar, 0, 0); 4074 mg->mg_private = DBVARMG_TRACE; 4075 SvSETMAGIC(PL_DBtrace); 4076 4077 PL_DBsignal = GvSV((gv_fetchpvs("DB::signal", GV_ADDMULTI, SVt_PV))); 4078 if (!SvIOK(PL_DBsignal)) 4079 sv_setiv(PL_DBsignal, 0); 4080 mg = sv_magicext(PL_DBsignal, NULL, PERL_MAGIC_debugvar, &PL_vtbl_debugvar, 0, 0); 4081 mg->mg_private = DBVARMG_SIGNAL; 4082 SvSETMAGIC(PL_DBsignal); 4083 4084 SvREFCNT_dec(PL_curstash); 4085 PL_curstash = ostash; 4086 } 4087 4088 #ifndef STRESS_REALLOC 4089 #define REASONABLE(size) (size) 4090 #define REASONABLE_but_at_least(size,min) (size) 4091 #else 4092 #define REASONABLE(size) (1) /* unreasonable */ 4093 #define REASONABLE_but_at_least(size,min) (min) 4094 #endif 4095 4096 void 4097 Perl_init_stacks(pTHX) 4098 { 4099 SSize_t size; 4100 4101 /* start with 128-item stack and 8K cxstack */ 4102 PL_curstackinfo = new_stackinfo(REASONABLE(128), 4103 REASONABLE(8192/sizeof(PERL_CONTEXT) - 1)); 4104 PL_curstackinfo->si_type = PERLSI_MAIN; 4105 PL_curstack = PL_curstackinfo->si_stack; 4106 PL_mainstack = PL_curstack; /* remember in case we switch stacks */ 4107 4108 PL_stack_base = AvARRAY(PL_curstack); 4109 PL_stack_sp = PL_stack_base; 4110 PL_stack_max = PL_stack_base + AvMAX(PL_curstack); 4111 4112 Newx(PL_tmps_stack,REASONABLE(128),SV*); 4113 PL_tmps_floor = -1; 4114 PL_tmps_ix = -1; 4115 PL_tmps_max = REASONABLE(128); 4116 4117 Newx(PL_markstack,REASONABLE(32),I32); 4118 PL_markstack_ptr = PL_markstack; 4119 PL_markstack_max = PL_markstack + REASONABLE(32); 4120 4121 SET_MARK_OFFSET; 4122 4123 Newx(PL_scopestack,REASONABLE(32),I32); 4124 #ifdef DEBUGGING 4125 Newx(PL_scopestack_name,REASONABLE(32),const char*); 4126 #endif 4127 PL_scopestack_ix = 0; 4128 PL_scopestack_max = REASONABLE(32); 4129 4130 size = REASONABLE_but_at_least(128,SS_MAXPUSH); 4131 Newx(PL_savestack, size, ANY); 4132 PL_savestack_ix = 0; 4133 /*PL_savestack_max lies: it always has SS_MAXPUSH more than it claims */ 4134 PL_savestack_max = size - SS_MAXPUSH; 4135 } 4136 4137 #undef REASONABLE 4138 4139 STATIC void 4140 S_nuke_stacks(pTHX) 4141 { 4142 while (PL_curstackinfo->si_next) 4143 PL_curstackinfo = PL_curstackinfo->si_next; 4144 while (PL_curstackinfo) { 4145 PERL_SI *p = PL_curstackinfo->si_prev; 4146 /* curstackinfo->si_stack got nuked by sv_free_arenas() */ 4147 Safefree(PL_curstackinfo->si_cxstack); 4148 Safefree(PL_curstackinfo); 4149 PL_curstackinfo = p; 4150 } 4151 Safefree(PL_tmps_stack); 4152 Safefree(PL_markstack); 4153 Safefree(PL_scopestack); 4154 #ifdef DEBUGGING 4155 Safefree(PL_scopestack_name); 4156 #endif 4157 Safefree(PL_savestack); 4158 } 4159 4160 void 4161 Perl_populate_isa(pTHX_ const char *name, STRLEN len, ...) 4162 { 4163 GV *const gv = gv_fetchpvn(name, len, GV_ADD | GV_ADDMULTI, SVt_PVAV); 4164 AV *const isa = GvAVn(gv); 4165 va_list args; 4166 4167 PERL_ARGS_ASSERT_POPULATE_ISA; 4168 4169 if(AvFILLp(isa) != -1) 4170 return; 4171 4172 /* NOTE: No support for tied ISA */ 4173 4174 va_start(args, len); 4175 do { 4176 const char *const parent = va_arg(args, const char*); 4177 size_t parent_len; 4178 4179 if (!parent) 4180 break; 4181 parent_len = va_arg(args, size_t); 4182 4183 /* Arguments are supplied with a trailing :: */ 4184 assert(parent_len > 2); 4185 assert(parent[parent_len - 1] == ':'); 4186 assert(parent[parent_len - 2] == ':'); 4187 av_push(isa, newSVpvn(parent, parent_len - 2)); 4188 (void) gv_fetchpvn(parent, parent_len, GV_ADD, SVt_PVGV); 4189 } while (1); 4190 va_end(args); 4191 } 4192 4193 4194 STATIC void 4195 S_init_predump_symbols(pTHX) 4196 { 4197 GV *tmpgv; 4198 IO *io; 4199 4200 sv_setpvs(get_sv("\"", GV_ADD), " "); 4201 PL_ofsgv = (GV*)SvREFCNT_inc(gv_fetchpvs(",", GV_ADD|GV_NOTQUAL, SVt_PV)); 4202 4203 4204 /* Historically, PVIOs were blessed into IO::Handle, unless 4205 FileHandle was loaded, in which case they were blessed into 4206 that. Action at a distance. 4207 However, if we simply bless into IO::Handle, we break code 4208 that assumes that PVIOs will have (among others) a seek 4209 method. IO::File inherits from IO::Handle and IO::Seekable, 4210 and provides the needed methods. But if we simply bless into 4211 it, then we break code that assumed that by loading 4212 IO::Handle, *it* would work. 4213 So a compromise is to set up the correct @IO::File::ISA, 4214 so that code that does C<use IO::Handle>; will still work. 4215 */ 4216 4217 Perl_populate_isa(aTHX_ STR_WITH_LEN("IO::File::ISA"), 4218 STR_WITH_LEN("IO::Handle::"), 4219 STR_WITH_LEN("IO::Seekable::"), 4220 STR_WITH_LEN("Exporter::"), 4221 NULL); 4222 4223 PL_stdingv = gv_fetchpvs("STDIN", GV_ADD|GV_NOTQUAL, SVt_PVIO); 4224 GvMULTI_on(PL_stdingv); 4225 io = GvIOp(PL_stdingv); 4226 IoTYPE(io) = IoTYPE_RDONLY; 4227 IoIFP(io) = PerlIO_stdin(); 4228 tmpgv = gv_fetchpvs("stdin", GV_ADD|GV_NOTQUAL, SVt_PV); 4229 GvMULTI_on(tmpgv); 4230 GvIOp(tmpgv) = MUTABLE_IO(SvREFCNT_inc_simple(io)); 4231 4232 tmpgv = gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVIO); 4233 GvMULTI_on(tmpgv); 4234 io = GvIOp(tmpgv); 4235 IoTYPE(io) = IoTYPE_WRONLY; 4236 IoOFP(io) = IoIFP(io) = PerlIO_stdout(); 4237 setdefout(tmpgv); 4238 tmpgv = gv_fetchpvs("stdout", GV_ADD|GV_NOTQUAL, SVt_PV); 4239 GvMULTI_on(tmpgv); 4240 GvIOp(tmpgv) = MUTABLE_IO(SvREFCNT_inc_simple(io)); 4241 4242 PL_stderrgv = gv_fetchpvs("STDERR", GV_ADD|GV_NOTQUAL, SVt_PVIO); 4243 GvMULTI_on(PL_stderrgv); 4244 io = GvIOp(PL_stderrgv); 4245 IoTYPE(io) = IoTYPE_WRONLY; 4246 IoOFP(io) = IoIFP(io) = PerlIO_stderr(); 4247 tmpgv = gv_fetchpvs("stderr", GV_ADD|GV_NOTQUAL, SVt_PV); 4248 GvMULTI_on(tmpgv); 4249 GvIOp(tmpgv) = MUTABLE_IO(SvREFCNT_inc_simple(io)); 4250 4251 PL_statname = newSVpvs(""); /* last filename we did stat on */ 4252 } 4253 4254 void 4255 Perl_init_argv_symbols(pTHX_ int argc, char **argv) 4256 { 4257 PERL_ARGS_ASSERT_INIT_ARGV_SYMBOLS; 4258 4259 argc--,argv++; /* skip name of script */ 4260 if (PL_doswitches) { 4261 for (; argc > 0 && **argv == '-'; argc--,argv++) { 4262 char *s; 4263 if (!argv[0][1]) 4264 break; 4265 if (argv[0][1] == '-' && !argv[0][2]) { 4266 argc--,argv++; 4267 break; 4268 } 4269 if ((s = strchr(argv[0], '='))) { 4270 const char *const start_name = argv[0] + 1; 4271 sv_setpv(GvSV(gv_fetchpvn_flags(start_name, s - start_name, 4272 TRUE, SVt_PV)), s + 1); 4273 } 4274 else 4275 sv_setiv(GvSV(gv_fetchpv(argv[0]+1, GV_ADD, SVt_PV)),1); 4276 } 4277 } 4278 if ((PL_argvgv = gv_fetchpvs("ARGV", GV_ADD|GV_NOTQUAL, SVt_PVAV))) { 4279 SvREFCNT_inc_simple_void_NN(PL_argvgv); 4280 GvMULTI_on(PL_argvgv); 4281 av_clear(GvAVn(PL_argvgv)); 4282 for (; argc > 0; argc--,argv++) { 4283 SV * const sv = newSVpv(argv[0],0); 4284 av_push(GvAV(PL_argvgv),sv); 4285 if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) { 4286 if (PL_unicode & PERL_UNICODE_ARGV_FLAG) 4287 SvUTF8_on(sv); 4288 } 4289 if (PL_unicode & PERL_UNICODE_WIDESYSCALLS_FLAG) /* Sarathy? */ 4290 (void)sv_utf8_decode(sv); 4291 } 4292 } 4293 4294 if (PL_inplace && (!PL_argvgv || AvFILL(GvAV(PL_argvgv)) == -1)) 4295 Perl_ck_warner_d(aTHX_ packWARN(WARN_INPLACE), 4296 "-i used with no filenames on the command line, " 4297 "reading from STDIN"); 4298 } 4299 4300 STATIC void 4301 S_init_postdump_symbols(pTHX_ int argc, char **argv, char **env) 4302 { 4303 #ifdef USE_ITHREADS 4304 dVAR; 4305 #endif 4306 GV* tmpgv; 4307 4308 PERL_ARGS_ASSERT_INIT_POSTDUMP_SYMBOLS; 4309 4310 PL_toptarget = newSV_type(SVt_PVIV); 4311 sv_setpvs(PL_toptarget, ""); 4312 PL_bodytarget = newSV_type(SVt_PVIV); 4313 sv_setpvs(PL_bodytarget, ""); 4314 PL_formtarget = PL_bodytarget; 4315 4316 TAINT; 4317 4318 init_argv_symbols(argc,argv); 4319 4320 if ((tmpgv = gv_fetchpvs("0", GV_ADD|GV_NOTQUAL, SVt_PV))) { 4321 sv_setpv(GvSV(tmpgv),PL_origfilename); 4322 } 4323 if ((PL_envgv = gv_fetchpvs("ENV", GV_ADD|GV_NOTQUAL, SVt_PVHV))) { 4324 HV *hv; 4325 bool env_is_not_environ; 4326 SvREFCNT_inc_simple_void_NN(PL_envgv); 4327 GvMULTI_on(PL_envgv); 4328 hv = GvHVn(PL_envgv); 4329 hv_magic(hv, NULL, PERL_MAGIC_env); 4330 #ifndef PERL_MICRO 4331 #ifdef USE_ENVIRON_ARRAY 4332 /* Note that if the supplied env parameter is actually a copy 4333 of the global environ then it may now point to free'd memory 4334 if the environment has been modified since. To avoid this 4335 problem we treat env==NULL as meaning 'use the default' 4336 */ 4337 if (!env) 4338 env = environ; 4339 env_is_not_environ = env != environ; 4340 if (env_is_not_environ 4341 # ifdef USE_ITHREADS 4342 && PL_curinterp == aTHX 4343 # endif 4344 ) 4345 { 4346 environ[0] = NULL; 4347 } 4348 if (env) { 4349 char *s, *old_var; 4350 STRLEN nlen; 4351 SV *sv; 4352 HV *dups = newHV(); 4353 4354 for (; *env; env++) { 4355 old_var = *env; 4356 4357 if (!(s = strchr(old_var,'=')) || s == old_var) 4358 continue; 4359 nlen = s - old_var; 4360 4361 #if defined(MSDOS) && !defined(DJGPP) 4362 *s = '\0'; 4363 (void)strupr(old_var); 4364 *s = '='; 4365 #endif 4366 if (hv_exists(hv, old_var, nlen)) { 4367 const char *name = savepvn(old_var, nlen); 4368 4369 /* make sure we use the same value as getenv(), otherwise code that 4370 uses getenv() (like setlocale()) might see a different value to %ENV 4371 */ 4372 sv = newSVpv(PerlEnv_getenv(name), 0); 4373 4374 /* keep a count of the dups of this name so we can de-dup environ later */ 4375 if (hv_exists(dups, name, nlen)) 4376 ++SvIVX(*hv_fetch(dups, name, nlen, 0)); 4377 else 4378 (void)hv_store(dups, name, nlen, newSViv(1), 0); 4379 4380 Safefree(name); 4381 } 4382 else { 4383 sv = newSVpv(s+1, 0); 4384 } 4385 (void)hv_store(hv, old_var, nlen, sv, 0); 4386 if (env_is_not_environ) 4387 mg_set(sv); 4388 } 4389 if (HvKEYS(dups)) { 4390 /* environ has some duplicate definitions, remove them */ 4391 HE *entry; 4392 hv_iterinit(dups); 4393 while ((entry = hv_iternext_flags(dups, 0))) { 4394 STRLEN nlen; 4395 const char *name = HePV(entry, nlen); 4396 IV count = SvIV(HeVAL(entry)); 4397 IV i; 4398 SV **valp = hv_fetch(hv, name, nlen, 0); 4399 4400 assert(valp); 4401 4402 /* try to remove any duplicate names, depending on the 4403 * implementation used in my_setenv() the iteration might 4404 * not be necessary, but let's be safe. 4405 */ 4406 for (i = 0; i < count; ++i) 4407 my_setenv(name, 0); 4408 4409 /* and set it back to the value we set $ENV{name} to */ 4410 my_setenv(name, SvPV_nolen(*valp)); 4411 } 4412 } 4413 SvREFCNT_dec_NN(dups); 4414 } 4415 #endif /* USE_ENVIRON_ARRAY */ 4416 #endif /* !PERL_MICRO */ 4417 } 4418 TAINT_NOT; 4419 4420 /* touch @F array to prevent spurious warnings 20020415 MJD */ 4421 if (PL_minus_a) { 4422 (void) get_av("main::F", GV_ADD | GV_ADDMULTI); 4423 } 4424 } 4425 4426 STATIC void 4427 S_init_perllib(pTHX) 4428 { 4429 #ifndef VMS 4430 const char *perl5lib = NULL; 4431 #endif 4432 const char *s; 4433 #if defined(WIN32) && !defined(PERL_IS_MINIPERL) 4434 STRLEN len; 4435 #endif 4436 4437 if (!TAINTING_get) { 4438 #ifndef VMS 4439 perl5lib = PerlEnv_getenv("PERL5LIB"); 4440 /* 4441 * It isn't possible to delete an environment variable with 4442 * PERL_USE_SAFE_PUTENV set unless unsetenv() is also available, so in that 4443 * case we treat PERL5LIB as undefined if it has a zero-length value. 4444 */ 4445 #if defined(PERL_USE_SAFE_PUTENV) && ! defined(HAS_UNSETENV) 4446 if (perl5lib && *perl5lib != '\0') 4447 #else 4448 if (perl5lib) 4449 #endif 4450 incpush_use_sep(perl5lib, 0, INCPUSH_ADD_SUB_DIRS); 4451 else { 4452 s = PerlEnv_getenv("PERLLIB"); 4453 if (s) 4454 incpush_use_sep(s, 0, 0); 4455 } 4456 #else /* VMS */ 4457 /* Treat PERL5?LIB as a possible search list logical name -- the 4458 * "natural" VMS idiom for a Unix path string. We allow each 4459 * element to be a set of |-separated directories for compatibility. 4460 */ 4461 char buf[256]; 4462 int idx = 0; 4463 if (vmstrnenv("PERL5LIB",buf,0,NULL,0)) 4464 do { 4465 incpush_use_sep(buf, 0, INCPUSH_ADD_SUB_DIRS); 4466 } while (vmstrnenv("PERL5LIB",buf,++idx,NULL,0)); 4467 else { 4468 while (vmstrnenv("PERLLIB",buf,idx++,NULL,0)) 4469 incpush_use_sep(buf, 0, 0); 4470 } 4471 #endif /* VMS */ 4472 } 4473 4474 #ifndef PERL_IS_MINIPERL 4475 /* miniperl gets just -I..., the split of $ENV{PERL5LIB}, and "." in @INC 4476 (and not the architecture specific directories from $ENV{PERL5LIB}) */ 4477 4478 /* Use the ~-expanded versions of APPLLIB (undocumented), 4479 SITEARCH, SITELIB, VENDORARCH, VENDORLIB, ARCHLIB and PRIVLIB 4480 */ 4481 #ifdef APPLLIB_EXP 4482 S_incpush_use_sep(aTHX_ STR_WITH_LEN(APPLLIB_EXP), 4483 INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE); 4484 #endif 4485 4486 #ifdef SITEARCH_EXP 4487 /* sitearch is always relative to sitelib on Windows for 4488 * DLL-based path intuition to work correctly */ 4489 # if !defined(WIN32) 4490 S_incpush_use_sep(aTHX_ STR_WITH_LEN(SITEARCH_EXP), 4491 INCPUSH_CAN_RELOCATE); 4492 # endif 4493 #endif 4494 4495 #ifdef SITELIB_EXP 4496 # if defined(WIN32) 4497 /* this picks up sitearch as well */ 4498 s = PerlEnv_sitelib_path(PERL_FS_VERSION, &len); 4499 if (s) 4500 incpush_use_sep(s, len, INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE); 4501 # else 4502 S_incpush_use_sep(aTHX_ STR_WITH_LEN(SITELIB_EXP), INCPUSH_CAN_RELOCATE); 4503 # endif 4504 #endif 4505 4506 #ifdef PERL_VENDORARCH_EXP 4507 /* vendorarch is always relative to vendorlib on Windows for 4508 * DLL-based path intuition to work correctly */ 4509 # if !defined(WIN32) 4510 S_incpush_use_sep(aTHX_ STR_WITH_LEN(PERL_VENDORARCH_EXP), 4511 INCPUSH_CAN_RELOCATE); 4512 # endif 4513 #endif 4514 4515 #ifdef PERL_VENDORLIB_EXP 4516 # if defined(WIN32) 4517 /* this picks up vendorarch as well */ 4518 s = PerlEnv_vendorlib_path(PERL_FS_VERSION, &len); 4519 if (s) 4520 incpush_use_sep(s, len, INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE); 4521 # else 4522 S_incpush_use_sep(aTHX_ STR_WITH_LEN(PERL_VENDORLIB_EXP), 4523 INCPUSH_CAN_RELOCATE); 4524 # endif 4525 #endif 4526 4527 #ifdef ARCHLIB_EXP 4528 S_incpush_use_sep(aTHX_ STR_WITH_LEN(ARCHLIB_EXP), INCPUSH_CAN_RELOCATE); 4529 #endif 4530 4531 #ifndef PRIVLIB_EXP 4532 # define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl" 4533 #endif 4534 4535 #if defined(WIN32) 4536 s = PerlEnv_lib_path(PERL_FS_VERSION, &len); 4537 if (s) 4538 incpush_use_sep(s, len, INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE); 4539 #else 4540 # ifdef NETWARE 4541 S_incpush_use_sep(aTHX_ PRIVLIB_EXP, 0, INCPUSH_CAN_RELOCATE); 4542 # else 4543 S_incpush_use_sep(aTHX_ STR_WITH_LEN(PRIVLIB_EXP), INCPUSH_CAN_RELOCATE); 4544 # endif 4545 #endif 4546 4547 #ifdef PERL_OTHERLIBDIRS 4548 S_incpush_use_sep(aTHX_ STR_WITH_LEN(PERL_OTHERLIBDIRS), 4549 INCPUSH_ADD_VERSIONED_SUB_DIRS|INCPUSH_NOT_BASEDIR 4550 |INCPUSH_CAN_RELOCATE); 4551 #endif 4552 4553 if (!TAINTING_get) { 4554 #ifndef VMS 4555 /* 4556 * It isn't possible to delete an environment variable with 4557 * PERL_USE_SAFE_PUTENV set unless unsetenv() is also available, so in that 4558 * case we treat PERL5LIB as undefined if it has a zero-length value. 4559 */ 4560 #if defined(PERL_USE_SAFE_PUTENV) && ! defined(HAS_UNSETENV) 4561 if (perl5lib && *perl5lib != '\0') 4562 #else 4563 if (perl5lib) 4564 #endif 4565 incpush_use_sep(perl5lib, 0, 4566 INCPUSH_ADD_OLD_VERS|INCPUSH_NOT_BASEDIR); 4567 #else /* VMS */ 4568 /* Treat PERL5?LIB as a possible search list logical name -- the 4569 * "natural" VMS idiom for a Unix path string. We allow each 4570 * element to be a set of |-separated directories for compatibility. 4571 */ 4572 char buf[256]; 4573 int idx = 0; 4574 if (vmstrnenv("PERL5LIB",buf,0,NULL,0)) 4575 do { 4576 incpush_use_sep(buf, 0, 4577 INCPUSH_ADD_OLD_VERS|INCPUSH_NOT_BASEDIR); 4578 } while (vmstrnenv("PERL5LIB",buf,++idx,NULL,0)); 4579 #endif /* VMS */ 4580 } 4581 4582 /* Use the ~-expanded versions of APPLLIB (undocumented), 4583 SITELIB and VENDORLIB for older versions 4584 */ 4585 #ifdef APPLLIB_EXP 4586 S_incpush_use_sep(aTHX_ STR_WITH_LEN(APPLLIB_EXP), INCPUSH_ADD_OLD_VERS 4587 |INCPUSH_NOT_BASEDIR|INCPUSH_CAN_RELOCATE); 4588 #endif 4589 4590 #if defined(SITELIB_STEM) && defined(PERL_INC_VERSION_LIST) 4591 /* Search for version-specific dirs below here */ 4592 S_incpush_use_sep(aTHX_ STR_WITH_LEN(SITELIB_STEM), 4593 INCPUSH_ADD_OLD_VERS|INCPUSH_CAN_RELOCATE); 4594 #endif 4595 4596 4597 #if defined(PERL_VENDORLIB_STEM) && defined(PERL_INC_VERSION_LIST) 4598 /* Search for version-specific dirs below here */ 4599 S_incpush_use_sep(aTHX_ STR_WITH_LEN(PERL_VENDORLIB_STEM), 4600 INCPUSH_ADD_OLD_VERS|INCPUSH_CAN_RELOCATE); 4601 #endif 4602 4603 #ifdef PERL_OTHERLIBDIRS 4604 S_incpush_use_sep(aTHX_ STR_WITH_LEN(PERL_OTHERLIBDIRS), 4605 INCPUSH_ADD_OLD_VERS|INCPUSH_ADD_ARCHONLY_SUB_DIRS 4606 |INCPUSH_CAN_RELOCATE); 4607 #endif 4608 #endif /* !PERL_IS_MINIPERL */ 4609 4610 if (!TAINTING_get) 4611 S_incpush(aTHX_ STR_WITH_LEN("."), 0); 4612 } 4613 4614 #if defined(DOSISH) || defined(__SYMBIAN32__) 4615 # define PERLLIB_SEP ';' 4616 #else 4617 # if defined(VMS) 4618 # define PERLLIB_SEP '|' 4619 # else 4620 # define PERLLIB_SEP ':' 4621 # endif 4622 #endif 4623 #ifndef PERLLIB_MANGLE 4624 # define PERLLIB_MANGLE(s,n) (s) 4625 #endif 4626 4627 #ifndef PERL_IS_MINIPERL 4628 /* Push a directory onto @INC if it exists. 4629 Generate a new SV if we do this, to save needing to copy the SV we push 4630 onto @INC */ 4631 STATIC SV * 4632 S_incpush_if_exists(pTHX_ AV *const av, SV *dir, SV *const stem) 4633 { 4634 Stat_t tmpstatbuf; 4635 4636 PERL_ARGS_ASSERT_INCPUSH_IF_EXISTS; 4637 4638 if (PerlLIO_stat(SvPVX_const(dir), &tmpstatbuf) >= 0 && 4639 S_ISDIR(tmpstatbuf.st_mode)) { 4640 av_push(av, dir); 4641 dir = newSVsv(stem); 4642 } else { 4643 /* Truncate dir back to stem. */ 4644 SvCUR_set(dir, SvCUR(stem)); 4645 } 4646 return dir; 4647 } 4648 #endif 4649 4650 STATIC SV * 4651 S_mayberelocate(pTHX_ const char *const dir, STRLEN len, U32 flags) 4652 { 4653 const U8 canrelocate = (U8)flags & INCPUSH_CAN_RELOCATE; 4654 SV *libdir; 4655 4656 PERL_ARGS_ASSERT_MAYBERELOCATE; 4657 assert(len > 0); 4658 4659 /* I am not convinced that this is valid when PERLLIB_MANGLE is 4660 defined to so something (in os2/os2.c), but the code has been 4661 this way, ignoring any possible changed of length, since 4662 760ac839baf413929cd31cc32ffd6dba6b781a81 (5.003_02) so I'll leave 4663 it be. */ 4664 libdir = newSVpvn(PERLLIB_MANGLE(dir, len), len); 4665 4666 #ifdef VMS 4667 { 4668 char *unix; 4669 4670 if ((unix = tounixspec_ts(SvPV(libdir,len),NULL)) != NULL) { 4671 len = strlen(unix); 4672 while (len > 1 && unix[len-1] == '/') len--; /* Cosmetic */ 4673 sv_usepvn(libdir,unix,len); 4674 } 4675 else 4676 PerlIO_printf(Perl_error_log, 4677 "Failed to unixify @INC element \"%s\"\n", 4678 SvPV_nolen_const(libdir)); 4679 } 4680 #endif 4681 4682 /* Do the if() outside the #ifdef to avoid warnings about an unused 4683 parameter. */ 4684 if (canrelocate) { 4685 #ifdef PERL_RELOCATABLE_INC 4686 /* 4687 * Relocatable include entries are marked with a leading .../ 4688 * 4689 * The algorithm is 4690 * 0: Remove that leading ".../" 4691 * 1: Remove trailing executable name (anything after the last '/') 4692 * from the perl path to give a perl prefix 4693 * Then 4694 * While the @INC element starts "../" and the prefix ends with a real 4695 * directory (ie not . or ..) chop that real directory off the prefix 4696 * and the leading "../" from the @INC element. ie a logical "../" 4697 * cleanup 4698 * Finally concatenate the prefix and the remainder of the @INC element 4699 * The intent is that /usr/local/bin/perl and .../../lib/perl5 4700 * generates /usr/local/lib/perl5 4701 */ 4702 const char *libpath = SvPVX(libdir); 4703 STRLEN libpath_len = SvCUR(libdir); 4704 if (libpath_len >= 4 && memEQ (libpath, ".../", 4)) { 4705 /* Game on! */ 4706 SV * const caret_X = get_sv("\030", 0); 4707 /* Going to use the SV just as a scratch buffer holding a C 4708 string: */ 4709 SV *prefix_sv; 4710 char *prefix; 4711 char *lastslash; 4712 4713 /* $^X is *the* source of taint if tainting is on, hence 4714 SvPOK() won't be true. */ 4715 assert(caret_X); 4716 assert(SvPOKp(caret_X)); 4717 prefix_sv = newSVpvn_flags(SvPVX(caret_X), SvCUR(caret_X), 4718 SvUTF8(caret_X)); 4719 /* Firstly take off the leading .../ 4720 If all else fail we'll do the paths relative to the current 4721 directory. */ 4722 sv_chop(libdir, libpath + 4); 4723 /* Don't use SvPV as we're intentionally bypassing taining, 4724 mortal copies that the mg_get of tainting creates, and 4725 corruption that seems to come via the save stack. 4726 I guess that the save stack isn't correctly set up yet. */ 4727 libpath = SvPVX(libdir); 4728 libpath_len = SvCUR(libdir); 4729 4730 /* This would work more efficiently with memrchr, but as it's 4731 only a GNU extension we'd need to probe for it and 4732 implement our own. Not hard, but maybe not worth it? */ 4733 4734 prefix = SvPVX(prefix_sv); 4735 lastslash = strrchr(prefix, '/'); 4736 4737 /* First time in with the *lastslash = '\0' we just wipe off 4738 the trailing /perl from (say) /usr/foo/bin/perl 4739 */ 4740 if (lastslash) { 4741 SV *tempsv; 4742 while ((*lastslash = '\0'), /* Do that, come what may. */ 4743 (libpath_len >= 3 && memEQ(libpath, "../", 3) 4744 && (lastslash = strrchr(prefix, '/')))) { 4745 if (lastslash[1] == '\0' 4746 || (lastslash[1] == '.' 4747 && (lastslash[2] == '/' /* ends "/." */ 4748 || (lastslash[2] == '/' 4749 && lastslash[3] == '/' /* or "/.." */ 4750 )))) { 4751 /* Prefix ends "/" or "/." or "/..", any of which 4752 are fishy, so don't do any more logical cleanup. 4753 */ 4754 break; 4755 } 4756 /* Remove leading "../" from path */ 4757 libpath += 3; 4758 libpath_len -= 3; 4759 /* Next iteration round the loop removes the last 4760 directory name from prefix by writing a '\0' in 4761 the while clause. */ 4762 } 4763 /* prefix has been terminated with a '\0' to the correct 4764 length. libpath points somewhere into the libdir SV. 4765 We need to join the 2 with '/' and drop the result into 4766 libdir. */ 4767 tempsv = Perl_newSVpvf(aTHX_ "%s/%s", prefix, libpath); 4768 SvREFCNT_dec(libdir); 4769 /* And this is the new libdir. */ 4770 libdir = tempsv; 4771 if (TAINTING_get && 4772 (PerlProc_getuid() != PerlProc_geteuid() || 4773 PerlProc_getgid() != PerlProc_getegid())) { 4774 /* Need to taint relocated paths if running set ID */ 4775 SvTAINTED_on(libdir); 4776 } 4777 } 4778 SvREFCNT_dec(prefix_sv); 4779 } 4780 #endif 4781 } 4782 return libdir; 4783 } 4784 4785 STATIC void 4786 S_incpush(pTHX_ const char *const dir, STRLEN len, U32 flags) 4787 { 4788 #ifndef PERL_IS_MINIPERL 4789 const U8 using_sub_dirs 4790 = (U8)flags & (INCPUSH_ADD_VERSIONED_SUB_DIRS 4791 |INCPUSH_ADD_ARCHONLY_SUB_DIRS|INCPUSH_ADD_OLD_VERS); 4792 const U8 add_versioned_sub_dirs 4793 = (U8)flags & INCPUSH_ADD_VERSIONED_SUB_DIRS; 4794 const U8 add_archonly_sub_dirs 4795 = (U8)flags & INCPUSH_ADD_ARCHONLY_SUB_DIRS; 4796 #ifdef PERL_INC_VERSION_LIST 4797 const U8 addoldvers = (U8)flags & INCPUSH_ADD_OLD_VERS; 4798 #endif 4799 #endif 4800 const U8 unshift = (U8)flags & INCPUSH_UNSHIFT; 4801 const U8 push_basedir = (flags & INCPUSH_NOT_BASEDIR) ? 0 : 1; 4802 AV *const inc = GvAVn(PL_incgv); 4803 4804 PERL_ARGS_ASSERT_INCPUSH; 4805 assert(len > 0); 4806 4807 /* Could remove this vestigial extra block, if we don't mind a lot of 4808 re-indenting diff noise. */ 4809 { 4810 SV *const libdir = mayberelocate(dir, len, flags); 4811 /* Change 20189146be79a0596543441fa369c6bf7f85103f, to fix RT#6665, 4812 arranged to unshift #! line -I onto the front of @INC. However, 4813 -I can add version and architecture specific libraries, and they 4814 need to go first. The old code assumed that it was always 4815 pushing. Hence to make it work, need to push the architecture 4816 (etc) libraries onto a temporary array, then "unshift" that onto 4817 the front of @INC. */ 4818 #ifndef PERL_IS_MINIPERL 4819 AV *const av = (using_sub_dirs) ? (unshift ? newAV() : inc) : NULL; 4820 4821 /* 4822 * BEFORE pushing libdir onto @INC we may first push version- and 4823 * archname-specific sub-directories. 4824 */ 4825 if (using_sub_dirs) { 4826 SV *subdir = newSVsv(libdir); 4827 #ifdef PERL_INC_VERSION_LIST 4828 /* Configure terminates PERL_INC_VERSION_LIST with a NULL */ 4829 const char * const incverlist[] = { PERL_INC_VERSION_LIST }; 4830 const char * const *incver; 4831 #endif 4832 4833 if (add_versioned_sub_dirs) { 4834 /* .../version/archname if -d .../version/archname */ 4835 sv_catpvs(subdir, "/" PERL_FS_VERSION "/" ARCHNAME); 4836 subdir = S_incpush_if_exists(aTHX_ av, subdir, libdir); 4837 4838 /* .../version if -d .../version */ 4839 sv_catpvs(subdir, "/" PERL_FS_VERSION); 4840 subdir = S_incpush_if_exists(aTHX_ av, subdir, libdir); 4841 } 4842 4843 #ifdef PERL_INC_VERSION_LIST 4844 if (addoldvers) { 4845 for (incver = incverlist; *incver; incver++) { 4846 /* .../xxx if -d .../xxx */ 4847 Perl_sv_catpvf(aTHX_ subdir, "/%s", *incver); 4848 subdir = S_incpush_if_exists(aTHX_ av, subdir, libdir); 4849 } 4850 } 4851 #endif 4852 4853 if (add_archonly_sub_dirs) { 4854 /* .../archname if -d .../archname */ 4855 sv_catpvs(subdir, "/" ARCHNAME); 4856 subdir = S_incpush_if_exists(aTHX_ av, subdir, libdir); 4857 4858 } 4859 4860 assert (SvREFCNT(subdir) == 1); 4861 SvREFCNT_dec(subdir); 4862 } 4863 #endif /* !PERL_IS_MINIPERL */ 4864 /* finally add this lib directory at the end of @INC */ 4865 if (unshift) { 4866 #ifdef PERL_IS_MINIPERL 4867 const Size_t extra = 0; 4868 #else 4869 Size_t extra = av_tindex(av) + 1; 4870 #endif 4871 av_unshift(inc, extra + push_basedir); 4872 if (push_basedir) 4873 av_store(inc, extra, libdir); 4874 #ifndef PERL_IS_MINIPERL 4875 while (extra--) { 4876 /* av owns a reference, av_store() expects to be donated a 4877 reference, and av expects to be sane when it's cleared. 4878 If I wanted to be naughty and wrong, I could peek inside the 4879 implementation of av_clear(), realise that it uses 4880 SvREFCNT_dec() too, so av's array could be a run of NULLs, 4881 and so directly steal from it (with a memcpy() to inc, and 4882 then memset() to NULL them out. But people copy code from the 4883 core expecting it to be best practise, so let's use the API. 4884 Although studious readers will note that I'm not checking any 4885 return codes. */ 4886 av_store(inc, extra, SvREFCNT_inc(*av_fetch(av, extra, FALSE))); 4887 } 4888 SvREFCNT_dec(av); 4889 #endif 4890 } 4891 else if (push_basedir) { 4892 av_push(inc, libdir); 4893 } 4894 4895 if (!push_basedir) { 4896 assert (SvREFCNT(libdir) == 1); 4897 SvREFCNT_dec(libdir); 4898 } 4899 } 4900 } 4901 4902 STATIC void 4903 S_incpush_use_sep(pTHX_ const char *p, STRLEN len, U32 flags) 4904 { 4905 const char *s; 4906 const char *end; 4907 /* This logic has been broken out from S_incpush(). It may be possible to 4908 simplify it. */ 4909 4910 PERL_ARGS_ASSERT_INCPUSH_USE_SEP; 4911 4912 /* perl compiled with -DPERL_RELOCATABLE_INCPUSH will ignore the len 4913 * argument to incpush_use_sep. This allows creation of relocatable 4914 * Perl distributions that patch the binary at install time. Those 4915 * distributions will have to provide their own relocation tools; this 4916 * is not a feature otherwise supported by core Perl. 4917 */ 4918 #ifndef PERL_RELOCATABLE_INCPUSH 4919 if (!len) 4920 #endif 4921 len = strlen(p); 4922 4923 end = p + len; 4924 4925 /* Break at all separators */ 4926 while ((s = (const char*)memchr(p, PERLLIB_SEP, end - p))) { 4927 if (s == p) { 4928 /* skip any consecutive separators */ 4929 4930 /* Uncomment the next line for PATH semantics */ 4931 /* But you'll need to write tests */ 4932 /* av_push(GvAVn(PL_incgv), newSVpvs(".")); */ 4933 } else { 4934 incpush(p, (STRLEN)(s - p), flags); 4935 } 4936 p = s + 1; 4937 } 4938 if (p != end) 4939 incpush(p, (STRLEN)(end - p), flags); 4940 4941 } 4942 4943 void 4944 Perl_call_list(pTHX_ I32 oldscope, AV *paramList) 4945 { 4946 SV *atsv; 4947 VOL const line_t oldline = PL_curcop ? CopLINE(PL_curcop) : 0; 4948 CV *cv; 4949 STRLEN len; 4950 int ret; 4951 dJMPENV; 4952 4953 PERL_ARGS_ASSERT_CALL_LIST; 4954 4955 while (av_tindex(paramList) >= 0) { 4956 cv = MUTABLE_CV(av_shift(paramList)); 4957 if (PL_savebegin) { 4958 if (paramList == PL_beginav) { 4959 /* save PL_beginav for compiler */ 4960 Perl_av_create_and_push(aTHX_ &PL_beginav_save, MUTABLE_SV(cv)); 4961 } 4962 else if (paramList == PL_checkav) { 4963 /* save PL_checkav for compiler */ 4964 Perl_av_create_and_push(aTHX_ &PL_checkav_save, MUTABLE_SV(cv)); 4965 } 4966 else if (paramList == PL_unitcheckav) { 4967 /* save PL_unitcheckav for compiler */ 4968 Perl_av_create_and_push(aTHX_ &PL_unitcheckav_save, MUTABLE_SV(cv)); 4969 } 4970 } else { 4971 SAVEFREESV(cv); 4972 } 4973 JMPENV_PUSH(ret); 4974 switch (ret) { 4975 case 0: 4976 CALL_LIST_BODY(cv); 4977 atsv = ERRSV; 4978 (void)SvPV_const(atsv, len); 4979 if (len) { 4980 PL_curcop = &PL_compiling; 4981 CopLINE_set(PL_curcop, oldline); 4982 if (paramList == PL_beginav) 4983 sv_catpvs(atsv, "BEGIN failed--compilation aborted"); 4984 else 4985 Perl_sv_catpvf(aTHX_ atsv, 4986 "%s failed--call queue aborted", 4987 paramList == PL_checkav ? "CHECK" 4988 : paramList == PL_initav ? "INIT" 4989 : paramList == PL_unitcheckav ? "UNITCHECK" 4990 : "END"); 4991 while (PL_scopestack_ix > oldscope) 4992 LEAVE; 4993 JMPENV_POP; 4994 Perl_croak(aTHX_ "%"SVf"", SVfARG(atsv)); 4995 } 4996 break; 4997 case 1: 4998 STATUS_ALL_FAILURE; 4999 /* FALLTHROUGH */ 5000 case 2: 5001 /* my_exit() was called */ 5002 while (PL_scopestack_ix > oldscope) 5003 LEAVE; 5004 FREETMPS; 5005 SET_CURSTASH(PL_defstash); 5006 PL_curcop = &PL_compiling; 5007 CopLINE_set(PL_curcop, oldline); 5008 JMPENV_POP; 5009 my_exit_jump(); 5010 NOT_REACHED; /* NOTREACHED */ 5011 case 3: 5012 if (PL_restartop) { 5013 PL_curcop = &PL_compiling; 5014 CopLINE_set(PL_curcop, oldline); 5015 JMPENV_JUMP(3); 5016 } 5017 PerlIO_printf(Perl_error_log, "panic: restartop in call_list\n"); 5018 FREETMPS; 5019 break; 5020 } 5021 JMPENV_POP; 5022 } 5023 } 5024 5025 void 5026 Perl_my_exit(pTHX_ U32 status) 5027 { 5028 if (PL_exit_flags & PERL_EXIT_ABORT) { 5029 abort(); 5030 } 5031 if (PL_exit_flags & PERL_EXIT_WARN) { 5032 PL_exit_flags |= PERL_EXIT_ABORT; /* Protect against reentrant calls */ 5033 Perl_warn(aTHX_ "Unexpected exit %lu", (unsigned long)status); 5034 PL_exit_flags &= ~PERL_EXIT_ABORT; 5035 } 5036 switch (status) { 5037 case 0: 5038 STATUS_ALL_SUCCESS; 5039 break; 5040 case 1: 5041 STATUS_ALL_FAILURE; 5042 break; 5043 default: 5044 STATUS_EXIT_SET(status); 5045 break; 5046 } 5047 my_exit_jump(); 5048 } 5049 5050 void 5051 Perl_my_failure_exit(pTHX) 5052 { 5053 #ifdef VMS 5054 /* We have been called to fall on our sword. The desired exit code 5055 * should be already set in STATUS_UNIX, but could be shifted over 5056 * by 8 bits. STATUS_UNIX_EXIT_SET will handle the cases where a 5057 * that code is set. 5058 * 5059 * If an error code has not been set, then force the issue. 5060 */ 5061 if (MY_POSIX_EXIT) { 5062 5063 /* According to the die_exit.t tests, if errno is non-zero */ 5064 /* It should be used for the error status. */ 5065 5066 if (errno == EVMSERR) { 5067 STATUS_NATIVE = vaxc$errno; 5068 } else { 5069 5070 /* According to die_exit.t tests, if the child_exit code is */ 5071 /* also zero, then we need to exit with a code of 255 */ 5072 if ((errno != 0) && (errno < 256)) 5073 STATUS_UNIX_EXIT_SET(errno); 5074 else if (STATUS_UNIX < 255) { 5075 STATUS_UNIX_EXIT_SET(255); 5076 } 5077 5078 } 5079 5080 /* The exit code could have been set by $? or vmsish which 5081 * means that it may not have fatal set. So convert 5082 * success/warning codes to fatal with out changing 5083 * the POSIX status code. The severity makes VMS native 5084 * status handling work, while UNIX mode programs use the 5085 * the POSIX exit codes. 5086 */ 5087 if ((STATUS_NATIVE & (STS$K_SEVERE|STS$K_ERROR)) == 0) { 5088 STATUS_NATIVE &= STS$M_COND_ID; 5089 STATUS_NATIVE |= STS$K_ERROR | STS$M_INHIB_MSG; 5090 } 5091 } 5092 else { 5093 /* Traditionally Perl on VMS always expects a Fatal Error. */ 5094 if (vaxc$errno & 1) { 5095 5096 /* So force success status to failure */ 5097 if (STATUS_NATIVE & 1) 5098 STATUS_ALL_FAILURE; 5099 } 5100 else { 5101 if (!vaxc$errno) { 5102 STATUS_UNIX = EINTR; /* In case something cares */ 5103 STATUS_ALL_FAILURE; 5104 } 5105 else { 5106 int severity; 5107 STATUS_NATIVE = vaxc$errno; /* Should already be this */ 5108 5109 /* Encode the severity code */ 5110 severity = STATUS_NATIVE & STS$M_SEVERITY; 5111 STATUS_UNIX = (severity ? severity : 1) << 8; 5112 5113 /* Perl expects this to be a fatal error */ 5114 if (severity != STS$K_SEVERE) 5115 STATUS_ALL_FAILURE; 5116 } 5117 } 5118 } 5119 5120 #else 5121 int exitstatus; 5122 if (errno & 255) 5123 STATUS_UNIX_SET(errno); 5124 else { 5125 exitstatus = STATUS_UNIX >> 8; 5126 if (exitstatus & 255) 5127 STATUS_UNIX_SET(exitstatus); 5128 else 5129 STATUS_UNIX_SET(255); 5130 } 5131 #endif 5132 if (PL_exit_flags & PERL_EXIT_ABORT) { 5133 abort(); 5134 } 5135 if (PL_exit_flags & PERL_EXIT_WARN) { 5136 PL_exit_flags |= PERL_EXIT_ABORT; /* Protect against reentrant calls */ 5137 Perl_warn(aTHX_ "Unexpected exit failure %ld", (long)PL_statusvalue); 5138 PL_exit_flags &= ~PERL_EXIT_ABORT; 5139 } 5140 my_exit_jump(); 5141 } 5142 5143 STATIC void 5144 S_my_exit_jump(pTHX) 5145 { 5146 if (PL_e_script) { 5147 SvREFCNT_dec(PL_e_script); 5148 PL_e_script = NULL; 5149 } 5150 5151 POPSTACK_TO(PL_mainstack); 5152 if (cxstack_ix >= 0) { 5153 dounwind(-1); 5154 cx_popblock(cxstack); 5155 } 5156 LEAVE_SCOPE(0); 5157 5158 JMPENV_JUMP(2); 5159 } 5160 5161 static I32 5162 read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen) 5163 { 5164 const char * const p = SvPVX_const(PL_e_script); 5165 const char *nl = strchr(p, '\n'); 5166 5167 PERL_UNUSED_ARG(idx); 5168 PERL_UNUSED_ARG(maxlen); 5169 5170 nl = (nl) ? nl+1 : SvEND(PL_e_script); 5171 if (nl-p == 0) { 5172 filter_del(read_e_script); 5173 return 0; 5174 } 5175 sv_catpvn(buf_sv, p, nl-p); 5176 sv_chop(PL_e_script, nl); 5177 return 1; 5178 } 5179 5180 /* removes boilerplate code at the end of each boot_Module xsub */ 5181 void 5182 Perl_xs_boot_epilog(pTHX_ const I32 ax) 5183 { 5184 if (PL_unitcheckav) 5185 call_list(PL_scopestack_ix, PL_unitcheckav); 5186 XSRETURN_YES; 5187 } 5188 5189 /* 5190 * ex: set ts=8 sts=4 sw=4 et: 5191 */ 5192