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