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