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