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