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