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