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