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