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