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