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