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