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