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