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