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