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 #undef PERL_BUILD_DATE 2073 2074 #ifdef PERL_BUILD_DATE 2075 PUSHs(Perl_newSVpvn_flags(aTHX_ 2076 STR_WITH_LEN("Compiled at " PERL_BUILD_DATE), 2077 SVs_TEMP)); 2078 #else 2079 PUSHs(&PL_sv_undef); 2080 #endif 2081 2082 for (i = 1; i <= local_patch_count; i++) { 2083 /* This will be an undef, if PL_localpatches[i] is NULL. */ 2084 PUSHs(sv_2mortal(newSVpv(PL_localpatches[i], 0))); 2085 } 2086 2087 XSRETURN(entries); 2088 } 2089 2090 #define INCPUSH_UNSHIFT 0x01 2091 #define INCPUSH_ADD_OLD_VERS 0x02 2092 #define INCPUSH_ADD_VERSIONED_SUB_DIRS 0x04 2093 #define INCPUSH_ADD_ARCHONLY_SUB_DIRS 0x08 2094 #define INCPUSH_NOT_BASEDIR 0x10 2095 #define INCPUSH_CAN_RELOCATE 0x20 2096 #define INCPUSH_ADD_SUB_DIRS \ 2097 (INCPUSH_ADD_VERSIONED_SUB_DIRS|INCPUSH_ADD_ARCHONLY_SUB_DIRS) 2098 2099 STATIC void * 2100 S_parse_body(pTHX_ char **env, XSINIT_t xsinit) 2101 { 2102 dVAR; 2103 PerlIO *rsfp; 2104 int argc = PL_origargc; 2105 char **argv = PL_origargv; 2106 const char *scriptname = NULL; 2107 bool dosearch = FALSE; 2108 char c; 2109 bool doextract = FALSE; 2110 const char *cddir = NULL; 2111 #ifdef USE_SITECUSTOMIZE 2112 bool minus_f = FALSE; 2113 #endif 2114 SV *linestr_sv = NULL; 2115 bool add_read_e_script = FALSE; 2116 U32 lex_start_flags = 0; 2117 2118 PERL_SET_PHASE(PERL_PHASE_START); 2119 2120 init_main_stash(); 2121 2122 { 2123 const char *s; 2124 for (argc--,argv++; argc > 0; argc--,argv++) { 2125 if (argv[0][0] != '-' || !argv[0][1]) 2126 break; 2127 s = argv[0]+1; 2128 reswitch: 2129 switch ((c = *s)) { 2130 case 'C': 2131 #ifndef PERL_STRICT_CR 2132 case '\r': 2133 #endif 2134 case ' ': 2135 case '0': 2136 case 'F': 2137 case 'a': 2138 case 'c': 2139 case 'd': 2140 case 'D': 2141 case 'h': 2142 case 'i': 2143 case 'l': 2144 case 'M': 2145 case 'm': 2146 case 'n': 2147 case 'p': 2148 case 's': 2149 case 'u': 2150 case 'U': 2151 case 'v': 2152 case 'W': 2153 case 'X': 2154 case 'w': 2155 if ((s = moreswitches(s))) 2156 goto reswitch; 2157 break; 2158 2159 case 't': 2160 #if defined(SILENT_NO_TAINT_SUPPORT) 2161 /* silently ignore */ 2162 #elif defined(NO_TAINT_SUPPORT) 2163 Perl_croak_nocontext("This perl was compiled without taint support. " 2164 "Cowardly refusing to run with -t or -T flags"); 2165 #else 2166 CHECK_MALLOC_TOO_LATE_FOR('t'); 2167 if( !TAINTING_get ) { 2168 TAINT_WARN_set(TRUE); 2169 TAINTING_set(TRUE); 2170 } 2171 #endif 2172 s++; 2173 goto reswitch; 2174 case 'T': 2175 #if defined(SILENT_NO_TAINT_SUPPORT) 2176 /* silently ignore */ 2177 #elif defined(NO_TAINT_SUPPORT) 2178 Perl_croak_nocontext("This perl was compiled without taint support. " 2179 "Cowardly refusing to run with -t or -T flags"); 2180 #else 2181 CHECK_MALLOC_TOO_LATE_FOR('T'); 2182 TAINTING_set(TRUE); 2183 TAINT_WARN_set(FALSE); 2184 #endif 2185 s++; 2186 goto reswitch; 2187 2188 case 'E': 2189 PL_minus_E = TRUE; 2190 /* FALLTHROUGH */ 2191 case 'e': 2192 forbid_setid('e', FALSE); 2193 if (!PL_e_script) { 2194 PL_e_script = newSVpvs(""); 2195 add_read_e_script = TRUE; 2196 } 2197 if (*++s) 2198 sv_catpv(PL_e_script, s); 2199 else if (argv[1]) { 2200 sv_catpv(PL_e_script, argv[1]); 2201 argc--,argv++; 2202 } 2203 else 2204 Perl_croak(aTHX_ "No code specified for -%c", c); 2205 sv_catpvs(PL_e_script, "\n"); 2206 break; 2207 2208 case 'f': 2209 #ifdef USE_SITECUSTOMIZE 2210 minus_f = TRUE; 2211 #endif 2212 s++; 2213 goto reswitch; 2214 2215 case 'I': /* -I handled both here and in moreswitches() */ 2216 forbid_setid('I', FALSE); 2217 if (!*++s && (s=argv[1]) != NULL) { 2218 argc--,argv++; 2219 } 2220 if (s && *s) { 2221 STRLEN len = strlen(s); 2222 incpush(s, len, INCPUSH_ADD_SUB_DIRS|INCPUSH_ADD_OLD_VERS); 2223 } 2224 else 2225 Perl_croak(aTHX_ "No directory specified for -I"); 2226 break; 2227 case 'S': 2228 forbid_setid('S', FALSE); 2229 dosearch = TRUE; 2230 s++; 2231 goto reswitch; 2232 case 'V': 2233 { 2234 SV *opts_prog; 2235 2236 if (*++s != ':') { 2237 opts_prog = newSVpvs("use Config; Config::_V()"); 2238 } 2239 else { 2240 ++s; 2241 opts_prog = Perl_newSVpvf(aTHX_ 2242 "use Config; Config::config_vars(qw%c%s%c)", 2243 0, s, 0); 2244 s += strlen(s); 2245 } 2246 Perl_av_create_and_push(aTHX_ &PL_preambleav, opts_prog); 2247 /* don't look for script or read stdin */ 2248 scriptname = BIT_BUCKET; 2249 goto reswitch; 2250 } 2251 case 'x': 2252 doextract = TRUE; 2253 s++; 2254 if (*s) 2255 cddir = s; 2256 break; 2257 case 0: 2258 break; 2259 case '-': 2260 if (!*++s || isSPACE(*s)) { 2261 argc--,argv++; 2262 goto switch_end; 2263 } 2264 /* catch use of gnu style long options. 2265 Both of these exit immediately. */ 2266 if (strEQ(s, "version")) 2267 minus_v(); 2268 if (strEQ(s, "help")) 2269 usage(); 2270 s--; 2271 /* FALLTHROUGH */ 2272 default: 2273 Perl_croak(aTHX_ "Unrecognized switch: -%s (-h will show valid options)",s); 2274 } 2275 } 2276 } 2277 2278 switch_end: 2279 2280 { 2281 char *s; 2282 2283 if ( 2284 #ifndef SECURE_INTERNAL_GETENV 2285 !TAINTING_get && 2286 #endif 2287 (s = PerlEnv_getenv("PERL5OPT"))) 2288 { 2289 while (isSPACE(*s)) 2290 s++; 2291 if (*s == '-' && *(s+1) == 'T') { 2292 #if defined(SILENT_NO_TAINT_SUPPORT) 2293 /* silently ignore */ 2294 #elif defined(NO_TAINT_SUPPORT) 2295 Perl_croak_nocontext("This perl was compiled without taint support. " 2296 "Cowardly refusing to run with -t or -T flags"); 2297 #else 2298 CHECK_MALLOC_TOO_LATE_FOR('T'); 2299 TAINTING_set(TRUE); 2300 TAINT_WARN_set(FALSE); 2301 #endif 2302 } 2303 else { 2304 char *popt_copy = NULL; 2305 while (s && *s) { 2306 const char *d; 2307 while (isSPACE(*s)) 2308 s++; 2309 if (*s == '-') { 2310 s++; 2311 if (isSPACE(*s)) 2312 continue; 2313 } 2314 d = s; 2315 if (!*s) 2316 break; 2317 if (!memCHRs("CDIMUdmtwW", *s)) 2318 Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s); 2319 while (++s && *s) { 2320 if (isSPACE(*s)) { 2321 if (!popt_copy) { 2322 popt_copy = SvPVX(sv_2mortal(newSVpv(d,0))); 2323 s = popt_copy + (s - d); 2324 d = popt_copy; 2325 } 2326 *s++ = '\0'; 2327 break; 2328 } 2329 } 2330 if (*d == 't') { 2331 #if defined(SILENT_NO_TAINT_SUPPORT) 2332 /* silently ignore */ 2333 #elif defined(NO_TAINT_SUPPORT) 2334 Perl_croak_nocontext("This perl was compiled without taint support. " 2335 "Cowardly refusing to run with -t or -T flags"); 2336 #else 2337 if( !TAINTING_get) { 2338 TAINT_WARN_set(TRUE); 2339 TAINTING_set(TRUE); 2340 } 2341 #endif 2342 } else { 2343 moreswitches(d); 2344 } 2345 } 2346 } 2347 } 2348 } 2349 2350 #ifndef NO_PERL_INTERNAL_RAND_SEED 2351 /* If we're not set[ug]id, we might have honored 2352 PERL_INTERNAL_RAND_SEED in perl_construct(). 2353 At this point command-line options have been parsed, so if 2354 we're now tainting and not set[ug]id re-seed. 2355 This could possibly be wasteful if PERL_INTERNAL_RAND_SEED is invalid, 2356 but avoids duplicating the logic from perl_construct(). 2357 */ 2358 if (TAINT_get && 2359 PerlProc_getuid() == PerlProc_geteuid() && 2360 PerlProc_getgid() == PerlProc_getegid()) { 2361 Perl_drand48_init_r(&PL_internal_random_state, seed()); 2362 } 2363 #endif 2364 2365 /* Set $^X early so that it can be used for relocatable paths in @INC */ 2366 /* and for SITELIB_EXP in USE_SITECUSTOMIZE */ 2367 assert (!TAINT_get); 2368 TAINT; 2369 set_caret_X(); 2370 TAINT_NOT; 2371 2372 #if defined(USE_SITECUSTOMIZE) 2373 if (!minus_f) { 2374 /* The games with local $! are to avoid setting errno if there is no 2375 sitecustomize script. "q%c...%c", 0, ..., 0 becomes "q\0...\0", 2376 ie a q() operator with a NUL byte as a the delimiter. This avoids 2377 problems with pathnames containing (say) ' */ 2378 # ifdef PERL_IS_MINIPERL 2379 AV *const inc = GvAV(PL_incgv); 2380 SV **const inc0 = inc ? av_fetch(inc, 0, FALSE) : NULL; 2381 2382 if (inc0) { 2383 /* if lib/buildcustomize.pl exists, it should not fail. If it does, 2384 it should be reported immediately as a build failure. */ 2385 (void)Perl_av_create_and_unshift_one(aTHX_ &PL_preambleav, 2386 Perl_newSVpvf(aTHX_ 2387 "BEGIN { my $f = q%c%s%" SVf "/buildcustomize.pl%c; " 2388 "do {local $!; -f $f }" 2389 " and do $f || die $@ || qq '$f: $!' }", 2390 0, (TAINTING_get ? "./" : ""), SVfARG(*inc0), 0)); 2391 } 2392 # else 2393 /* SITELIB_EXP is a function call on Win32. */ 2394 const char *const raw_sitelib = SITELIB_EXP; 2395 if (raw_sitelib) { 2396 /* process .../.. if PERL_RELOCATABLE_INC is defined */ 2397 SV *sitelib_sv = mayberelocate(raw_sitelib, strlen(raw_sitelib), 2398 INCPUSH_CAN_RELOCATE); 2399 const char *const sitelib = SvPVX(sitelib_sv); 2400 (void)Perl_av_create_and_unshift_one(aTHX_ &PL_preambleav, 2401 Perl_newSVpvf(aTHX_ 2402 "BEGIN { do {local $!; -f q%c%s/sitecustomize.pl%c} && do q%c%s/sitecustomize.pl%c }", 2403 0, SVfARG(sitelib), 0, 2404 0, SVfARG(sitelib), 0)); 2405 assert (SvREFCNT(sitelib_sv) == 1); 2406 SvREFCNT_dec(sitelib_sv); 2407 } 2408 # endif 2409 } 2410 #endif 2411 2412 if (!scriptname) 2413 scriptname = argv[0]; 2414 if (PL_e_script) { 2415 argc++,argv--; 2416 scriptname = BIT_BUCKET; /* don't look for script or read stdin */ 2417 } 2418 else if (scriptname == NULL) { 2419 #ifdef MSDOS 2420 if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) ) 2421 moreswitches("h"); 2422 #endif 2423 scriptname = "-"; 2424 } 2425 2426 assert (!TAINT_get); 2427 init_perllib(); 2428 2429 { 2430 bool suidscript = FALSE; 2431 2432 rsfp = open_script(scriptname, dosearch, &suidscript); 2433 if (!rsfp) { 2434 rsfp = PerlIO_stdin(); 2435 lex_start_flags = LEX_DONT_CLOSE_RSFP; 2436 } 2437 2438 validate_suid(rsfp); 2439 2440 #ifndef PERL_MICRO 2441 # if defined(SIGCHLD) || defined(SIGCLD) 2442 { 2443 # ifndef SIGCHLD 2444 # define SIGCHLD SIGCLD 2445 # endif 2446 Sighandler_t sigstate = rsignal_state(SIGCHLD); 2447 if (sigstate == (Sighandler_t) SIG_IGN) { 2448 Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), 2449 "Can't ignore signal CHLD, forcing to default"); 2450 (void)rsignal(SIGCHLD, (Sighandler_t)SIG_DFL); 2451 } 2452 } 2453 # endif 2454 #endif 2455 2456 if (doextract) { 2457 2458 /* This will croak if suidscript is true, as -x cannot be used with 2459 setuid scripts. */ 2460 forbid_setid('x', suidscript); 2461 /* Hence you can't get here if suidscript is true */ 2462 2463 linestr_sv = newSV_type(SVt_PV); 2464 lex_start_flags |= LEX_START_COPIED; 2465 find_beginning(linestr_sv, rsfp); 2466 if (cddir && PerlDir_chdir( (char *)cddir ) < 0) 2467 Perl_croak(aTHX_ "Can't chdir to %s",cddir); 2468 } 2469 } 2470 2471 PL_main_cv = PL_compcv = MUTABLE_CV(newSV_type(SVt_PVCV)); 2472 CvUNIQUE_on(PL_compcv); 2473 2474 CvPADLIST_set(PL_compcv, pad_new(0)); 2475 2476 PL_isarev = newHV(); 2477 2478 boot_core_PerlIO(); 2479 boot_core_UNIVERSAL(); 2480 boot_core_mro(); 2481 newXS("Internals::V", S_Internals_V, __FILE__); 2482 2483 if (xsinit) 2484 (*xsinit)(aTHX); /* in case linked C routines want magical variables */ 2485 #ifndef PERL_MICRO 2486 #if defined(VMS) || defined(WIN32) || defined(DJGPP) || defined(__CYGWIN__) || defined(SYMBIAN) 2487 init_os_extras(); 2488 #endif 2489 #endif 2490 2491 #ifdef USE_SOCKS 2492 # ifdef HAS_SOCKS5_INIT 2493 socks5_init(argv[0]); 2494 # else 2495 SOCKSinit(argv[0]); 2496 # endif 2497 #endif 2498 2499 init_predump_symbols(); 2500 /* init_postdump_symbols not currently designed to be called */ 2501 /* more than once (ENV isn't cleared first, for example) */ 2502 /* But running with -u leaves %ENV & @ARGV undefined! XXX */ 2503 if (!PL_do_undump) 2504 init_postdump_symbols(argc,argv,env); 2505 2506 /* PL_unicode is turned on by -C, or by $ENV{PERL_UNICODE}, 2507 * or explicitly in some platforms. 2508 * PL_utf8locale is conditionally turned on by 2509 * locale.c:Perl_init_i18nl10n() if the environment 2510 * look like the user wants to use UTF-8. */ 2511 #if defined(__SYMBIAN32__) 2512 PL_unicode = PERL_UNICODE_STD_FLAG; /* See PERL_SYMBIAN_CONSOLE_UTF8. */ 2513 #endif 2514 # ifndef PERL_IS_MINIPERL 2515 if (PL_unicode) { 2516 /* Requires init_predump_symbols(). */ 2517 if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) { 2518 IO* io; 2519 PerlIO* fp; 2520 SV* sv; 2521 2522 /* Turn on UTF-8-ness on STDIN, STDOUT, STDERR 2523 * and the default open disciplines. */ 2524 if ((PL_unicode & PERL_UNICODE_STDIN_FLAG) && 2525 PL_stdingv && (io = GvIO(PL_stdingv)) && 2526 (fp = IoIFP(io))) 2527 PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8"); 2528 if ((PL_unicode & PERL_UNICODE_STDOUT_FLAG) && 2529 PL_defoutgv && (io = GvIO(PL_defoutgv)) && 2530 (fp = IoOFP(io))) 2531 PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8"); 2532 if ((PL_unicode & PERL_UNICODE_STDERR_FLAG) && 2533 PL_stderrgv && (io = GvIO(PL_stderrgv)) && 2534 (fp = IoOFP(io))) 2535 PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8"); 2536 if ((PL_unicode & PERL_UNICODE_INOUT_FLAG) && 2537 (sv = GvSV(gv_fetchpvs("\017PEN", GV_ADD|GV_NOTQUAL, 2538 SVt_PV)))) { 2539 U32 in = PL_unicode & PERL_UNICODE_IN_FLAG; 2540 U32 out = PL_unicode & PERL_UNICODE_OUT_FLAG; 2541 if (in) { 2542 if (out) 2543 sv_setpvs(sv, ":utf8\0:utf8"); 2544 else 2545 sv_setpvs(sv, ":utf8\0"); 2546 } 2547 else if (out) 2548 sv_setpvs(sv, "\0:utf8"); 2549 SvSETMAGIC(sv); 2550 } 2551 } 2552 } 2553 #endif 2554 2555 { 2556 const char *s; 2557 if ((s = PerlEnv_getenv("PERL_SIGNALS"))) { 2558 if (strEQ(s, "unsafe")) 2559 PL_signals |= PERL_SIGNALS_UNSAFE_FLAG; 2560 else if (strEQ(s, "safe")) 2561 PL_signals &= ~PERL_SIGNALS_UNSAFE_FLAG; 2562 else 2563 Perl_croak(aTHX_ "PERL_SIGNALS illegal: \"%s\"", s); 2564 } 2565 } 2566 2567 2568 lex_start(linestr_sv, rsfp, lex_start_flags); 2569 SvREFCNT_dec(linestr_sv); 2570 2571 PL_subname = newSVpvs("main"); 2572 2573 if (add_read_e_script) 2574 filter_add(read_e_script, NULL); 2575 2576 /* now parse the script */ 2577 2578 SETERRNO(0,SS_NORMAL); 2579 if (yyparse(GRAMPROG) || PL_parser->error_count) { 2580 abort_execution("", PL_origfilename); 2581 } 2582 CopLINE_set(PL_curcop, 0); 2583 SET_CURSTASH(PL_defstash); 2584 if (PL_e_script) { 2585 SvREFCNT_dec(PL_e_script); 2586 PL_e_script = NULL; 2587 } 2588 2589 if (PL_do_undump) 2590 my_unexec(); 2591 2592 if (isWARN_ONCE) { 2593 SAVECOPFILE(PL_curcop); 2594 SAVECOPLINE(PL_curcop); 2595 gv_check(PL_defstash); 2596 } 2597 2598 LEAVE; 2599 FREETMPS; 2600 2601 #ifdef MYMALLOC 2602 { 2603 const char *s; 2604 UV uv; 2605 s = PerlEnv_getenv("PERL_DEBUG_MSTATS"); 2606 if (s && grok_atoUV(s, &uv, NULL) && uv >= 2) 2607 dump_mstats("after compilation:"); 2608 } 2609 #endif 2610 2611 ENTER; 2612 PL_restartjmpenv = NULL; 2613 PL_restartop = 0; 2614 return NULL; 2615 } 2616 2617 /* 2618 =for apidoc perl_run 2619 2620 Tells a Perl interpreter to run its main program. See L<perlembed> 2621 for a tutorial. 2622 2623 C<my_perl> points to the Perl interpreter. It must have been previously 2624 created through the use of L</perl_alloc> and L</perl_construct>, and 2625 initialised through L</perl_parse>. This function should not be called 2626 if L</perl_parse> returned a non-zero value, indicating a failure in 2627 initialisation or compilation. 2628 2629 This function executes code in C<INIT> blocks, and then executes the 2630 main program. The code to be executed is that established by the prior 2631 call to L</perl_parse>. If the interpreter's C<PL_exit_flags> word 2632 does not have the C<PERL_EXIT_DESTRUCT_END> flag set, then this function 2633 will also execute code in C<END> blocks. If it is desired to make any 2634 further use of the interpreter after calling this function, then C<END> 2635 blocks should be postponed to L</perl_destruct> time by setting that flag. 2636 2637 Returns an integer of slightly tricky interpretation. The correct use 2638 of the return value is as a truth value indicating whether the program 2639 terminated non-locally. If zero is returned, this indicates that 2640 the program ran to completion, and it is safe to make other use of the 2641 interpreter (provided that the C<PERL_EXIT_DESTRUCT_END> flag was set as 2642 described above). If a non-zero value is returned, this indicates that 2643 the interpreter wants to terminate early. The interpreter should not be 2644 just abandoned because of this desire to terminate; the caller should 2645 proceed to shut the interpreter down cleanly with L</perl_destruct> 2646 and free it with L</perl_free>. 2647 2648 For historical reasons, the non-zero return value also attempts to 2649 be a suitable value to pass to the C library function C<exit> (or to 2650 return from C<main>), to serve as an exit code indicating the nature of 2651 the way the program terminated. However, this isn't portable, due to 2652 differing exit code conventions. An attempt is made to return an exit 2653 code of the type required by the host operating system, but because 2654 it is constrained to be non-zero, it is not necessarily possible to 2655 indicate every type of exit. It is only reliable on Unix, where a zero 2656 exit code can be augmented with a set bit that will be ignored. In any 2657 case, this function is not the correct place to acquire an exit code: 2658 one should get that from L</perl_destruct>. 2659 2660 =cut 2661 */ 2662 2663 int 2664 perl_run(pTHXx) 2665 { 2666 I32 oldscope; 2667 int ret = 0; 2668 dJMPENV; 2669 2670 PERL_ARGS_ASSERT_PERL_RUN; 2671 #ifndef MULTIPLICITY 2672 PERL_UNUSED_ARG(my_perl); 2673 #endif 2674 2675 oldscope = PL_scopestack_ix; 2676 #ifdef VMS 2677 VMSISH_HUSHED = 0; 2678 #endif 2679 2680 JMPENV_PUSH(ret); 2681 switch (ret) { 2682 case 1: 2683 cxstack_ix = -1; /* start context stack again */ 2684 goto redo_body; 2685 case 0: /* normal completion */ 2686 redo_body: 2687 run_body(oldscope); 2688 /* FALLTHROUGH */ 2689 case 2: /* my_exit() */ 2690 while (PL_scopestack_ix > oldscope) 2691 LEAVE; 2692 FREETMPS; 2693 SET_CURSTASH(PL_defstash); 2694 if (!(PL_exit_flags & PERL_EXIT_DESTRUCT_END) && 2695 PL_endav && !PL_minus_c) { 2696 PERL_SET_PHASE(PERL_PHASE_END); 2697 call_list(oldscope, PL_endav); 2698 } 2699 #ifdef MYMALLOC 2700 if (PerlEnv_getenv("PERL_DEBUG_MSTATS")) 2701 dump_mstats("after execution: "); 2702 #endif 2703 ret = STATUS_EXIT; 2704 break; 2705 case 3: 2706 if (PL_restartop) { 2707 POPSTACK_TO(PL_mainstack); 2708 goto redo_body; 2709 } 2710 PerlIO_printf(Perl_error_log, "panic: restartop in perl_run\n"); 2711 FREETMPS; 2712 ret = 1; 2713 break; 2714 } 2715 2716 JMPENV_POP; 2717 return ret; 2718 } 2719 2720 STATIC void 2721 S_run_body(pTHX_ I32 oldscope) 2722 { 2723 DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support (0x%x).\n", 2724 PL_sawampersand ? "Enabling" : "Omitting", 2725 (unsigned int)(PL_sawampersand))); 2726 2727 if (!PL_restartop) { 2728 #ifdef DEBUGGING 2729 if (DEBUG_x_TEST || DEBUG_B_TEST) 2730 dump_all_perl(!DEBUG_B_TEST); 2731 if (!DEBUG_q_TEST) 2732 PERL_DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n")); 2733 #endif 2734 2735 if (PL_minus_c) { 2736 PerlIO_printf(Perl_error_log, "%s syntax OK\n", PL_origfilename); 2737 my_exit(0); 2738 } 2739 if (PERLDB_SINGLE && PL_DBsingle) 2740 PL_DBsingle_iv = 1; 2741 if (PL_initav) { 2742 PERL_SET_PHASE(PERL_PHASE_INIT); 2743 call_list(oldscope, PL_initav); 2744 } 2745 #ifdef PERL_DEBUG_READONLY_OPS 2746 if (PL_main_root && PL_main_root->op_slabbed) 2747 Slab_to_ro(OpSLAB(PL_main_root)); 2748 #endif 2749 } 2750 2751 /* do it */ 2752 2753 PERL_SET_PHASE(PERL_PHASE_RUN); 2754 2755 if (PL_restartop) { 2756 PL_restartjmpenv = NULL; 2757 PL_op = PL_restartop; 2758 PL_restartop = 0; 2759 CALLRUNOPS(aTHX); 2760 } 2761 else if (PL_main_start) { 2762 CvDEPTH(PL_main_cv) = 1; 2763 PL_op = PL_main_start; 2764 CALLRUNOPS(aTHX); 2765 } 2766 my_exit(0); 2767 NOT_REACHED; /* NOTREACHED */ 2768 } 2769 2770 /* 2771 =head1 SV Manipulation Functions 2772 2773 =for apidoc get_sv 2774 2775 Returns the SV of the specified Perl scalar. C<flags> are passed to 2776 C<gv_fetchpv>. If C<GV_ADD> is set and the 2777 Perl variable does not exist then it will be created. If C<flags> is zero 2778 and the variable does not exist then NULL is returned. 2779 2780 =cut 2781 */ 2782 2783 SV* 2784 Perl_get_sv(pTHX_ const char *name, I32 flags) 2785 { 2786 GV *gv; 2787 2788 PERL_ARGS_ASSERT_GET_SV; 2789 2790 gv = gv_fetchpv(name, flags, SVt_PV); 2791 if (gv) 2792 return GvSV(gv); 2793 return NULL; 2794 } 2795 2796 /* 2797 =head1 Array Manipulation Functions 2798 2799 =for apidoc get_av 2800 2801 Returns the AV of the specified Perl global or package array with the given 2802 name (so it won't work on lexical variables). C<flags> are passed 2803 to C<gv_fetchpv>. If C<GV_ADD> is set and the 2804 Perl variable does not exist then it will be created. If C<flags> is zero 2805 and the variable does not exist then NULL is returned. 2806 2807 Perl equivalent: C<@{"$name"}>. 2808 2809 =cut 2810 */ 2811 2812 AV* 2813 Perl_get_av(pTHX_ const char *name, I32 flags) 2814 { 2815 GV* const gv = gv_fetchpv(name, flags, SVt_PVAV); 2816 2817 PERL_ARGS_ASSERT_GET_AV; 2818 2819 if (flags) 2820 return GvAVn(gv); 2821 if (gv) 2822 return GvAV(gv); 2823 return NULL; 2824 } 2825 2826 /* 2827 =head1 Hash Manipulation Functions 2828 2829 =for apidoc get_hv 2830 2831 Returns the HV of the specified Perl hash. C<flags> are passed to 2832 C<gv_fetchpv>. If C<GV_ADD> is set and the 2833 Perl variable does not exist then it will be created. If C<flags> is zero 2834 and the variable does not exist then C<NULL> is returned. 2835 2836 =cut 2837 */ 2838 2839 HV* 2840 Perl_get_hv(pTHX_ const char *name, I32 flags) 2841 { 2842 GV* const gv = gv_fetchpv(name, flags, SVt_PVHV); 2843 2844 PERL_ARGS_ASSERT_GET_HV; 2845 2846 if (flags) 2847 return GvHVn(gv); 2848 if (gv) 2849 return GvHV(gv); 2850 return NULL; 2851 } 2852 2853 /* 2854 =head1 CV Manipulation Functions 2855 2856 =for apidoc get_cvn_flags 2857 2858 Returns the CV of the specified Perl subroutine. C<flags> are passed to 2859 C<gv_fetchpvn_flags>. If C<GV_ADD> is set and the Perl subroutine does not 2860 exist then it will be declared (which has the same effect as saying 2861 C<sub name;>). If C<GV_ADD> is not set and the subroutine does not exist 2862 then NULL is returned. 2863 2864 =for apidoc get_cv 2865 2866 Uses C<strlen> to get the length of C<name>, then calls C<get_cvn_flags>. 2867 2868 =cut 2869 */ 2870 2871 CV* 2872 Perl_get_cvn_flags(pTHX_ const char *name, STRLEN len, I32 flags) 2873 { 2874 GV* const gv = gv_fetchpvn_flags(name, len, flags, SVt_PVCV); 2875 2876 PERL_ARGS_ASSERT_GET_CVN_FLAGS; 2877 2878 if (gv && UNLIKELY(SvROK(gv)) && SvTYPE(SvRV((SV *)gv)) == SVt_PVCV) 2879 return (CV*)SvRV((SV *)gv); 2880 2881 /* XXX this is probably not what they think they're getting. 2882 * It has the same effect as "sub name;", i.e. just a forward 2883 * declaration! */ 2884 if ((flags & ~GV_NOADD_MASK) && !GvCVu(gv)) { 2885 return newSTUB(gv,0); 2886 } 2887 if (gv) 2888 return GvCVu(gv); 2889 return NULL; 2890 } 2891 2892 /* Nothing in core calls this now, but we can't replace it with a macro and 2893 move it to mathoms.c as a macro would evaluate name twice. */ 2894 CV* 2895 Perl_get_cv(pTHX_ const char *name, I32 flags) 2896 { 2897 PERL_ARGS_ASSERT_GET_CV; 2898 2899 return get_cvn_flags(name, strlen(name), flags); 2900 } 2901 2902 /* Be sure to refetch the stack pointer after calling these routines. */ 2903 2904 /* 2905 2906 =head1 Callback Functions 2907 2908 =for apidoc call_argv 2909 2910 Performs a callback to the specified named and package-scoped Perl subroutine 2911 with C<argv> (a C<NULL>-terminated array of strings) as arguments. See 2912 L<perlcall>. 2913 2914 Approximate Perl equivalent: C<&{"$sub_name"}(@$argv)>. 2915 2916 =cut 2917 */ 2918 2919 I32 2920 Perl_call_argv(pTHX_ const char *sub_name, I32 flags, char **argv) 2921 2922 /* See G_* flags in cop.h */ 2923 /* null terminated arg list */ 2924 { 2925 dSP; 2926 2927 PERL_ARGS_ASSERT_CALL_ARGV; 2928 2929 PUSHMARK(SP); 2930 while (*argv) { 2931 mXPUSHs(newSVpv(*argv,0)); 2932 argv++; 2933 } 2934 PUTBACK; 2935 return call_pv(sub_name, flags); 2936 } 2937 2938 /* 2939 =for apidoc call_pv 2940 2941 Performs a callback to the specified Perl sub. See L<perlcall>. 2942 2943 =cut 2944 */ 2945 2946 I32 2947 Perl_call_pv(pTHX_ const char *sub_name, I32 flags) 2948 /* name of the subroutine */ 2949 /* See G_* flags in cop.h */ 2950 { 2951 PERL_ARGS_ASSERT_CALL_PV; 2952 2953 return call_sv(MUTABLE_SV(get_cv(sub_name, GV_ADD)), flags); 2954 } 2955 2956 /* 2957 =for apidoc call_method 2958 2959 Performs a callback to the specified Perl method. The blessed object must 2960 be on the stack. See L<perlcall>. 2961 2962 =cut 2963 */ 2964 2965 I32 2966 Perl_call_method(pTHX_ const char *methname, I32 flags) 2967 /* name of the subroutine */ 2968 /* See G_* flags in cop.h */ 2969 { 2970 STRLEN len; 2971 SV* sv; 2972 PERL_ARGS_ASSERT_CALL_METHOD; 2973 2974 len = strlen(methname); 2975 sv = flags & G_METHOD_NAMED 2976 ? sv_2mortal(newSVpvn_share(methname, len,0)) 2977 : newSVpvn_flags(methname, len, SVs_TEMP); 2978 2979 return call_sv(sv, flags | G_METHOD); 2980 } 2981 2982 /* May be called with any of a CV, a GV, or an SV containing the name. */ 2983 /* 2984 =for apidoc call_sv 2985 2986 Performs a callback to the Perl sub specified by the SV. 2987 2988 If neither the C<G_METHOD> nor C<G_METHOD_NAMED> flag is supplied, the 2989 SV may be any of a CV, a GV, a reference to a CV, a reference to a GV 2990 or C<SvPV(sv)> will be used as the name of the sub to call. 2991 2992 If the C<G_METHOD> flag is supplied, the SV may be a reference to a CV or 2993 C<SvPV(sv)> will be used as the name of the method to call. 2994 2995 If the C<G_METHOD_NAMED> flag is supplied, C<SvPV(sv)> will be used as 2996 the name of the method to call. 2997 2998 Some other values are treated specially for internal use and should 2999 not be depended on. 3000 3001 See L<perlcall>. 3002 3003 =for apidoc Amnh||G_METHOD 3004 =for apidoc Amnh||G_METHOD_NAMED 3005 3006 =cut 3007 */ 3008 3009 I32 3010 Perl_call_sv(pTHX_ SV *sv, volatile I32 flags) 3011 /* See G_* flags in cop.h */ 3012 { 3013 dVAR; 3014 LOGOP myop; /* fake syntax tree node */ 3015 METHOP method_op; 3016 I32 oldmark; 3017 volatile I32 retval = 0; 3018 bool oldcatch = CATCH_GET; 3019 int ret; 3020 OP* const oldop = PL_op; 3021 dJMPENV; 3022 3023 PERL_ARGS_ASSERT_CALL_SV; 3024 3025 if (flags & G_DISCARD) { 3026 ENTER; 3027 SAVETMPS; 3028 } 3029 if (!(flags & G_WANT)) { 3030 /* Backwards compatibility - as G_SCALAR was 0, it could be omitted. 3031 */ 3032 flags |= G_SCALAR; 3033 } 3034 3035 Zero(&myop, 1, LOGOP); 3036 if (!(flags & G_NOARGS)) 3037 myop.op_flags |= OPf_STACKED; 3038 myop.op_flags |= OP_GIMME_REVERSE(flags); 3039 SAVEOP(); 3040 PL_op = (OP*)&myop; 3041 3042 if (!(flags & G_METHOD_NAMED)) { 3043 dSP; 3044 EXTEND(SP, 1); 3045 PUSHs(sv); 3046 PUTBACK; 3047 } 3048 oldmark = TOPMARK; 3049 3050 if (PERLDB_SUB && PL_curstash != PL_debstash 3051 /* Handle first BEGIN of -d. */ 3052 && (PL_DBcv || (PL_DBcv = GvCV(PL_DBsub))) 3053 /* Try harder, since this may have been a sighandler, thus 3054 * curstash may be meaningless. */ 3055 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((const CV *)sv) != PL_debstash) 3056 && !(flags & G_NODEBUG)) 3057 myop.op_private |= OPpENTERSUB_DB; 3058 3059 if (flags & (G_METHOD|G_METHOD_NAMED)) { 3060 Zero(&method_op, 1, METHOP); 3061 method_op.op_next = (OP*)&myop; 3062 PL_op = (OP*)&method_op; 3063 if ( flags & G_METHOD_NAMED ) { 3064 method_op.op_ppaddr = PL_ppaddr[OP_METHOD_NAMED]; 3065 method_op.op_type = OP_METHOD_NAMED; 3066 method_op.op_u.op_meth_sv = sv; 3067 } else { 3068 method_op.op_ppaddr = PL_ppaddr[OP_METHOD]; 3069 method_op.op_type = OP_METHOD; 3070 } 3071 myop.op_ppaddr = PL_ppaddr[OP_ENTERSUB]; 3072 myop.op_type = OP_ENTERSUB; 3073 } 3074 3075 if (!(flags & G_EVAL)) { 3076 CATCH_SET(TRUE); 3077 CALL_BODY_SUB((OP*)&myop); 3078 retval = PL_stack_sp - (PL_stack_base + oldmark); 3079 CATCH_SET(oldcatch); 3080 } 3081 else { 3082 I32 old_cxix; 3083 myop.op_other = (OP*)&myop; 3084 (void)POPMARK; 3085 old_cxix = cxstack_ix; 3086 create_eval_scope(NULL, flags|G_FAKINGEVAL); 3087 INCMARK; 3088 3089 JMPENV_PUSH(ret); 3090 3091 switch (ret) { 3092 case 0: 3093 redo_body: 3094 CALL_BODY_SUB((OP*)&myop); 3095 retval = PL_stack_sp - (PL_stack_base + oldmark); 3096 if (!(flags & G_KEEPERR)) { 3097 CLEAR_ERRSV(); 3098 } 3099 break; 3100 case 1: 3101 STATUS_ALL_FAILURE; 3102 /* FALLTHROUGH */ 3103 case 2: 3104 /* my_exit() was called */ 3105 SET_CURSTASH(PL_defstash); 3106 FREETMPS; 3107 JMPENV_POP; 3108 my_exit_jump(); 3109 NOT_REACHED; /* NOTREACHED */ 3110 case 3: 3111 if (PL_restartop) { 3112 PL_restartjmpenv = NULL; 3113 PL_op = PL_restartop; 3114 PL_restartop = 0; 3115 goto redo_body; 3116 } 3117 PL_stack_sp = PL_stack_base + oldmark; 3118 if ((flags & G_WANT) == G_ARRAY) 3119 retval = 0; 3120 else { 3121 retval = 1; 3122 *++PL_stack_sp = &PL_sv_undef; 3123 } 3124 break; 3125 } 3126 3127 /* if we croaked, depending on how we croaked the eval scope 3128 * may or may not have already been popped */ 3129 if (cxstack_ix > old_cxix) { 3130 assert(cxstack_ix == old_cxix + 1); 3131 assert(CxTYPE(CX_CUR()) == CXt_EVAL); 3132 delete_eval_scope(); 3133 } 3134 JMPENV_POP; 3135 } 3136 3137 if (flags & G_DISCARD) { 3138 PL_stack_sp = PL_stack_base + oldmark; 3139 retval = 0; 3140 FREETMPS; 3141 LEAVE; 3142 } 3143 PL_op = oldop; 3144 return retval; 3145 } 3146 3147 /* Eval a string. The G_EVAL flag is always assumed. */ 3148 3149 /* 3150 =for apidoc eval_sv 3151 3152 Tells Perl to C<eval> the string in the SV. It supports the same flags 3153 as C<call_sv>, with the obvious exception of C<G_EVAL>. See L<perlcall>. 3154 3155 The C<G_RETHROW> flag can be used if you only need eval_sv() to 3156 execute code specified by a string, but not catch any errors. 3157 3158 =for apidoc Amnh||G_RETHROW 3159 =cut 3160 */ 3161 3162 I32 3163 Perl_eval_sv(pTHX_ SV *sv, I32 flags) 3164 3165 /* See G_* flags in cop.h */ 3166 { 3167 dVAR; 3168 UNOP myop; /* fake syntax tree node */ 3169 volatile I32 oldmark; 3170 volatile I32 retval = 0; 3171 int ret; 3172 OP* const oldop = PL_op; 3173 dJMPENV; 3174 3175 PERL_ARGS_ASSERT_EVAL_SV; 3176 3177 if (flags & G_DISCARD) { 3178 ENTER; 3179 SAVETMPS; 3180 } 3181 3182 SAVEOP(); 3183 PL_op = (OP*)&myop; 3184 Zero(&myop, 1, UNOP); 3185 { 3186 dSP; 3187 oldmark = SP - PL_stack_base; 3188 EXTEND(SP, 1); 3189 PUSHs(sv); 3190 PUTBACK; 3191 } 3192 3193 if (!(flags & G_NOARGS)) 3194 myop.op_flags = OPf_STACKED; 3195 myop.op_type = OP_ENTEREVAL; 3196 myop.op_flags |= OP_GIMME_REVERSE(flags); 3197 if (flags & G_KEEPERR) 3198 myop.op_flags |= OPf_SPECIAL; 3199 3200 if (flags & G_RE_REPARSING) 3201 myop.op_private = (OPpEVAL_COPHH | OPpEVAL_RE_REPARSING); 3202 3203 /* fail now; otherwise we could fail after the JMPENV_PUSH but 3204 * before a cx_pusheval(), which corrupts the stack after a croak */ 3205 TAINT_PROPER("eval_sv()"); 3206 3207 JMPENV_PUSH(ret); 3208 switch (ret) { 3209 case 0: 3210 redo_body: 3211 if (PL_op == (OP*)(&myop)) { 3212 PL_op = PL_ppaddr[OP_ENTEREVAL](aTHX); 3213 if (!PL_op) 3214 goto fail; /* failed in compilation */ 3215 } 3216 CALLRUNOPS(aTHX); 3217 retval = PL_stack_sp - (PL_stack_base + oldmark); 3218 if (!(flags & G_KEEPERR)) { 3219 CLEAR_ERRSV(); 3220 } 3221 break; 3222 case 1: 3223 STATUS_ALL_FAILURE; 3224 /* FALLTHROUGH */ 3225 case 2: 3226 /* my_exit() was called */ 3227 SET_CURSTASH(PL_defstash); 3228 FREETMPS; 3229 JMPENV_POP; 3230 my_exit_jump(); 3231 NOT_REACHED; /* NOTREACHED */ 3232 case 3: 3233 if (PL_restartop) { 3234 PL_restartjmpenv = NULL; 3235 PL_op = PL_restartop; 3236 PL_restartop = 0; 3237 goto redo_body; 3238 } 3239 fail: 3240 if (flags & G_RETHROW) { 3241 JMPENV_POP; 3242 croak_sv(ERRSV); 3243 } 3244 3245 PL_stack_sp = PL_stack_base + oldmark; 3246 if ((flags & G_WANT) == G_ARRAY) 3247 retval = 0; 3248 else { 3249 retval = 1; 3250 *++PL_stack_sp = &PL_sv_undef; 3251 } 3252 break; 3253 } 3254 3255 JMPENV_POP; 3256 if (flags & G_DISCARD) { 3257 PL_stack_sp = PL_stack_base + oldmark; 3258 retval = 0; 3259 FREETMPS; 3260 LEAVE; 3261 } 3262 PL_op = oldop; 3263 return retval; 3264 } 3265 3266 /* 3267 =for apidoc eval_pv 3268 3269 Tells Perl to C<eval> the given string in scalar context and return an SV* result. 3270 3271 =cut 3272 */ 3273 3274 SV* 3275 Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error) 3276 { 3277 SV* sv = newSVpv(p, 0); 3278 3279 PERL_ARGS_ASSERT_EVAL_PV; 3280 3281 if (croak_on_error) { 3282 sv_2mortal(sv); 3283 eval_sv(sv, G_SCALAR | G_RETHROW); 3284 } 3285 else { 3286 eval_sv(sv, G_SCALAR); 3287 SvREFCNT_dec(sv); 3288 } 3289 3290 { 3291 dSP; 3292 sv = POPs; 3293 PUTBACK; 3294 } 3295 3296 return sv; 3297 } 3298 3299 /* Require a module. */ 3300 3301 /* 3302 =head1 Embedding Functions 3303 3304 =for apidoc require_pv 3305 3306 Tells Perl to C<require> the file named by the string argument. It is 3307 analogous to the Perl code C<eval "require '$file'">. It's even 3308 implemented that way; consider using load_module instead. 3309 3310 =cut */ 3311 3312 void 3313 Perl_require_pv(pTHX_ const char *pv) 3314 { 3315 dSP; 3316 SV* sv; 3317 3318 PERL_ARGS_ASSERT_REQUIRE_PV; 3319 3320 PUSHSTACKi(PERLSI_REQUIRE); 3321 sv = Perl_newSVpvf(aTHX_ "require q%c%s%c", 0, pv, 0); 3322 eval_sv(sv_2mortal(sv), G_DISCARD); 3323 POPSTACK; 3324 } 3325 3326 STATIC void 3327 S_usage(pTHX) /* XXX move this out into a module ? */ 3328 { 3329 /* This message really ought to be max 23 lines. 3330 * Removed -h because the user already knows that option. Others? */ 3331 3332 /* Grouped as 6 lines per C string literal, to keep under the ANSI C 89 3333 minimum of 509 character string literals. */ 3334 static const char * const usage_msg[] = { 3335 " -0[octal] specify record separator (\\0, if no argument)\n" 3336 " -a autosplit mode with -n or -p (splits $_ into @F)\n" 3337 " -C[number/list] enables the listed Unicode features\n" 3338 " -c check syntax only (runs BEGIN and CHECK blocks)\n" 3339 " -d[:debugger] run program under debugger\n" 3340 " -D[number/list] set debugging flags (argument is a bit mask or alphabets)\n", 3341 " -e program one line of program (several -e's allowed, omit programfile)\n" 3342 " -E program like -e, but enables all optional features\n" 3343 " -f don't do $sitelib/sitecustomize.pl at startup\n" 3344 " -F/pattern/ split() pattern for -a switch (//'s are optional)\n" 3345 " -i[extension] edit <> files in place (makes backup if extension supplied)\n" 3346 " -Idirectory specify @INC/#include directory (several -I's allowed)\n", 3347 " -l[octal] enable line ending processing, specifies line terminator\n" 3348 " -[mM][-]module execute \"use/no module...\" before executing program\n" 3349 " -n assume \"while (<>) { ... }\" loop around program\n" 3350 " -p assume loop like -n but print line also, like sed\n" 3351 " -s enable rudimentary parsing for switches after programfile\n" 3352 " -S look for programfile using PATH environment variable\n", 3353 " -t enable tainting warnings\n" 3354 " -T enable tainting checks\n" 3355 " -u dump core after parsing program\n" 3356 " -U allow unsafe operations\n" 3357 " -v print version, patchlevel and license\n" 3358 " -V[:variable] print configuration summary (or a single Config.pm variable)\n", 3359 " -w enable many useful warnings\n" 3360 " -W enable all warnings\n" 3361 " -x[directory] ignore text before #!perl line (optionally cd to directory)\n" 3362 " -X disable all warnings\n" 3363 " \n" 3364 "Run 'perldoc perl' for more help with Perl.\n\n", 3365 NULL 3366 }; 3367 const char * const *p = usage_msg; 3368 PerlIO *out = PerlIO_stdout(); 3369 3370 PerlIO_printf(out, 3371 "\nUsage: %s [switches] [--] [programfile] [arguments]\n", 3372 PL_origargv[0]); 3373 while (*p) 3374 PerlIO_puts(out, *p++); 3375 my_exit(0); 3376 } 3377 3378 /* convert a string of -D options (or digits) into an int. 3379 * sets *s to point to the char after the options */ 3380 3381 #ifdef DEBUGGING 3382 int 3383 Perl_get_debug_opts(pTHX_ const char **s, bool givehelp) 3384 { 3385 static const char * const usage_msgd[] = { 3386 " Debugging flag values: (see also -d)\n" 3387 " p Tokenizing and parsing (with v, displays parse stack)\n" 3388 " s Stack snapshots (with v, displays all stacks)\n" 3389 " l Context (loop) stack processing\n" 3390 " t Trace execution\n" 3391 " o Method and overloading resolution\n", 3392 " c String/numeric conversions\n" 3393 " P Print profiling info, source file input state\n" 3394 " m Memory and SV allocation\n" 3395 " f Format processing\n" 3396 " r Regular expression parsing and execution\n" 3397 " x Syntax tree dump\n", 3398 " u Tainting checks\n" 3399 " H Hash dump -- usurps values()\n" 3400 " X Scratchpad allocation\n" 3401 " D Cleaning up\n" 3402 " S Op slab allocation\n" 3403 " T Tokenising\n" 3404 " R Include reference counts of dumped variables (eg when using -Ds)\n", 3405 " J Do not s,t,P-debug (Jump over) opcodes within package DB\n" 3406 " v Verbose: use in conjunction with other flags\n" 3407 " C Copy On Write\n" 3408 " A Consistency checks on internal structures\n" 3409 " q quiet - currently only suppresses the 'EXECUTING' message\n" 3410 " M trace smart match resolution\n" 3411 " B dump suBroutine definitions, including special Blocks like BEGIN\n", 3412 " L trace some locale setting information--for Perl core development\n", 3413 " i trace PerlIO layer processing\n", 3414 " y trace y///, tr/// compilation and execution\n", 3415 NULL 3416 }; 3417 UV uv = 0; 3418 3419 PERL_ARGS_ASSERT_GET_DEBUG_OPTS; 3420 3421 if (isALPHA(**s)) { 3422 /* if adding extra options, remember to update DEBUG_MASK */ 3423 static const char debopts[] = "psltocPmfrxuUHXDSTRJvCAqMBLiy"; 3424 3425 for (; isWORDCHAR(**s); (*s)++) { 3426 const char * const d = strchr(debopts,**s); 3427 if (d) 3428 uv |= 1 << (d - debopts); 3429 else if (ckWARN_d(WARN_DEBUGGING)) 3430 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING), 3431 "invalid option -D%c, use -D'' to see choices\n", **s); 3432 } 3433 } 3434 else if (isDIGIT(**s)) { 3435 const char* e = *s + strlen(*s); 3436 if (grok_atoUV(*s, &uv, &e)) 3437 *s = e; 3438 for (; isWORDCHAR(**s); (*s)++) ; 3439 } 3440 else if (givehelp) { 3441 const char *const *p = usage_msgd; 3442 while (*p) PerlIO_puts(PerlIO_stdout(), *p++); 3443 } 3444 return (int)uv; /* ignore any UV->int conversion loss */ 3445 } 3446 #endif 3447 3448 /* This routine handles any switches that can be given during run */ 3449 3450 const char * 3451 Perl_moreswitches(pTHX_ const char *s) 3452 { 3453 dVAR; 3454 UV rschar; 3455 const char option = *s; /* used to remember option in -m/-M code */ 3456 3457 PERL_ARGS_ASSERT_MORESWITCHES; 3458 3459 switch (*s) { 3460 case '0': 3461 { 3462 I32 flags = 0; 3463 STRLEN numlen; 3464 3465 SvREFCNT_dec(PL_rs); 3466 if (s[1] == 'x' && s[2]) { 3467 const char *e = s+=2; 3468 U8 *tmps; 3469 3470 while (*e) 3471 e++; 3472 numlen = e - s; 3473 flags = PERL_SCAN_SILENT_ILLDIGIT; 3474 rschar = (U32)grok_hex(s, &numlen, &flags, NULL); 3475 if (s + numlen < e) { 3476 rschar = 0; /* Grandfather -0xFOO as -0 -xFOO. */ 3477 numlen = 0; 3478 s--; 3479 } 3480 PL_rs = newSVpvs(""); 3481 tmps = (U8*) SvGROW(PL_rs, (STRLEN)(UVCHR_SKIP(rschar) + 1)); 3482 uvchr_to_utf8(tmps, rschar); 3483 SvCUR_set(PL_rs, UVCHR_SKIP(rschar)); 3484 SvUTF8_on(PL_rs); 3485 } 3486 else { 3487 numlen = 4; 3488 rschar = (U32)grok_oct(s, &numlen, &flags, NULL); 3489 if (rschar & ~((U8)~0)) 3490 PL_rs = &PL_sv_undef; 3491 else if (!rschar && numlen >= 2) 3492 PL_rs = newSVpvs(""); 3493 else { 3494 char ch = (char)rschar; 3495 PL_rs = newSVpvn(&ch, 1); 3496 } 3497 } 3498 sv_setsv(get_sv("/", GV_ADD), PL_rs); 3499 return s + numlen; 3500 } 3501 case 'C': 3502 s++; 3503 PL_unicode = parse_unicode_opts( (const char **)&s ); 3504 if (PL_unicode & PERL_UNICODE_UTF8CACHEASSERT_FLAG) 3505 PL_utf8cache = -1; 3506 return s; 3507 case 'F': 3508 PL_minus_a = TRUE; 3509 PL_minus_F = TRUE; 3510 PL_minus_n = TRUE; 3511 PL_splitstr = ++s; 3512 while (*s && !isSPACE(*s)) ++s; 3513 PL_splitstr = savepvn(PL_splitstr, s - PL_splitstr); 3514 return s; 3515 case 'a': 3516 PL_minus_a = TRUE; 3517 PL_minus_n = TRUE; 3518 s++; 3519 return s; 3520 case 'c': 3521 PL_minus_c = TRUE; 3522 s++; 3523 return s; 3524 case 'd': 3525 forbid_setid('d', FALSE); 3526 s++; 3527 3528 /* -dt indicates to the debugger that threads will be used */ 3529 if (*s == 't' && !isWORDCHAR(s[1])) { 3530 ++s; 3531 my_setenv("PERL5DB_THREADED", "1"); 3532 } 3533 3534 /* The following permits -d:Mod to accepts arguments following an = 3535 in the fashion that -MSome::Mod does. */ 3536 if (*s == ':' || *s == '=') { 3537 const char *start; 3538 const char *end; 3539 SV *sv; 3540 3541 if (*++s == '-') { 3542 ++s; 3543 sv = newSVpvs("no Devel::"); 3544 } else { 3545 sv = newSVpvs("use Devel::"); 3546 } 3547 3548 start = s; 3549 end = s + strlen(s); 3550 3551 /* We now allow -d:Module=Foo,Bar and -d:-Module */ 3552 while(isWORDCHAR(*s) || *s==':') ++s; 3553 if (*s != '=') 3554 sv_catpvn(sv, start, end - start); 3555 else { 3556 sv_catpvn(sv, start, s-start); 3557 /* Don't use NUL as q// delimiter here, this string goes in the 3558 * environment. */ 3559 Perl_sv_catpvf(aTHX_ sv, " split(/,/,q{%s});", ++s); 3560 } 3561 s = end; 3562 my_setenv("PERL5DB", SvPV_nolen_const(sv)); 3563 SvREFCNT_dec(sv); 3564 } 3565 if (!PL_perldb) { 3566 PL_perldb = PERLDB_ALL; 3567 init_debugger(); 3568 } 3569 return s; 3570 case 'D': 3571 { 3572 #ifdef DEBUGGING 3573 forbid_setid('D', FALSE); 3574 s++; 3575 PL_debug = get_debug_opts( (const char **)&s, 1) | DEBUG_TOP_FLAG; 3576 #else /* !DEBUGGING */ 3577 if (ckWARN_d(WARN_DEBUGGING)) 3578 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING), 3579 "Recompile perl with -DDEBUGGING to use -D switch (did you mean -d ?)\n"); 3580 for (s++; isWORDCHAR(*s); s++) ; 3581 #endif 3582 return s; 3583 NOT_REACHED; /* NOTREACHED */ 3584 } 3585 case 'h': 3586 usage(); 3587 NOT_REACHED; /* NOTREACHED */ 3588 3589 case 'i': 3590 Safefree(PL_inplace); 3591 { 3592 const char * const start = ++s; 3593 while (*s && !isSPACE(*s)) 3594 ++s; 3595 3596 PL_inplace = savepvn(start, s - start); 3597 } 3598 return s; 3599 case 'I': /* -I handled both here and in parse_body() */ 3600 forbid_setid('I', FALSE); 3601 ++s; 3602 while (*s && isSPACE(*s)) 3603 ++s; 3604 if (*s) { 3605 const char *e, *p; 3606 p = s; 3607 /* ignore trailing spaces (possibly followed by other switches) */ 3608 do { 3609 for (e = p; *e && !isSPACE(*e); e++) ; 3610 p = e; 3611 while (isSPACE(*p)) 3612 p++; 3613 } while (*p && *p != '-'); 3614 incpush(s, e-s, 3615 INCPUSH_ADD_SUB_DIRS|INCPUSH_ADD_OLD_VERS|INCPUSH_UNSHIFT); 3616 s = p; 3617 if (*s == '-') 3618 s++; 3619 } 3620 else 3621 Perl_croak(aTHX_ "No directory specified for -I"); 3622 return s; 3623 case 'l': 3624 PL_minus_l = TRUE; 3625 s++; 3626 if (PL_ors_sv) { 3627 SvREFCNT_dec(PL_ors_sv); 3628 PL_ors_sv = NULL; 3629 } 3630 if (isDIGIT(*s)) { 3631 I32 flags = 0; 3632 STRLEN numlen; 3633 PL_ors_sv = newSVpvs("\n"); 3634 numlen = 3 + (*s == '0'); 3635 *SvPVX(PL_ors_sv) = (char)grok_oct(s, &numlen, &flags, NULL); 3636 s += numlen; 3637 } 3638 else { 3639 if (RsPARA(PL_rs)) { 3640 PL_ors_sv = newSVpvs("\n\n"); 3641 } 3642 else { 3643 PL_ors_sv = newSVsv(PL_rs); 3644 } 3645 } 3646 return s; 3647 case 'M': 3648 forbid_setid('M', FALSE); /* XXX ? */ 3649 /* FALLTHROUGH */ 3650 case 'm': 3651 forbid_setid('m', FALSE); /* XXX ? */ 3652 if (*++s) { 3653 const char *start; 3654 const char *end; 3655 SV *sv; 3656 const char *use = "use "; 3657 bool colon = FALSE; 3658 /* -M-foo == 'no foo' */ 3659 /* Leading space on " no " is deliberate, to make both 3660 possibilities the same length. */ 3661 if (*s == '-') { use = " no "; ++s; } 3662 sv = newSVpvn(use,4); 3663 start = s; 3664 /* We allow -M'Module qw(Foo Bar)' */ 3665 while(isWORDCHAR(*s) || *s==':') { 3666 if( *s++ == ':' ) { 3667 if( *s == ':' ) 3668 s++; 3669 else 3670 colon = TRUE; 3671 } 3672 } 3673 if (s == start) 3674 Perl_croak(aTHX_ "Module name required with -%c option", 3675 option); 3676 if (colon) 3677 Perl_croak(aTHX_ "Invalid module name %.*s with -%c option: " 3678 "contains single ':'", 3679 (int)(s - start), start, option); 3680 end = s + strlen(s); 3681 if (*s != '=') { 3682 sv_catpvn(sv, start, end - start); 3683 if (option == 'm') { 3684 if (*s != '\0') 3685 Perl_croak(aTHX_ "Can't use '%c' after -mname", *s); 3686 sv_catpvs( sv, " ()"); 3687 } 3688 } else { 3689 sv_catpvn(sv, start, s-start); 3690 /* Use NUL as q''-delimiter. */ 3691 sv_catpvs(sv, " split(/,/,q\0"); 3692 ++s; 3693 sv_catpvn(sv, s, end - s); 3694 sv_catpvs(sv, "\0)"); 3695 } 3696 s = end; 3697 Perl_av_create_and_push(aTHX_ &PL_preambleav, sv); 3698 } 3699 else 3700 Perl_croak(aTHX_ "Missing argument to -%c", option); 3701 return s; 3702 case 'n': 3703 PL_minus_n = TRUE; 3704 s++; 3705 return s; 3706 case 'p': 3707 PL_minus_p = TRUE; 3708 s++; 3709 return s; 3710 case 's': 3711 forbid_setid('s', FALSE); 3712 PL_doswitches = TRUE; 3713 s++; 3714 return s; 3715 case 't': 3716 case 'T': 3717 #if defined(SILENT_NO_TAINT_SUPPORT) 3718 /* silently ignore */ 3719 #elif defined(NO_TAINT_SUPPORT) 3720 Perl_croak_nocontext("This perl was compiled without taint support. " 3721 "Cowardly refusing to run with -t or -T flags"); 3722 #else 3723 if (!TAINTING_get) 3724 TOO_LATE_FOR(*s); 3725 #endif 3726 s++; 3727 return s; 3728 case 'u': 3729 PL_do_undump = TRUE; 3730 s++; 3731 return s; 3732 case 'U': 3733 PL_unsafe = TRUE; 3734 s++; 3735 return s; 3736 case 'v': 3737 minus_v(); 3738 case 'w': 3739 if (! (PL_dowarn & G_WARN_ALL_MASK)) { 3740 PL_dowarn |= G_WARN_ON; 3741 } 3742 s++; 3743 return s; 3744 case 'W': 3745 PL_dowarn = G_WARN_ALL_ON|G_WARN_ON; 3746 free_and_set_cop_warnings(&PL_compiling, pWARN_ALL); 3747 s++; 3748 return s; 3749 case 'X': 3750 PL_dowarn = G_WARN_ALL_OFF; 3751 free_and_set_cop_warnings(&PL_compiling, pWARN_NONE); 3752 s++; 3753 return s; 3754 case '*': 3755 case ' ': 3756 while( *s == ' ' ) 3757 ++s; 3758 if (s[0] == '-') /* Additional switches on #! line. */ 3759 return s+1; 3760 break; 3761 case '-': 3762 case 0: 3763 #if defined(WIN32) || !defined(PERL_STRICT_CR) 3764 case '\r': 3765 #endif 3766 case '\n': 3767 case '\t': 3768 break; 3769 #ifdef ALTERNATE_SHEBANG 3770 case 'S': /* OS/2 needs -S on "extproc" line. */ 3771 break; 3772 #endif 3773 case 'e': case 'f': case 'x': case 'E': 3774 #ifndef ALTERNATE_SHEBANG 3775 case 'S': 3776 #endif 3777 case 'V': 3778 Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s); 3779 default: 3780 Perl_croak(aTHX_ 3781 "Unrecognized switch: -%.1s (-h will show valid options)",s 3782 ); 3783 } 3784 return NULL; 3785 } 3786 3787 3788 STATIC void 3789 S_minus_v(pTHX) 3790 { 3791 PerlIO * PIO_stdout; 3792 { 3793 const char * const level_str = "v" PERL_VERSION_STRING; 3794 const STRLEN level_len = sizeof("v" PERL_VERSION_STRING)-1; 3795 #ifdef PERL_PATCHNUM 3796 SV* level; 3797 # ifdef PERL_GIT_UNCOMMITTED_CHANGES 3798 static const char num [] = PERL_PATCHNUM "*"; 3799 # else 3800 static const char num [] = PERL_PATCHNUM; 3801 # endif 3802 { 3803 const STRLEN num_len = sizeof(num)-1; 3804 /* A very advanced compiler would fold away the strnEQ 3805 and this whole conditional, but most (all?) won't do it. 3806 SV level could also be replaced by with preprocessor 3807 catenation. 3808 */ 3809 if (num_len >= level_len && strnEQ(num,level_str,level_len)) { 3810 /* per 46807d8e80, PERL_PATCHNUM is outside of the control 3811 of the interp so it might contain format characters 3812 */ 3813 level = newSVpvn(num, num_len); 3814 } else { 3815 level = Perl_newSVpvf_nocontext("%s (%s)", level_str, num); 3816 } 3817 } 3818 #else 3819 SV* level = newSVpvn(level_str, level_len); 3820 #endif /* #ifdef PERL_PATCHNUM */ 3821 PIO_stdout = PerlIO_stdout(); 3822 PerlIO_printf(PIO_stdout, 3823 "\nThis is perl " STRINGIFY(PERL_REVISION) 3824 ", version " STRINGIFY(PERL_VERSION) 3825 ", subversion " STRINGIFY(PERL_SUBVERSION) 3826 " (%" SVf ") built for " ARCHNAME, SVfARG(level) 3827 ); 3828 SvREFCNT_dec_NN(level); 3829 } 3830 #if defined(LOCAL_PATCH_COUNT) 3831 if (LOCAL_PATCH_COUNT > 0) 3832 PerlIO_printf(PIO_stdout, 3833 "\n(with %d registered patch%s, " 3834 "see perl -V for more detail)", 3835 LOCAL_PATCH_COUNT, 3836 (LOCAL_PATCH_COUNT!=1) ? "es" : ""); 3837 #endif 3838 3839 PerlIO_printf(PIO_stdout, 3840 "\n\nCopyright 1987-2021, Larry Wall\n"); 3841 #ifdef MSDOS 3842 PerlIO_printf(PIO_stdout, 3843 "\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n"); 3844 #endif 3845 #ifdef DJGPP 3846 PerlIO_printf(PIO_stdout, 3847 "djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n" 3848 "djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n"); 3849 #endif 3850 #ifdef OS2 3851 PerlIO_printf(PIO_stdout, 3852 "\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n" 3853 "Version 5 port Copyright (c) 1994-2002, Andreas Kaiser, Ilya Zakharevich\n"); 3854 #endif 3855 #ifdef OEMVS 3856 PerlIO_printf(PIO_stdout, 3857 "MVS (OS390) port by Mortice Kern Systems, 1997-1999\n"); 3858 #endif 3859 #ifdef __VOS__ 3860 PerlIO_printf(PIO_stdout, 3861 "Stratus OpenVOS port by Paul.Green@stratus.com, 1997-2013\n"); 3862 #endif 3863 #ifdef POSIX_BC 3864 PerlIO_printf(PIO_stdout, 3865 "BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n"); 3866 #endif 3867 #ifdef __SYMBIAN32__ 3868 PerlIO_printf(PIO_stdout, 3869 "Symbian port by Nokia, 2004-2005\n"); 3870 #endif 3871 #ifdef BINARY_BUILD_NOTICE 3872 BINARY_BUILD_NOTICE; 3873 #endif 3874 PerlIO_printf(PIO_stdout, 3875 "\n\ 3876 Perl may be copied only under the terms of either the Artistic License or the\n\ 3877 GNU General Public License, which may be found in the Perl 5 source kit.\n\n\ 3878 Complete documentation for Perl, including FAQ lists, should be found on\n\ 3879 this system using \"man perl\" or \"perldoc perl\". If you have access to the\n\ 3880 Internet, point your browser at http://www.perl.org/, the Perl Home Page.\n\n"); 3881 my_exit(0); 3882 } 3883 3884 /* compliments of Tom Christiansen */ 3885 3886 /* unexec() can be found in the Gnu emacs distribution */ 3887 /* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */ 3888 3889 #ifdef VMS 3890 #include <lib$routines.h> 3891 #endif 3892 3893 void 3894 Perl_my_unexec(pTHX) 3895 { 3896 #ifdef UNEXEC 3897 SV * prog = newSVpv(BIN_EXP, 0); 3898 SV * file = newSVpv(PL_origfilename, 0); 3899 int status = 1; 3900 extern int etext; 3901 3902 sv_catpvs(prog, "/perl"); 3903 sv_catpvs(file, ".perldump"); 3904 3905 unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0); 3906 /* unexec prints msg to stderr in case of failure */ 3907 PerlProc_exit(status); 3908 #else 3909 PERL_UNUSED_CONTEXT; 3910 # ifdef VMS 3911 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */ 3912 # elif defined(WIN32) || defined(__CYGWIN__) 3913 Perl_croak_nocontext("dump is not supported"); 3914 # else 3915 ABORT(); /* for use with undump */ 3916 # endif 3917 #endif 3918 } 3919 3920 /* initialize curinterp */ 3921 STATIC void 3922 S_init_interp(pTHX) 3923 { 3924 #ifdef MULTIPLICITY 3925 # define PERLVAR(prefix,var,type) 3926 # define PERLVARA(prefix,var,n,type) 3927 # if defined(PERL_IMPLICIT_CONTEXT) 3928 # define PERLVARI(prefix,var,type,init) aTHX->prefix##var = init; 3929 # define PERLVARIC(prefix,var,type,init) aTHX->prefix##var = init; 3930 # else 3931 # define PERLVARI(prefix,var,type,init) PERL_GET_INTERP->var = init; 3932 # define PERLVARIC(prefix,var,type,init) PERL_GET_INTERP->var = init; 3933 # endif 3934 # include "intrpvar.h" 3935 # undef PERLVAR 3936 # undef PERLVARA 3937 # undef PERLVARI 3938 # undef PERLVARIC 3939 #else 3940 # define PERLVAR(prefix,var,type) 3941 # define PERLVARA(prefix,var,n,type) 3942 # define PERLVARI(prefix,var,type,init) PL_##var = init; 3943 # define PERLVARIC(prefix,var,type,init) PL_##var = init; 3944 # include "intrpvar.h" 3945 # undef PERLVAR 3946 # undef PERLVARA 3947 # undef PERLVARI 3948 # undef PERLVARIC 3949 #endif 3950 3951 } 3952 3953 STATIC void 3954 S_init_main_stash(pTHX) 3955 { 3956 GV *gv; 3957 HV *hv = newHV(); 3958 3959 PL_curstash = PL_defstash = (HV *)SvREFCNT_inc_simple_NN(hv); 3960 /* We know that the string "main" will be in the global shared string 3961 table, so it's a small saving to use it rather than allocate another 3962 8 bytes. */ 3963 PL_curstname = newSVpvs_share("main"); 3964 gv = gv_fetchpvs("main::", GV_ADD|GV_NOTQUAL, SVt_PVHV); 3965 /* If we hadn't caused another reference to "main" to be in the shared 3966 string table above, then it would be worth reordering these two, 3967 because otherwise all we do is delete "main" from it as a consequence 3968 of the SvREFCNT_dec, only to add it again with hv_name_set */ 3969 SvREFCNT_dec(GvHV(gv)); 3970 hv_name_sets(PL_defstash, "main", 0); 3971 GvHV(gv) = MUTABLE_HV(SvREFCNT_inc_simple(PL_defstash)); 3972 SvREADONLY_on(gv); 3973 PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpvs("INC", GV_ADD|GV_NOTQUAL, 3974 SVt_PVAV))); 3975 SvREFCNT_inc_simple_void(PL_incgv); /* Don't allow it to be freed */ 3976 GvMULTI_on(PL_incgv); 3977 PL_hintgv = gv_fetchpvs("\010", GV_ADD|GV_NOTQUAL, SVt_PV); /* ^H */ 3978 SvREFCNT_inc_simple_void(PL_hintgv); 3979 GvMULTI_on(PL_hintgv); 3980 PL_defgv = gv_fetchpvs("_", GV_ADD|GV_NOTQUAL, SVt_PVAV); 3981 SvREFCNT_inc_simple_void(PL_defgv); 3982 PL_errgv = gv_fetchpvs("@", GV_ADD|GV_NOTQUAL, SVt_PV); 3983 SvREFCNT_inc_simple_void(PL_errgv); 3984 GvMULTI_on(PL_errgv); 3985 PL_replgv = gv_fetchpvs("\022", GV_ADD|GV_NOTQUAL, SVt_PV); /* ^R */ 3986 SvREFCNT_inc_simple_void(PL_replgv); 3987 GvMULTI_on(PL_replgv); 3988 (void)Perl_form(aTHX_ "%240s",""); /* Preallocate temp - for immediate signals. */ 3989 #ifdef PERL_DONT_CREATE_GVSV 3990 (void)gv_SVadd(PL_errgv); 3991 #endif 3992 sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */ 3993 CLEAR_ERRSV(); 3994 CopSTASH_set(&PL_compiling, PL_defstash); 3995 PL_debstash = GvHV(gv_fetchpvs("DB::", GV_ADDMULTI, SVt_PVHV)); 3996 PL_globalstash = GvHV(gv_fetchpvs("CORE::GLOBAL::", GV_ADDMULTI, 3997 SVt_PVHV)); 3998 /* We must init $/ before switches are processed. */ 3999 sv_setpvs(get_sv("/", GV_ADD), "\n"); 4000 } 4001 4002 STATIC PerlIO * 4003 S_open_script(pTHX_ const char *scriptname, bool dosearch, bool *suidscript) 4004 { 4005 int fdscript = -1; 4006 PerlIO *rsfp = NULL; 4007 Stat_t tmpstatbuf; 4008 int fd; 4009 4010 PERL_ARGS_ASSERT_OPEN_SCRIPT; 4011 4012 if (PL_e_script) { 4013 PL_origfilename = savepvs("-e"); 4014 } 4015 else { 4016 const char *s; 4017 UV uv; 4018 /* if find_script() returns, it returns a malloc()-ed value */ 4019 scriptname = PL_origfilename = find_script(scriptname, dosearch, NULL, 1); 4020 s = scriptname + strlen(scriptname); 4021 4022 if (strBEGINs(scriptname, "/dev/fd/") 4023 && isDIGIT(scriptname[8]) 4024 && grok_atoUV(scriptname + 8, &uv, &s) 4025 && uv <= PERL_INT_MAX 4026 ) { 4027 fdscript = (int)uv; 4028 if (*s) { 4029 /* PSz 18 Feb 04 4030 * Tell apart "normal" usage of fdscript, e.g. 4031 * with bash on FreeBSD: 4032 * perl <( echo '#!perl -DA'; echo 'print "$0\n"') 4033 * from usage in suidperl. 4034 * Does any "normal" usage leave garbage after the number??? 4035 * Is it a mistake to use a similar /dev/fd/ construct for 4036 * suidperl? 4037 */ 4038 *suidscript = TRUE; 4039 /* PSz 20 Feb 04 4040 * Be supersafe and do some sanity-checks. 4041 * Still, can we be sure we got the right thing? 4042 */ 4043 if (*s != '/') { 4044 Perl_croak(aTHX_ "Wrong syntax (suid) fd script name \"%s\"\n", s); 4045 } 4046 if (! *(s+1)) { 4047 Perl_croak(aTHX_ "Missing (suid) fd script name\n"); 4048 } 4049 scriptname = savepv(s + 1); 4050 Safefree(PL_origfilename); 4051 PL_origfilename = (char *)scriptname; 4052 } 4053 } 4054 } 4055 4056 CopFILE_free(PL_curcop); 4057 CopFILE_set(PL_curcop, PL_origfilename); 4058 if (*PL_origfilename == '-' && PL_origfilename[1] == '\0') 4059 scriptname = (char *)""; 4060 if (fdscript >= 0) { 4061 rsfp = PerlIO_fdopen(fdscript,PERL_SCRIPT_MODE); 4062 } 4063 else if (!*scriptname) { 4064 forbid_setid(0, *suidscript); 4065 return NULL; 4066 } 4067 else { 4068 #ifdef FAKE_BIT_BUCKET 4069 /* This hack allows one not to have /dev/null (or BIT_BUCKET as it 4070 * is called) and still have the "-e" work. (Believe it or not, 4071 * a /dev/null is required for the "-e" to work because source 4072 * filter magic is used to implement it. ) This is *not* a general 4073 * replacement for a /dev/null. What we do here is create a temp 4074 * file (an empty file), open up that as the script, and then 4075 * immediately close and unlink it. Close enough for jazz. */ 4076 #define FAKE_BIT_BUCKET_PREFIX "/tmp/perlnull-" 4077 #define FAKE_BIT_BUCKET_SUFFIX "XXXXXXXX" 4078 #define FAKE_BIT_BUCKET_TEMPLATE FAKE_BIT_BUCKET_PREFIX FAKE_BIT_BUCKET_SUFFIX 4079 char tmpname[sizeof(FAKE_BIT_BUCKET_TEMPLATE)] = { 4080 FAKE_BIT_BUCKET_TEMPLATE 4081 }; 4082 const char * const err = "Failed to create a fake bit bucket"; 4083 if (strEQ(scriptname, BIT_BUCKET)) { 4084 int tmpfd = Perl_my_mkstemp_cloexec(tmpname); 4085 if (tmpfd > -1) { 4086 scriptname = tmpname; 4087 close(tmpfd); 4088 } else 4089 Perl_croak(aTHX_ err); 4090 } 4091 #endif 4092 rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE); 4093 #ifdef FAKE_BIT_BUCKET 4094 if ( strBEGINs(scriptname, FAKE_BIT_BUCKET_PREFIX) 4095 && strlen(scriptname) == sizeof(tmpname) - 1) 4096 { 4097 unlink(scriptname); 4098 } 4099 scriptname = BIT_BUCKET; 4100 #endif 4101 } 4102 if (!rsfp) { 4103 /* PSz 16 Sep 03 Keep neat error message */ 4104 if (PL_e_script) 4105 Perl_croak(aTHX_ "Can't open " BIT_BUCKET ": %s\n", Strerror(errno)); 4106 else 4107 Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n", 4108 CopFILE(PL_curcop), Strerror(errno)); 4109 } 4110 fd = PerlIO_fileno(rsfp); 4111 4112 if (fd < 0 || 4113 (PerlLIO_fstat(fd, &tmpstatbuf) >= 0 4114 && S_ISDIR(tmpstatbuf.st_mode))) 4115 Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n", 4116 CopFILE(PL_curcop), 4117 Strerror(EISDIR)); 4118 4119 return rsfp; 4120 } 4121 4122 /* In the days of suidperl, we refused to execute a setuid script stored on 4123 * a filesystem mounted nosuid and/or noexec. This meant that we probed for the 4124 * existence of the appropriate filesystem-statting function, and behaved 4125 * accordingly. But even though suidperl is long gone, we must still include 4126 * those probes for the benefit of modules like Filesys::Df, which expect the 4127 * results of those probes to be stored in %Config; see RT#126368. So mention 4128 * the relevant cpp symbols here, to ensure that metaconfig will include their 4129 * probes in the generated Configure: 4130 * 4131 * I_SYSSTATVFS HAS_FSTATVFS 4132 * I_SYSMOUNT 4133 * I_STATFS HAS_FSTATFS HAS_GETFSSTAT 4134 * I_MNTENT HAS_GETMNTENT HAS_HASMNTOPT 4135 */ 4136 4137 4138 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW 4139 /* Don't even need this function. */ 4140 #else 4141 STATIC void 4142 S_validate_suid(pTHX_ PerlIO *rsfp) 4143 { 4144 const Uid_t my_uid = PerlProc_getuid(); 4145 const Uid_t my_euid = PerlProc_geteuid(); 4146 const Gid_t my_gid = PerlProc_getgid(); 4147 const Gid_t my_egid = PerlProc_getegid(); 4148 4149 PERL_ARGS_ASSERT_VALIDATE_SUID; 4150 4151 if (my_euid != my_uid || my_egid != my_gid) { /* (suidperl doesn't exist, in fact) */ 4152 dVAR; 4153 int fd = PerlIO_fileno(rsfp); 4154 Stat_t statbuf; 4155 if (fd < 0 || PerlLIO_fstat(fd, &statbuf) < 0) { /* may be either wrapped or real suid */ 4156 Perl_croak_nocontext( "Illegal suidscript"); 4157 } 4158 if ((my_euid != my_uid && my_euid == statbuf.st_uid && statbuf.st_mode & S_ISUID) 4159 || 4160 (my_egid != my_gid && my_egid == statbuf.st_gid && statbuf.st_mode & S_ISGID) 4161 ) 4162 if (!PL_do_undump) 4163 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\ 4164 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n"); 4165 /* not set-id, must be wrapped */ 4166 } 4167 } 4168 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */ 4169 4170 STATIC void 4171 S_find_beginning(pTHX_ SV* linestr_sv, PerlIO *rsfp) 4172 { 4173 const char *s; 4174 const char *s2; 4175 4176 PERL_ARGS_ASSERT_FIND_BEGINNING; 4177 4178 /* skip forward in input to the real script? */ 4179 4180 do { 4181 if ((s = sv_gets(linestr_sv, rsfp, 0)) == NULL) 4182 Perl_croak(aTHX_ "No Perl script found in input\n"); 4183 s2 = s; 4184 } while (!(*s == '#' && s[1] == '!' && ((s = instr(s,"perl")) || (s = instr(s2,"PERL"))))); 4185 PerlIO_ungetc(rsfp, '\n'); /* to keep line count right */ 4186 while (*s && !(isSPACE (*s) || *s == '#')) s++; 4187 s2 = s; 4188 while (*s == ' ' || *s == '\t') s++; 4189 if (*s++ == '-') { 4190 while (isDIGIT(s2[-1]) || s2[-1] == '-' || s2[-1] == '.' 4191 || s2[-1] == '_') s2--; 4192 if (strBEGINs(s2-4,"perl")) 4193 while ((s = moreswitches(s))) 4194 ; 4195 } 4196 } 4197 4198 4199 STATIC void 4200 S_init_ids(pTHX) 4201 { 4202 /* no need to do anything here any more if we don't 4203 * do tainting. */ 4204 #ifndef NO_TAINT_SUPPORT 4205 const Uid_t my_uid = PerlProc_getuid(); 4206 const Uid_t my_euid = PerlProc_geteuid(); 4207 const Gid_t my_gid = PerlProc_getgid(); 4208 const Gid_t my_egid = PerlProc_getegid(); 4209 4210 PERL_UNUSED_CONTEXT; 4211 4212 /* Should not happen: */ 4213 CHECK_MALLOC_TAINT(my_uid && (my_euid != my_uid || my_egid != my_gid)); 4214 TAINTING_set( TAINTING_get | (my_uid && (my_euid != my_uid || my_egid != my_gid)) ); 4215 #endif 4216 /* BUG */ 4217 /* PSz 27 Feb 04 4218 * Should go by suidscript, not uid!=euid: why disallow 4219 * system("ls") in scripts run from setuid things? 4220 * Or, is this run before we check arguments and set suidscript? 4221 * What about SETUID_SCRIPTS_ARE_SECURE_NOW: could we use fdscript then? 4222 * (We never have suidscript, can we be sure to have fdscript?) 4223 * Or must then go by UID checks? See comments in forbid_setid also. 4224 */ 4225 } 4226 4227 /* This is used very early in the lifetime of the program, 4228 * before even the options are parsed, so PL_tainting has 4229 * not been initialized properly. */ 4230 bool 4231 Perl_doing_taint(int argc, char *argv[], char *envp[]) 4232 { 4233 #ifndef PERL_IMPLICIT_SYS 4234 /* If we have PERL_IMPLICIT_SYS we can't call getuid() et alia 4235 * before we have an interpreter-- and the whole point of this 4236 * function is to be called at such an early stage. If you are on 4237 * a system with PERL_IMPLICIT_SYS but you do have a concept of 4238 * "tainted because running with altered effective ids', you'll 4239 * have to add your own checks somewhere in here. The two most 4240 * known samples of 'implicitness' are Win32 and NetWare, neither 4241 * of which has much of concept of 'uids'. */ 4242 Uid_t uid = PerlProc_getuid(); 4243 Uid_t euid = PerlProc_geteuid(); 4244 Gid_t gid = PerlProc_getgid(); 4245 Gid_t egid = PerlProc_getegid(); 4246 (void)envp; 4247 4248 #ifdef VMS 4249 uid |= gid << 16; 4250 euid |= egid << 16; 4251 #endif 4252 if (uid && (euid != uid || egid != gid)) 4253 return 1; 4254 #endif /* !PERL_IMPLICIT_SYS */ 4255 /* This is a really primitive check; environment gets ignored only 4256 * if -T are the first chars together; otherwise one gets 4257 * "Too late" message. */ 4258 if ( argc > 1 && argv[1][0] == '-' 4259 && isALPHA_FOLD_EQ(argv[1][1], 't')) 4260 return 1; 4261 return 0; 4262 } 4263 4264 /* Passing the flag as a single char rather than a string is a slight space 4265 optimisation. The only message that isn't /^-.$/ is 4266 "program input from stdin", which is substituted in place of '\0', which 4267 could never be a command line flag. */ 4268 STATIC void 4269 S_forbid_setid(pTHX_ const char flag, const bool suidscript) /* g */ 4270 { 4271 char string[3] = "-x"; 4272 const char *message = "program input from stdin"; 4273 4274 PERL_UNUSED_CONTEXT; 4275 if (flag) { 4276 string[1] = flag; 4277 message = string; 4278 } 4279 4280 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW 4281 if (PerlProc_getuid() != PerlProc_geteuid()) 4282 Perl_croak(aTHX_ "No %s allowed while running setuid", message); 4283 if (PerlProc_getgid() != PerlProc_getegid()) 4284 Perl_croak(aTHX_ "No %s allowed while running setgid", message); 4285 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */ 4286 if (suidscript) 4287 Perl_croak(aTHX_ "No %s allowed with (suid) fdscript", message); 4288 } 4289 4290 void 4291 Perl_init_dbargs(pTHX) 4292 { 4293 AV *const args = PL_dbargs = GvAV(gv_AVadd((gv_fetchpvs("DB::args", 4294 GV_ADDMULTI, 4295 SVt_PVAV)))); 4296 4297 if (AvREAL(args)) { 4298 /* Someone has already created it. 4299 It might have entries, and if we just turn off AvREAL(), they will 4300 "leak" until global destruction. */ 4301 av_clear(args); 4302 if (SvTIED_mg((const SV *)args, PERL_MAGIC_tied)) 4303 Perl_croak(aTHX_ "Cannot set tied @DB::args"); 4304 } 4305 AvREIFY_only(PL_dbargs); 4306 } 4307 4308 void 4309 Perl_init_debugger(pTHX) 4310 { 4311 HV * const ostash = PL_curstash; 4312 MAGIC *mg; 4313 4314 PL_curstash = (HV *)SvREFCNT_inc_simple(PL_debstash); 4315 4316 Perl_init_dbargs(aTHX); 4317 PL_DBgv = MUTABLE_GV( 4318 SvREFCNT_inc(gv_fetchpvs("DB::DB", GV_ADDMULTI, SVt_PVGV)) 4319 ); 4320 PL_DBline = MUTABLE_GV( 4321 SvREFCNT_inc(gv_fetchpvs("DB::dbline", GV_ADDMULTI, SVt_PVAV)) 4322 ); 4323 PL_DBsub = MUTABLE_GV(SvREFCNT_inc( 4324 gv_HVadd(gv_fetchpvs("DB::sub", GV_ADDMULTI, SVt_PVHV)) 4325 )); 4326 PL_DBsingle = GvSV((gv_fetchpvs("DB::single", GV_ADDMULTI, SVt_PV))); 4327 if (!SvIOK(PL_DBsingle)) 4328 sv_setiv(PL_DBsingle, 0); 4329 mg = sv_magicext(PL_DBsingle, NULL, PERL_MAGIC_debugvar, &PL_vtbl_debugvar, 0, 0); 4330 mg->mg_private = DBVARMG_SINGLE; 4331 SvSETMAGIC(PL_DBsingle); 4332 4333 PL_DBtrace = GvSV((gv_fetchpvs("DB::trace", GV_ADDMULTI, SVt_PV))); 4334 if (!SvIOK(PL_DBtrace)) 4335 sv_setiv(PL_DBtrace, 0); 4336 mg = sv_magicext(PL_DBtrace, NULL, PERL_MAGIC_debugvar, &PL_vtbl_debugvar, 0, 0); 4337 mg->mg_private = DBVARMG_TRACE; 4338 SvSETMAGIC(PL_DBtrace); 4339 4340 PL_DBsignal = GvSV((gv_fetchpvs("DB::signal", GV_ADDMULTI, SVt_PV))); 4341 if (!SvIOK(PL_DBsignal)) 4342 sv_setiv(PL_DBsignal, 0); 4343 mg = sv_magicext(PL_DBsignal, NULL, PERL_MAGIC_debugvar, &PL_vtbl_debugvar, 0, 0); 4344 mg->mg_private = DBVARMG_SIGNAL; 4345 SvSETMAGIC(PL_DBsignal); 4346 4347 SvREFCNT_dec(PL_curstash); 4348 PL_curstash = ostash; 4349 } 4350 4351 #ifndef STRESS_REALLOC 4352 #define REASONABLE(size) (size) 4353 #define REASONABLE_but_at_least(size,min) (size) 4354 #else 4355 #define REASONABLE(size) (1) /* unreasonable */ 4356 #define REASONABLE_but_at_least(size,min) (min) 4357 #endif 4358 4359 void 4360 Perl_init_stacks(pTHX) 4361 { 4362 SSize_t size; 4363 4364 /* start with 128-item stack and 8K cxstack */ 4365 PL_curstackinfo = new_stackinfo(REASONABLE(128), 4366 REASONABLE(8192/sizeof(PERL_CONTEXT) - 1)); 4367 PL_curstackinfo->si_type = PERLSI_MAIN; 4368 #if defined DEBUGGING && !defined DEBUGGING_RE_ONLY 4369 PL_curstackinfo->si_stack_hwm = 0; 4370 #endif 4371 PL_curstack = PL_curstackinfo->si_stack; 4372 PL_mainstack = PL_curstack; /* remember in case we switch stacks */ 4373 4374 PL_stack_base = AvARRAY(PL_curstack); 4375 PL_stack_sp = PL_stack_base; 4376 PL_stack_max = PL_stack_base + AvMAX(PL_curstack); 4377 4378 Newx(PL_tmps_stack,REASONABLE(128),SV*); 4379 PL_tmps_floor = -1; 4380 PL_tmps_ix = -1; 4381 PL_tmps_max = REASONABLE(128); 4382 4383 Newx(PL_markstack,REASONABLE(32),I32); 4384 PL_markstack_ptr = PL_markstack; 4385 PL_markstack_max = PL_markstack + REASONABLE(32); 4386 4387 SET_MARK_OFFSET; 4388 4389 Newx(PL_scopestack,REASONABLE(32),I32); 4390 #ifdef DEBUGGING 4391 Newx(PL_scopestack_name,REASONABLE(32),const char*); 4392 #endif 4393 PL_scopestack_ix = 0; 4394 PL_scopestack_max = REASONABLE(32); 4395 4396 size = REASONABLE_but_at_least(128,SS_MAXPUSH); 4397 Newx(PL_savestack, size, ANY); 4398 PL_savestack_ix = 0; 4399 /*PL_savestack_max lies: it always has SS_MAXPUSH more than it claims */ 4400 PL_savestack_max = size - SS_MAXPUSH; 4401 } 4402 4403 #undef REASONABLE 4404 4405 STATIC void 4406 S_nuke_stacks(pTHX) 4407 { 4408 while (PL_curstackinfo->si_next) 4409 PL_curstackinfo = PL_curstackinfo->si_next; 4410 while (PL_curstackinfo) { 4411 PERL_SI *p = PL_curstackinfo->si_prev; 4412 /* curstackinfo->si_stack got nuked by sv_free_arenas() */ 4413 Safefree(PL_curstackinfo->si_cxstack); 4414 Safefree(PL_curstackinfo); 4415 PL_curstackinfo = p; 4416 } 4417 Safefree(PL_tmps_stack); 4418 Safefree(PL_markstack); 4419 Safefree(PL_scopestack); 4420 #ifdef DEBUGGING 4421 Safefree(PL_scopestack_name); 4422 #endif 4423 Safefree(PL_savestack); 4424 } 4425 4426 void 4427 Perl_populate_isa(pTHX_ const char *name, STRLEN len, ...) 4428 { 4429 GV *const gv = gv_fetchpvn(name, len, GV_ADD | GV_ADDMULTI, SVt_PVAV); 4430 AV *const isa = GvAVn(gv); 4431 va_list args; 4432 4433 PERL_ARGS_ASSERT_POPULATE_ISA; 4434 4435 if(AvFILLp(isa) != -1) 4436 return; 4437 4438 /* NOTE: No support for tied ISA */ 4439 4440 va_start(args, len); 4441 do { 4442 const char *const parent = va_arg(args, const char*); 4443 size_t parent_len; 4444 4445 if (!parent) 4446 break; 4447 parent_len = va_arg(args, size_t); 4448 4449 /* Arguments are supplied with a trailing :: */ 4450 assert(parent_len > 2); 4451 assert(parent[parent_len - 1] == ':'); 4452 assert(parent[parent_len - 2] == ':'); 4453 av_push(isa, newSVpvn(parent, parent_len - 2)); 4454 (void) gv_fetchpvn(parent, parent_len, GV_ADD, SVt_PVGV); 4455 } while (1); 4456 va_end(args); 4457 } 4458 4459 4460 STATIC void 4461 S_init_predump_symbols(pTHX) 4462 { 4463 GV *tmpgv; 4464 IO *io; 4465 4466 sv_setpvs(get_sv("\"", GV_ADD), " "); 4467 PL_ofsgv = (GV*)SvREFCNT_inc(gv_fetchpvs(",", GV_ADD|GV_NOTQUAL, SVt_PV)); 4468 4469 4470 /* Historically, PVIOs were blessed into IO::Handle, unless 4471 FileHandle was loaded, in which case they were blessed into 4472 that. Action at a distance. 4473 However, if we simply bless into IO::Handle, we break code 4474 that assumes that PVIOs will have (among others) a seek 4475 method. IO::File inherits from IO::Handle and IO::Seekable, 4476 and provides the needed methods. But if we simply bless into 4477 it, then we break code that assumed that by loading 4478 IO::Handle, *it* would work. 4479 So a compromise is to set up the correct @IO::File::ISA, 4480 so that code that does C<use IO::Handle>; will still work. 4481 */ 4482 4483 Perl_populate_isa(aTHX_ STR_WITH_LEN("IO::File::ISA"), 4484 STR_WITH_LEN("IO::Handle::"), 4485 STR_WITH_LEN("IO::Seekable::"), 4486 STR_WITH_LEN("Exporter::"), 4487 NULL); 4488 4489 PL_stdingv = gv_fetchpvs("STDIN", GV_ADD|GV_NOTQUAL, SVt_PVIO); 4490 GvMULTI_on(PL_stdingv); 4491 io = GvIOp(PL_stdingv); 4492 IoTYPE(io) = IoTYPE_RDONLY; 4493 IoIFP(io) = PerlIO_stdin(); 4494 tmpgv = gv_fetchpvs("stdin", GV_ADD|GV_NOTQUAL, SVt_PV); 4495 GvMULTI_on(tmpgv); 4496 GvIOp(tmpgv) = MUTABLE_IO(SvREFCNT_inc_simple(io)); 4497 4498 tmpgv = gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVIO); 4499 GvMULTI_on(tmpgv); 4500 io = GvIOp(tmpgv); 4501 IoTYPE(io) = IoTYPE_WRONLY; 4502 IoOFP(io) = IoIFP(io) = PerlIO_stdout(); 4503 setdefout(tmpgv); 4504 tmpgv = gv_fetchpvs("stdout", GV_ADD|GV_NOTQUAL, SVt_PV); 4505 GvMULTI_on(tmpgv); 4506 GvIOp(tmpgv) = MUTABLE_IO(SvREFCNT_inc_simple(io)); 4507 4508 PL_stderrgv = gv_fetchpvs("STDERR", GV_ADD|GV_NOTQUAL, SVt_PVIO); 4509 GvMULTI_on(PL_stderrgv); 4510 io = GvIOp(PL_stderrgv); 4511 IoTYPE(io) = IoTYPE_WRONLY; 4512 IoOFP(io) = IoIFP(io) = PerlIO_stderr(); 4513 tmpgv = gv_fetchpvs("stderr", GV_ADD|GV_NOTQUAL, SVt_PV); 4514 GvMULTI_on(tmpgv); 4515 GvIOp(tmpgv) = MUTABLE_IO(SvREFCNT_inc_simple(io)); 4516 4517 PL_statname = newSVpvs(""); /* last filename we did stat on */ 4518 } 4519 4520 void 4521 Perl_init_argv_symbols(pTHX_ int argc, char **argv) 4522 { 4523 PERL_ARGS_ASSERT_INIT_ARGV_SYMBOLS; 4524 4525 argc--,argv++; /* skip name of script */ 4526 if (PL_doswitches) { 4527 for (; argc > 0 && **argv == '-'; argc--,argv++) { 4528 char *s; 4529 if (!argv[0][1]) 4530 break; 4531 if (argv[0][1] == '-' && !argv[0][2]) { 4532 argc--,argv++; 4533 break; 4534 } 4535 if ((s = strchr(argv[0], '='))) { 4536 const char *const start_name = argv[0] + 1; 4537 sv_setpv(GvSV(gv_fetchpvn_flags(start_name, s - start_name, 4538 TRUE, SVt_PV)), s + 1); 4539 } 4540 else 4541 sv_setiv(GvSV(gv_fetchpv(argv[0]+1, GV_ADD, SVt_PV)),1); 4542 } 4543 } 4544 if ((PL_argvgv = gv_fetchpvs("ARGV", GV_ADD|GV_NOTQUAL, SVt_PVAV))) { 4545 SvREFCNT_inc_simple_void_NN(PL_argvgv); 4546 GvMULTI_on(PL_argvgv); 4547 av_clear(GvAVn(PL_argvgv)); 4548 for (; argc > 0; argc--,argv++) { 4549 SV * const sv = newSVpv(argv[0],0); 4550 av_push(GvAV(PL_argvgv),sv); 4551 if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) { 4552 if (PL_unicode & PERL_UNICODE_ARGV_FLAG) 4553 SvUTF8_on(sv); 4554 } 4555 if (PL_unicode & PERL_UNICODE_WIDESYSCALLS_FLAG) /* Sarathy? */ 4556 (void)sv_utf8_decode(sv); 4557 } 4558 } 4559 4560 if (PL_inplace && (!PL_argvgv || AvFILL(GvAV(PL_argvgv)) == -1)) 4561 Perl_ck_warner_d(aTHX_ packWARN(WARN_INPLACE), 4562 "-i used with no filenames on the command line, " 4563 "reading from STDIN"); 4564 } 4565 4566 STATIC void 4567 S_init_postdump_symbols(pTHX_ int argc, char **argv, char **env) 4568 { 4569 #ifdef USE_ITHREADS 4570 dVAR; 4571 #endif 4572 GV* tmpgv; 4573 4574 PERL_ARGS_ASSERT_INIT_POSTDUMP_SYMBOLS; 4575 4576 PL_toptarget = newSV_type(SVt_PVIV); 4577 SvPVCLEAR(PL_toptarget); 4578 PL_bodytarget = newSV_type(SVt_PVIV); 4579 SvPVCLEAR(PL_bodytarget); 4580 PL_formtarget = PL_bodytarget; 4581 4582 TAINT; 4583 4584 init_argv_symbols(argc,argv); 4585 4586 if ((tmpgv = gv_fetchpvs("0", GV_ADD|GV_NOTQUAL, SVt_PV))) { 4587 sv_setpv(GvSV(tmpgv),PL_origfilename); 4588 } 4589 if ((PL_envgv = gv_fetchpvs("ENV", GV_ADD|GV_NOTQUAL, SVt_PVHV))) { 4590 HV *hv; 4591 bool env_is_not_environ; 4592 SvREFCNT_inc_simple_void_NN(PL_envgv); 4593 GvMULTI_on(PL_envgv); 4594 hv = GvHVn(PL_envgv); 4595 hv_magic(hv, NULL, PERL_MAGIC_env); 4596 #ifndef PERL_MICRO 4597 #ifdef USE_ENVIRON_ARRAY 4598 /* Note that if the supplied env parameter is actually a copy 4599 of the global environ then it may now point to free'd memory 4600 if the environment has been modified since. To avoid this 4601 problem we treat env==NULL as meaning 'use the default' 4602 */ 4603 if (!env) 4604 env = environ; 4605 env_is_not_environ = env != environ; 4606 if (env_is_not_environ 4607 # ifdef USE_ITHREADS 4608 && PL_curinterp == aTHX 4609 # endif 4610 ) 4611 { 4612 environ[0] = NULL; 4613 } 4614 if (env) { 4615 char *s, *old_var; 4616 STRLEN nlen; 4617 SV *sv; 4618 HV *dups = newHV(); 4619 4620 for (; *env; env++) { 4621 old_var = *env; 4622 4623 if (!(s = strchr(old_var,'=')) || s == old_var) 4624 continue; 4625 nlen = s - old_var; 4626 4627 #if defined(MSDOS) && !defined(DJGPP) 4628 *s = '\0'; 4629 (void)strupr(old_var); 4630 *s = '='; 4631 #endif 4632 if (hv_exists(hv, old_var, nlen)) { 4633 const char *name = savepvn(old_var, nlen); 4634 4635 /* make sure we use the same value as getenv(), otherwise code that 4636 uses getenv() (like setlocale()) might see a different value to %ENV 4637 */ 4638 sv = newSVpv(PerlEnv_getenv(name), 0); 4639 4640 /* keep a count of the dups of this name so we can de-dup environ later */ 4641 if (hv_exists(dups, name, nlen)) 4642 ++SvIVX(*hv_fetch(dups, name, nlen, 0)); 4643 else 4644 (void)hv_store(dups, name, nlen, newSViv(1), 0); 4645 4646 Safefree(name); 4647 } 4648 else { 4649 sv = newSVpv(s+1, 0); 4650 } 4651 (void)hv_store(hv, old_var, nlen, sv, 0); 4652 if (env_is_not_environ) 4653 mg_set(sv); 4654 } 4655 if (HvKEYS(dups)) { 4656 /* environ has some duplicate definitions, remove them */ 4657 HE *entry; 4658 hv_iterinit(dups); 4659 while ((entry = hv_iternext_flags(dups, 0))) { 4660 STRLEN nlen; 4661 const char *name = HePV(entry, nlen); 4662 IV count = SvIV(HeVAL(entry)); 4663 IV i; 4664 SV **valp = hv_fetch(hv, name, nlen, 0); 4665 4666 assert(valp); 4667 4668 /* try to remove any duplicate names, depending on the 4669 * implementation used in my_setenv() the iteration might 4670 * not be necessary, but let's be safe. 4671 */ 4672 for (i = 0; i < count; ++i) 4673 my_setenv(name, 0); 4674 4675 /* and set it back to the value we set $ENV{name} to */ 4676 my_setenv(name, SvPV_nolen(*valp)); 4677 } 4678 } 4679 SvREFCNT_dec_NN(dups); 4680 } 4681 #endif /* USE_ENVIRON_ARRAY */ 4682 #endif /* !PERL_MICRO */ 4683 } 4684 TAINT_NOT; 4685 4686 /* touch @F array to prevent spurious warnings 20020415 MJD */ 4687 if (PL_minus_a) { 4688 (void) get_av("main::F", GV_ADD | GV_ADDMULTI); 4689 } 4690 } 4691 4692 STATIC void 4693 S_init_perllib(pTHX) 4694 { 4695 #ifndef VMS 4696 const char *perl5lib = NULL; 4697 #endif 4698 const char *s; 4699 #if defined(WIN32) && !defined(PERL_IS_MINIPERL) 4700 STRLEN len; 4701 #endif 4702 4703 if (!TAINTING_get) { 4704 #ifndef VMS 4705 perl5lib = PerlEnv_getenv("PERL5LIB"); 4706 /* 4707 * It isn't possible to delete an environment variable with 4708 * PERL_USE_SAFE_PUTENV set unless unsetenv() is also available, so in that 4709 * case we treat PERL5LIB as undefined if it has a zero-length value. 4710 */ 4711 #if defined(PERL_USE_SAFE_PUTENV) && ! defined(HAS_UNSETENV) 4712 if (perl5lib && *perl5lib != '\0') 4713 #else 4714 if (perl5lib) 4715 #endif 4716 incpush_use_sep(perl5lib, 0, INCPUSH_ADD_SUB_DIRS); 4717 else { 4718 s = PerlEnv_getenv("PERLLIB"); 4719 if (s) 4720 incpush_use_sep(s, 0, 0); 4721 } 4722 #else /* VMS */ 4723 /* Treat PERL5?LIB as a possible search list logical name -- the 4724 * "natural" VMS idiom for a Unix path string. We allow each 4725 * element to be a set of |-separated directories for compatibility. 4726 */ 4727 char buf[256]; 4728 int idx = 0; 4729 if (vmstrnenv("PERL5LIB",buf,0,NULL,0)) 4730 do { 4731 incpush_use_sep(buf, 0, INCPUSH_ADD_SUB_DIRS); 4732 } while (vmstrnenv("PERL5LIB",buf,++idx,NULL,0)); 4733 else { 4734 while (vmstrnenv("PERLLIB",buf,idx++,NULL,0)) 4735 incpush_use_sep(buf, 0, 0); 4736 } 4737 #endif /* VMS */ 4738 } 4739 4740 #ifndef PERL_IS_MINIPERL 4741 /* miniperl gets just -I..., the split of $ENV{PERL5LIB}, and "." in @INC 4742 (and not the architecture specific directories from $ENV{PERL5LIB}) */ 4743 4744 #include "perl_inc_macro.h" 4745 /* Use the ~-expanded versions of APPLLIB (undocumented), 4746 SITEARCH, SITELIB, VENDORARCH, VENDORLIB, ARCHLIB and PRIVLIB 4747 */ 4748 INCPUSH_APPLLIB_EXP 4749 INCPUSH_SITEARCH_EXP 4750 INCPUSH_SITELIB_EXP 4751 INCPUSH_PERL_VENDORARCH_EXP 4752 INCPUSH_PERL_VENDORLIB_EXP 4753 INCPUSH_ARCHLIB_EXP 4754 INCPUSH_PRIVLIB_EXP 4755 INCPUSH_PERL_OTHERLIBDIRS 4756 INCPUSH_PERL5LIB 4757 INCPUSH_APPLLIB_OLD_EXP 4758 INCPUSH_SITELIB_STEM 4759 INCPUSH_PERL_VENDORLIB_STEM 4760 INCPUSH_PERL_OTHERLIBDIRS_ARCHONLY 4761 4762 #endif /* !PERL_IS_MINIPERL */ 4763 4764 if (!TAINTING_get) { 4765 #if !defined(PERL_IS_MINIPERL) && defined(DEFAULT_INC_EXCLUDES_DOT) 4766 const char * const unsafe = PerlEnv_getenv("PERL_USE_UNSAFE_INC"); 4767 if (unsafe && strEQ(unsafe, "1")) 4768 #endif 4769 S_incpush(aTHX_ STR_WITH_LEN("."), 0); 4770 } 4771 } 4772 4773 #if defined(DOSISH) || defined(__SYMBIAN32__) 4774 # define PERLLIB_SEP ';' 4775 #elif defined(__VMS) 4776 # define PERLLIB_SEP PL_perllib_sep 4777 #else 4778 # define PERLLIB_SEP ':' 4779 #endif 4780 #ifndef PERLLIB_MANGLE 4781 # define PERLLIB_MANGLE(s,n) (s) 4782 #endif 4783 4784 #ifndef PERL_IS_MINIPERL 4785 /* Push a directory onto @INC if it exists. 4786 Generate a new SV if we do this, to save needing to copy the SV we push 4787 onto @INC */ 4788 STATIC SV * 4789 S_incpush_if_exists(pTHX_ AV *const av, SV *dir, SV *const stem) 4790 { 4791 Stat_t tmpstatbuf; 4792 4793 PERL_ARGS_ASSERT_INCPUSH_IF_EXISTS; 4794 4795 if (PerlLIO_stat(SvPVX_const(dir), &tmpstatbuf) >= 0 && 4796 S_ISDIR(tmpstatbuf.st_mode)) { 4797 av_push(av, dir); 4798 dir = newSVsv(stem); 4799 } else { 4800 /* Truncate dir back to stem. */ 4801 SvCUR_set(dir, SvCUR(stem)); 4802 } 4803 return dir; 4804 } 4805 #endif 4806 4807 STATIC SV * 4808 S_mayberelocate(pTHX_ const char *const dir, STRLEN len, U32 flags) 4809 { 4810 const U8 canrelocate = (U8)flags & INCPUSH_CAN_RELOCATE; 4811 SV *libdir; 4812 4813 PERL_ARGS_ASSERT_MAYBERELOCATE; 4814 assert(len > 0); 4815 4816 /* I am not convinced that this is valid when PERLLIB_MANGLE is 4817 defined to so something (in os2/os2.c), but the code has been 4818 this way, ignoring any possible changed of length, since 4819 760ac839baf413929cd31cc32ffd6dba6b781a81 (5.003_02) so I'll leave 4820 it be. */ 4821 libdir = newSVpvn(PERLLIB_MANGLE(dir, len), len); 4822 4823 #ifdef VMS 4824 { 4825 char *unix; 4826 4827 if ((unix = tounixspec_ts(SvPV(libdir,len),NULL)) != NULL) { 4828 len = strlen(unix); 4829 while (len > 1 && unix[len-1] == '/') len--; /* Cosmetic */ 4830 sv_usepvn(libdir,unix,len); 4831 } 4832 else 4833 PerlIO_printf(Perl_error_log, 4834 "Failed to unixify @INC element \"%s\"\n", 4835 SvPV_nolen_const(libdir)); 4836 } 4837 #endif 4838 4839 /* Do the if() outside the #ifdef to avoid warnings about an unused 4840 parameter. */ 4841 if (canrelocate) { 4842 #ifdef PERL_RELOCATABLE_INC 4843 /* 4844 * Relocatable include entries are marked with a leading .../ 4845 * 4846 * The algorithm is 4847 * 0: Remove that leading ".../" 4848 * 1: Remove trailing executable name (anything after the last '/') 4849 * from the perl path to give a perl prefix 4850 * Then 4851 * While the @INC element starts "../" and the prefix ends with a real 4852 * directory (ie not . or ..) chop that real directory off the prefix 4853 * and the leading "../" from the @INC element. ie a logical "../" 4854 * cleanup 4855 * Finally concatenate the prefix and the remainder of the @INC element 4856 * The intent is that /usr/local/bin/perl and .../../lib/perl5 4857 * generates /usr/local/lib/perl5 4858 */ 4859 const char *libpath = SvPVX(libdir); 4860 STRLEN libpath_len = SvCUR(libdir); 4861 if (memBEGINs(libpath, libpath_len, ".../")) { 4862 /* Game on! */ 4863 SV * const caret_X = get_sv("\030", 0); 4864 /* Going to use the SV just as a scratch buffer holding a C 4865 string: */ 4866 SV *prefix_sv; 4867 char *prefix; 4868 char *lastslash; 4869 4870 /* $^X is *the* source of taint if tainting is on, hence 4871 SvPOK() won't be true. */ 4872 assert(caret_X); 4873 assert(SvPOKp(caret_X)); 4874 prefix_sv = newSVpvn_flags(SvPVX(caret_X), SvCUR(caret_X), 4875 SvUTF8(caret_X)); 4876 /* Firstly take off the leading .../ 4877 If all else fail we'll do the paths relative to the current 4878 directory. */ 4879 sv_chop(libdir, libpath + 4); 4880 /* Don't use SvPV as we're intentionally bypassing taining, 4881 mortal copies that the mg_get of tainting creates, and 4882 corruption that seems to come via the save stack. 4883 I guess that the save stack isn't correctly set up yet. */ 4884 libpath = SvPVX(libdir); 4885 libpath_len = SvCUR(libdir); 4886 4887 prefix = SvPVX(prefix_sv); 4888 lastslash = (char *) my_memrchr(prefix, '/', 4889 SvEND(prefix_sv) - prefix); 4890 4891 /* First time in with the *lastslash = '\0' we just wipe off 4892 the trailing /perl from (say) /usr/foo/bin/perl 4893 */ 4894 if (lastslash) { 4895 SV *tempsv; 4896 while ((*lastslash = '\0'), /* Do that, come what may. */ 4897 ( memBEGINs(libpath, libpath_len, "../") 4898 && (lastslash = 4899 (char *) my_memrchr(prefix, '/', 4900 SvEND(prefix_sv) - prefix)))) 4901 { 4902 if (lastslash[1] == '\0' 4903 || (lastslash[1] == '.' 4904 && (lastslash[2] == '/' /* ends "/." */ 4905 || (lastslash[2] == '/' 4906 && lastslash[3] == '/' /* or "/.." */ 4907 )))) { 4908 /* Prefix ends "/" or "/." or "/..", any of which 4909 are fishy, so don't do any more logical cleanup. 4910 */ 4911 break; 4912 } 4913 /* Remove leading "../" from path */ 4914 libpath += 3; 4915 libpath_len -= 3; 4916 /* Next iteration round the loop removes the last 4917 directory name from prefix by writing a '\0' in 4918 the while clause. */ 4919 } 4920 /* prefix has been terminated with a '\0' to the correct 4921 length. libpath points somewhere into the libdir SV. 4922 We need to join the 2 with '/' and drop the result into 4923 libdir. */ 4924 tempsv = Perl_newSVpvf(aTHX_ "%s/%s", prefix, libpath); 4925 SvREFCNT_dec(libdir); 4926 /* And this is the new libdir. */ 4927 libdir = tempsv; 4928 if (TAINTING_get && 4929 (PerlProc_getuid() != PerlProc_geteuid() || 4930 PerlProc_getgid() != PerlProc_getegid())) { 4931 /* Need to taint relocated paths if running set ID */ 4932 SvTAINTED_on(libdir); 4933 } 4934 } 4935 SvREFCNT_dec(prefix_sv); 4936 } 4937 #endif 4938 } 4939 return libdir; 4940 } 4941 4942 STATIC void 4943 S_incpush(pTHX_ const char *const dir, STRLEN len, U32 flags) 4944 { 4945 #ifndef PERL_IS_MINIPERL 4946 const U8 using_sub_dirs 4947 = (U8)flags & (INCPUSH_ADD_VERSIONED_SUB_DIRS 4948 |INCPUSH_ADD_ARCHONLY_SUB_DIRS|INCPUSH_ADD_OLD_VERS); 4949 const U8 add_versioned_sub_dirs 4950 = (U8)flags & INCPUSH_ADD_VERSIONED_SUB_DIRS; 4951 const U8 add_archonly_sub_dirs 4952 = (U8)flags & INCPUSH_ADD_ARCHONLY_SUB_DIRS; 4953 #ifdef PERL_INC_VERSION_LIST 4954 const U8 addoldvers = (U8)flags & INCPUSH_ADD_OLD_VERS; 4955 #endif 4956 #endif 4957 const U8 unshift = (U8)flags & INCPUSH_UNSHIFT; 4958 const U8 push_basedir = (flags & INCPUSH_NOT_BASEDIR) ? 0 : 1; 4959 AV *const inc = GvAVn(PL_incgv); 4960 4961 PERL_ARGS_ASSERT_INCPUSH; 4962 assert(len > 0); 4963 4964 /* Could remove this vestigial extra block, if we don't mind a lot of 4965 re-indenting diff noise. */ 4966 { 4967 SV *const libdir = mayberelocate(dir, len, flags); 4968 /* Change 20189146be79a0596543441fa369c6bf7f85103f, to fix RT#6665, 4969 arranged to unshift #! line -I onto the front of @INC. However, 4970 -I can add version and architecture specific libraries, and they 4971 need to go first. The old code assumed that it was always 4972 pushing. Hence to make it work, need to push the architecture 4973 (etc) libraries onto a temporary array, then "unshift" that onto 4974 the front of @INC. */ 4975 #ifndef PERL_IS_MINIPERL 4976 AV *const av = (using_sub_dirs) ? (unshift ? newAV() : inc) : NULL; 4977 4978 /* 4979 * BEFORE pushing libdir onto @INC we may first push version- and 4980 * archname-specific sub-directories. 4981 */ 4982 if (using_sub_dirs) { 4983 SV *subdir = newSVsv(libdir); 4984 #ifdef PERL_INC_VERSION_LIST 4985 /* Configure terminates PERL_INC_VERSION_LIST with a NULL */ 4986 const char * const incverlist[] = { PERL_INC_VERSION_LIST }; 4987 const char * const *incver; 4988 #endif 4989 4990 if (add_versioned_sub_dirs) { 4991 /* .../version/archname if -d .../version/archname */ 4992 sv_catpvs(subdir, "/" PERL_FS_VERSION "/" ARCHNAME); 4993 subdir = S_incpush_if_exists(aTHX_ av, subdir, libdir); 4994 4995 /* .../version if -d .../version */ 4996 sv_catpvs(subdir, "/" PERL_FS_VERSION); 4997 subdir = S_incpush_if_exists(aTHX_ av, subdir, libdir); 4998 } 4999 5000 #ifdef PERL_INC_VERSION_LIST 5001 if (addoldvers) { 5002 for (incver = incverlist; *incver; incver++) { 5003 /* .../xxx if -d .../xxx */ 5004 Perl_sv_catpvf(aTHX_ subdir, "/%s", *incver); 5005 subdir = S_incpush_if_exists(aTHX_ av, subdir, libdir); 5006 } 5007 } 5008 #endif 5009 5010 if (add_archonly_sub_dirs) { 5011 /* .../archname if -d .../archname */ 5012 sv_catpvs(subdir, "/" ARCHNAME); 5013 subdir = S_incpush_if_exists(aTHX_ av, subdir, libdir); 5014 5015 } 5016 5017 assert (SvREFCNT(subdir) == 1); 5018 SvREFCNT_dec(subdir); 5019 } 5020 #endif /* !PERL_IS_MINIPERL */ 5021 /* finally add this lib directory at the end of @INC */ 5022 if (unshift) { 5023 #ifdef PERL_IS_MINIPERL 5024 const Size_t extra = 0; 5025 #else 5026 Size_t extra = av_tindex(av) + 1; 5027 #endif 5028 av_unshift(inc, extra + push_basedir); 5029 if (push_basedir) 5030 av_store(inc, extra, libdir); 5031 #ifndef PERL_IS_MINIPERL 5032 while (extra--) { 5033 /* av owns a reference, av_store() expects to be donated a 5034 reference, and av expects to be sane when it's cleared. 5035 If I wanted to be naughty and wrong, I could peek inside the 5036 implementation of av_clear(), realise that it uses 5037 SvREFCNT_dec() too, so av's array could be a run of NULLs, 5038 and so directly steal from it (with a memcpy() to inc, and 5039 then memset() to NULL them out. But people copy code from the 5040 core expecting it to be best practise, so let's use the API. 5041 Although studious readers will note that I'm not checking any 5042 return codes. */ 5043 av_store(inc, extra, SvREFCNT_inc(*av_fetch(av, extra, FALSE))); 5044 } 5045 SvREFCNT_dec(av); 5046 #endif 5047 } 5048 else if (push_basedir) { 5049 av_push(inc, libdir); 5050 } 5051 5052 if (!push_basedir) { 5053 assert (SvREFCNT(libdir) == 1); 5054 SvREFCNT_dec(libdir); 5055 } 5056 } 5057 } 5058 5059 STATIC void 5060 S_incpush_use_sep(pTHX_ const char *p, STRLEN len, U32 flags) 5061 { 5062 const char *s; 5063 const char *end; 5064 /* This logic has been broken out from S_incpush(). It may be possible to 5065 simplify it. */ 5066 5067 PERL_ARGS_ASSERT_INCPUSH_USE_SEP; 5068 5069 /* perl compiled with -DPERL_RELOCATABLE_INCPUSH will ignore the len 5070 * argument to incpush_use_sep. This allows creation of relocatable 5071 * Perl distributions that patch the binary at install time. Those 5072 * distributions will have to provide their own relocation tools; this 5073 * is not a feature otherwise supported by core Perl. 5074 */ 5075 #ifndef PERL_RELOCATABLE_INCPUSH 5076 if (!len) 5077 #endif 5078 len = strlen(p); 5079 5080 end = p + len; 5081 5082 /* Break at all separators */ 5083 while ((s = (const char*)memchr(p, PERLLIB_SEP, end - p))) { 5084 if (s == p) { 5085 /* skip any consecutive separators */ 5086 5087 /* Uncomment the next line for PATH semantics */ 5088 /* But you'll need to write tests */ 5089 /* av_push(GvAVn(PL_incgv), newSVpvs(".")); */ 5090 } else { 5091 incpush(p, (STRLEN)(s - p), flags); 5092 } 5093 p = s + 1; 5094 } 5095 if (p != end) 5096 incpush(p, (STRLEN)(end - p), flags); 5097 5098 } 5099 5100 void 5101 Perl_call_list(pTHX_ I32 oldscope, AV *paramList) 5102 { 5103 SV *atsv; 5104 volatile const line_t oldline = PL_curcop ? CopLINE(PL_curcop) : 0; 5105 CV *cv; 5106 STRLEN len; 5107 int ret; 5108 dJMPENV; 5109 5110 PERL_ARGS_ASSERT_CALL_LIST; 5111 5112 while (av_tindex(paramList) >= 0) { 5113 cv = MUTABLE_CV(av_shift(paramList)); 5114 if (PL_savebegin) { 5115 if (paramList == PL_beginav) { 5116 /* save PL_beginav for compiler */ 5117 Perl_av_create_and_push(aTHX_ &PL_beginav_save, MUTABLE_SV(cv)); 5118 } 5119 else if (paramList == PL_checkav) { 5120 /* save PL_checkav for compiler */ 5121 Perl_av_create_and_push(aTHX_ &PL_checkav_save, MUTABLE_SV(cv)); 5122 } 5123 else if (paramList == PL_unitcheckav) { 5124 /* save PL_unitcheckav for compiler */ 5125 Perl_av_create_and_push(aTHX_ &PL_unitcheckav_save, MUTABLE_SV(cv)); 5126 } 5127 } else { 5128 SAVEFREESV(cv); 5129 } 5130 JMPENV_PUSH(ret); 5131 switch (ret) { 5132 case 0: 5133 CALL_LIST_BODY(cv); 5134 atsv = ERRSV; 5135 (void)SvPV_const(atsv, len); 5136 if (len) { 5137 PL_curcop = &PL_compiling; 5138 CopLINE_set(PL_curcop, oldline); 5139 if (paramList == PL_beginav) 5140 sv_catpvs(atsv, "BEGIN failed--compilation aborted"); 5141 else 5142 Perl_sv_catpvf(aTHX_ atsv, 5143 "%s failed--call queue aborted", 5144 paramList == PL_checkav ? "CHECK" 5145 : paramList == PL_initav ? "INIT" 5146 : paramList == PL_unitcheckav ? "UNITCHECK" 5147 : "END"); 5148 while (PL_scopestack_ix > oldscope) 5149 LEAVE; 5150 JMPENV_POP; 5151 Perl_croak(aTHX_ "%" SVf, SVfARG(atsv)); 5152 } 5153 break; 5154 case 1: 5155 STATUS_ALL_FAILURE; 5156 /* FALLTHROUGH */ 5157 case 2: 5158 /* my_exit() was called */ 5159 while (PL_scopestack_ix > oldscope) 5160 LEAVE; 5161 FREETMPS; 5162 SET_CURSTASH(PL_defstash); 5163 PL_curcop = &PL_compiling; 5164 CopLINE_set(PL_curcop, oldline); 5165 JMPENV_POP; 5166 my_exit_jump(); 5167 NOT_REACHED; /* NOTREACHED */ 5168 case 3: 5169 if (PL_restartop) { 5170 PL_curcop = &PL_compiling; 5171 CopLINE_set(PL_curcop, oldline); 5172 JMPENV_JUMP(3); 5173 } 5174 PerlIO_printf(Perl_error_log, "panic: restartop in call_list\n"); 5175 FREETMPS; 5176 break; 5177 } 5178 JMPENV_POP; 5179 } 5180 } 5181 5182 /* 5183 =for apidoc my_exit 5184 5185 A wrapper for the C library L<exit(3)>, honoring what L<perlapi/PL_exit_flags> 5186 say to do. 5187 5188 =cut 5189 */ 5190 5191 void 5192 Perl_my_exit(pTHX_ U32 status) 5193 { 5194 if (PL_exit_flags & PERL_EXIT_ABORT) { 5195 abort(); 5196 } 5197 if (PL_exit_flags & PERL_EXIT_WARN) { 5198 PL_exit_flags |= PERL_EXIT_ABORT; /* Protect against reentrant calls */ 5199 Perl_warn(aTHX_ "Unexpected exit %lu", (unsigned long)status); 5200 PL_exit_flags &= ~PERL_EXIT_ABORT; 5201 } 5202 switch (status) { 5203 case 0: 5204 STATUS_ALL_SUCCESS; 5205 break; 5206 case 1: 5207 STATUS_ALL_FAILURE; 5208 break; 5209 default: 5210 STATUS_EXIT_SET(status); 5211 break; 5212 } 5213 my_exit_jump(); 5214 } 5215 5216 void 5217 Perl_my_failure_exit(pTHX) 5218 { 5219 #ifdef VMS 5220 /* We have been called to fall on our sword. The desired exit code 5221 * should be already set in STATUS_UNIX, but could be shifted over 5222 * by 8 bits. STATUS_UNIX_EXIT_SET will handle the cases where a 5223 * that code is set. 5224 * 5225 * If an error code has not been set, then force the issue. 5226 */ 5227 if (MY_POSIX_EXIT) { 5228 5229 /* According to the die_exit.t tests, if errno is non-zero */ 5230 /* It should be used for the error status. */ 5231 5232 if (errno == EVMSERR) { 5233 STATUS_NATIVE = vaxc$errno; 5234 } else { 5235 5236 /* According to die_exit.t tests, if the child_exit code is */ 5237 /* also zero, then we need to exit with a code of 255 */ 5238 if ((errno != 0) && (errno < 256)) 5239 STATUS_UNIX_EXIT_SET(errno); 5240 else if (STATUS_UNIX < 255) { 5241 STATUS_UNIX_EXIT_SET(255); 5242 } 5243 5244 } 5245 5246 /* The exit code could have been set by $? or vmsish which 5247 * means that it may not have fatal set. So convert 5248 * success/warning codes to fatal with out changing 5249 * the POSIX status code. The severity makes VMS native 5250 * status handling work, while UNIX mode programs use the 5251 * POSIX exit codes. 5252 */ 5253 if ((STATUS_NATIVE & (STS$K_SEVERE|STS$K_ERROR)) == 0) { 5254 STATUS_NATIVE &= STS$M_COND_ID; 5255 STATUS_NATIVE |= STS$K_ERROR | STS$M_INHIB_MSG; 5256 } 5257 } 5258 else { 5259 /* Traditionally Perl on VMS always expects a Fatal Error. */ 5260 if (vaxc$errno & 1) { 5261 5262 /* So force success status to failure */ 5263 if (STATUS_NATIVE & 1) 5264 STATUS_ALL_FAILURE; 5265 } 5266 else { 5267 if (!vaxc$errno) { 5268 STATUS_UNIX = EINTR; /* In case something cares */ 5269 STATUS_ALL_FAILURE; 5270 } 5271 else { 5272 int severity; 5273 STATUS_NATIVE = vaxc$errno; /* Should already be this */ 5274 5275 /* Encode the severity code */ 5276 severity = STATUS_NATIVE & STS$M_SEVERITY; 5277 STATUS_UNIX = (severity ? severity : 1) << 8; 5278 5279 /* Perl expects this to be a fatal error */ 5280 if (severity != STS$K_SEVERE) 5281 STATUS_ALL_FAILURE; 5282 } 5283 } 5284 } 5285 5286 #else 5287 int exitstatus; 5288 int eno = errno; 5289 if (eno & 255) 5290 STATUS_UNIX_SET(eno); 5291 else { 5292 exitstatus = STATUS_UNIX >> 8; 5293 if (exitstatus & 255) 5294 STATUS_UNIX_SET(exitstatus); 5295 else 5296 STATUS_UNIX_SET(255); 5297 } 5298 #endif 5299 if (PL_exit_flags & PERL_EXIT_ABORT) { 5300 abort(); 5301 } 5302 if (PL_exit_flags & PERL_EXIT_WARN) { 5303 PL_exit_flags |= PERL_EXIT_ABORT; /* Protect against reentrant calls */ 5304 Perl_warn(aTHX_ "Unexpected exit failure %ld", (long)PL_statusvalue); 5305 PL_exit_flags &= ~PERL_EXIT_ABORT; 5306 } 5307 my_exit_jump(); 5308 } 5309 5310 STATIC void 5311 S_my_exit_jump(pTHX) 5312 { 5313 if (PL_e_script) { 5314 SvREFCNT_dec(PL_e_script); 5315 PL_e_script = NULL; 5316 } 5317 5318 POPSTACK_TO(PL_mainstack); 5319 if (cxstack_ix >= 0) { 5320 dounwind(-1); 5321 cx_popblock(cxstack); 5322 } 5323 LEAVE_SCOPE(0); 5324 5325 JMPENV_JUMP(2); 5326 } 5327 5328 static I32 5329 read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen) 5330 { 5331 const char * const p = SvPVX_const(PL_e_script); 5332 const char * const e = SvEND(PL_e_script); 5333 const char *nl = (char *) memchr(p, '\n', e - p); 5334 5335 PERL_UNUSED_ARG(idx); 5336 PERL_UNUSED_ARG(maxlen); 5337 5338 nl = (nl) ? nl+1 : e; 5339 if (nl-p == 0) { 5340 filter_del(read_e_script); 5341 return 0; 5342 } 5343 sv_catpvn(buf_sv, p, nl-p); 5344 sv_chop(PL_e_script, nl); 5345 return 1; 5346 } 5347 5348 /* removes boilerplate code at the end of each boot_Module xsub */ 5349 void 5350 Perl_xs_boot_epilog(pTHX_ const I32 ax) 5351 { 5352 if (PL_unitcheckav) 5353 call_list(PL_scopestack_ix, PL_unitcheckav); 5354 XSRETURN_YES; 5355 } 5356 5357 /* 5358 * ex: set ts=8 sts=4 sw=4 et: 5359 */ 5360