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