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