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