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