1 /* perl.c 2 * 3 * Copyright (c) 1987-1997 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 #include "perl.h" 16 #include "patchlevel.h" 17 18 /* XXX If this causes problems, set i_unistd=undef in the hint file. */ 19 #ifdef I_UNISTD 20 #include <unistd.h> 21 #endif 22 23 #if !defined(STANDARD_C) && !defined(HAS_GETENV_PROTOTYPE) 24 char *getenv _((char *)); /* Usually in <stdlib.h> */ 25 #endif 26 27 dEXTCONST char rcsid[] = "perl.c\nPatch level: ###\n"; 28 29 #ifdef IAMSUID 30 #ifndef DOSUID 31 #define DOSUID 32 #endif 33 #endif 34 35 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW 36 #ifdef DOSUID 37 #undef DOSUID 38 #endif 39 #endif 40 41 #define I_REINIT \ 42 STMT_START { \ 43 chopset = " \n-"; \ 44 copline = NOLINE; \ 45 curcop = &compiling; \ 46 curcopdb = NULL; \ 47 cxstack_ix = -1; \ 48 cxstack_max = 128; \ 49 dbargs = 0; \ 50 dlmax = 128; \ 51 laststatval = -1; \ 52 laststype = OP_STAT; \ 53 maxscream = -1; \ 54 maxsysfd = MAXSYSFD; \ 55 statname = Nullsv; \ 56 tmps_floor = -1; \ 57 tmps_ix = -1; \ 58 op_mask = NULL; \ 59 dlmax = 128; \ 60 laststatval = -1; \ 61 laststype = OP_STAT; \ 62 mess_sv = Nullsv; \ 63 } STMT_END 64 65 static void find_beginning _((void)); 66 static void forbid_setid _((char *)); 67 static void incpush _((char *, int)); 68 static void init_ids _((void)); 69 static void init_debugger _((void)); 70 static void init_lexer _((void)); 71 static void init_main_stash _((void)); 72 static void init_perllib _((void)); 73 static void init_postdump_symbols _((int, char **, char **)); 74 static void init_predump_symbols _((void)); 75 static void init_stacks _((void)); 76 static void my_exit_jump _((void)) __attribute__((noreturn)); 77 static void nuke_stacks _((void)); 78 static void open_script _((char *, bool, SV *)); 79 static void usage _((char *)); 80 static void validate_suid _((char *, char*)); 81 82 static int fdscript = -1; 83 84 PerlInterpreter * 85 perl_alloc() 86 { 87 PerlInterpreter *sv_interp; 88 89 curinterp = 0; 90 New(53, sv_interp, 1, PerlInterpreter); 91 return sv_interp; 92 } 93 94 void 95 perl_construct( sv_interp ) 96 register PerlInterpreter *sv_interp; 97 { 98 if (!(curinterp = sv_interp)) 99 return; 100 101 #ifdef MULTIPLICITY 102 Zero(sv_interp, 1, PerlInterpreter); 103 #endif 104 105 /* Init the real globals? */ 106 if (!linestr) { 107 linestr = NEWSV(65,80); 108 sv_upgrade(linestr,SVt_PVIV); 109 110 if (!SvREADONLY(&sv_undef)) { 111 SvREADONLY_on(&sv_undef); 112 113 sv_setpv(&sv_no,No); 114 SvNV(&sv_no); 115 SvREADONLY_on(&sv_no); 116 117 sv_setpv(&sv_yes,Yes); 118 SvNV(&sv_yes); 119 SvREADONLY_on(&sv_yes); 120 } 121 122 nrs = newSVpv("\n", 1); 123 rs = SvREFCNT_inc(nrs); 124 125 pidstatus = newHV(); 126 127 #ifdef MSDOS 128 /* 129 * There is no way we can refer to them from Perl so close them to save 130 * space. The other alternative would be to provide STDAUX and STDPRN 131 * filehandles. 132 */ 133 (void)fclose(stdaux); 134 (void)fclose(stdprn); 135 #endif 136 } 137 138 #ifdef MULTIPLICITY 139 I_REINIT; 140 perl_destruct_level = 1; 141 #else 142 if(perl_destruct_level > 0) 143 I_REINIT; 144 #endif 145 146 init_ids(); 147 lex_state = LEX_NOTPARSING; 148 149 start_env.je_prev = NULL; 150 start_env.je_ret = -1; 151 start_env.je_mustcatch = TRUE; 152 top_env = &start_env; 153 STATUS_ALL_SUCCESS; 154 155 SET_NUMERIC_STANDARD(); 156 #if defined(SUBVERSION) && SUBVERSION > 0 157 sprintf(patchlevel, "%7.5f", (double) 5 158 + ((double) PATCHLEVEL / (double) 1000) 159 + ((double) SUBVERSION / (double) 100000)); 160 #else 161 sprintf(patchlevel, "%5.3f", (double) 5 + 162 ((double) PATCHLEVEL / (double) 1000)); 163 #endif 164 165 #if defined(LOCAL_PATCH_COUNT) 166 localpatches = local_patches; /* For possible -v */ 167 #endif 168 169 PerlIO_init(); /* Hook to IO system */ 170 171 fdpid = newAV(); /* for remembering popen pids by fd */ 172 173 init_stacks(); 174 ENTER; 175 } 176 177 void 178 perl_destruct(sv_interp) 179 register PerlInterpreter *sv_interp; 180 { 181 int destruct_level; /* 0=none, 1=full, 2=full with checks */ 182 I32 last_sv_count; 183 HV *hv; 184 185 if (!(curinterp = sv_interp)) 186 return; 187 188 destruct_level = perl_destruct_level; 189 #ifdef DEBUGGING 190 { 191 char *s; 192 if (s = getenv("PERL_DESTRUCT_LEVEL")) { 193 int i = atoi(s); 194 if (destruct_level < i) 195 destruct_level = i; 196 } 197 } 198 #endif 199 200 LEAVE; 201 FREETMPS; 202 203 /* We must account for everything. */ 204 205 /* Destroy the main CV and syntax tree */ 206 if (main_root) { 207 curpad = AvARRAY(comppad); 208 op_free(main_root); 209 main_root = Nullop; 210 } 211 main_start = Nullop; 212 SvREFCNT_dec(main_cv); 213 main_cv = Nullcv; 214 215 if (sv_objcount) { 216 /* 217 * Try to destruct global references. We do this first so that the 218 * destructors and destructees still exist. Some sv's might remain. 219 * Non-referenced objects are on their own. 220 */ 221 222 dirty = TRUE; 223 sv_clean_objs(); 224 } 225 226 /* unhook hooks which will soon be, or use, destroyed data */ 227 SvREFCNT_dec(warnhook); 228 warnhook = Nullsv; 229 SvREFCNT_dec(diehook); 230 diehook = Nullsv; 231 SvREFCNT_dec(parsehook); 232 parsehook = Nullsv; 233 234 if (destruct_level == 0){ 235 236 DEBUG_P(debprofdump()); 237 238 /* The exit() function will do everything that needs doing. */ 239 return; 240 } 241 242 /* loosen bonds of global variables */ 243 244 if(rsfp) { 245 (void)PerlIO_close(rsfp); 246 rsfp = Nullfp; 247 } 248 249 /* Filters for program text */ 250 SvREFCNT_dec(rsfp_filters); 251 rsfp_filters = Nullav; 252 253 /* switches */ 254 preprocess = FALSE; 255 minus_n = FALSE; 256 minus_p = FALSE; 257 minus_l = FALSE; 258 minus_a = FALSE; 259 minus_F = FALSE; 260 doswitches = FALSE; 261 dowarn = FALSE; 262 doextract = FALSE; 263 sawampersand = FALSE; /* must save all match strings */ 264 sawstudy = FALSE; /* do fbm_instr on all strings */ 265 sawvec = FALSE; 266 unsafe = FALSE; 267 268 Safefree(inplace); 269 inplace = Nullch; 270 271 Safefree(e_tmpname); 272 e_tmpname = Nullch; 273 274 if (e_fp) { 275 PerlIO_close(e_fp); 276 e_fp = Nullfp; 277 } 278 279 /* magical thingies */ 280 281 Safefree(ofs); /* $, */ 282 ofs = Nullch; 283 284 Safefree(ors); /* $\ */ 285 ors = Nullch; 286 287 SvREFCNT_dec(nrs); /* $\ helper */ 288 nrs = Nullsv; 289 290 multiline = 0; /* $* */ 291 292 SvREFCNT_dec(statname); 293 statname = Nullsv; 294 statgv = Nullgv; 295 296 /* defgv, aka *_ should be taken care of elsewhere */ 297 298 #if 0 /* just about all regexp stuff, seems to be ok */ 299 300 /* shortcuts to regexp stuff */ 301 leftgv = Nullgv; 302 ampergv = Nullgv; 303 304 SAVEFREEOP(curpm); 305 SAVEFREEOP(oldlastpm); /* for saving regexp context during debugger */ 306 307 regprecomp = NULL; /* uncompiled string. */ 308 regparse = NULL; /* Input-scan pointer. */ 309 regxend = NULL; /* End of input for compile */ 310 regnpar = 0; /* () count. */ 311 regcode = NULL; /* Code-emit pointer; ®dummy = don't. */ 312 regsize = 0; /* Code size. */ 313 regnaughty = 0; /* How bad is this pattern? */ 314 regsawback = 0; /* Did we see \1, ...? */ 315 316 reginput = NULL; /* String-input pointer. */ 317 regbol = NULL; /* Beginning of input, for ^ check. */ 318 regeol = NULL; /* End of input, for $ check. */ 319 regstartp = (char **)NULL; /* Pointer to startp array. */ 320 regendp = (char **)NULL; /* Ditto for endp. */ 321 reglastparen = 0; /* Similarly for lastparen. */ 322 regtill = NULL; /* How far we are required to go. */ 323 regflags = 0; /* are we folding, multilining? */ 324 regprev = (char)NULL; /* char before regbol, \n if none */ 325 326 #endif /* if 0 */ 327 328 /* clean up after study() */ 329 SvREFCNT_dec(lastscream); 330 lastscream = Nullsv; 331 Safefree(screamfirst); 332 screamfirst = 0; 333 Safefree(screamnext); 334 screamnext = 0; 335 336 /* startup and shutdown function lists */ 337 SvREFCNT_dec(beginav); 338 SvREFCNT_dec(endav); 339 beginav = Nullav; 340 endav = Nullav; 341 342 /* temp stack during pp_sort() */ 343 SvREFCNT_dec(sortstack); 344 sortstack = Nullav; 345 346 /* shortcuts just get cleared */ 347 envgv = Nullgv; 348 siggv = Nullgv; 349 incgv = Nullgv; 350 errgv = Nullgv; 351 argvgv = Nullgv; 352 argvoutgv = Nullgv; 353 stdingv = Nullgv; 354 last_in_gv = Nullgv; 355 356 /* reset so print() ends up where we expect */ 357 setdefout(Nullgv); 358 359 /* Prepare to destruct main symbol table. */ 360 361 hv = defstash; 362 defstash = 0; 363 SvREFCNT_dec(hv); 364 365 FREETMPS; 366 if (destruct_level >= 2) { 367 if (scopestack_ix != 0) 368 warn("Unbalanced scopes: %ld more ENTERs than LEAVEs\n", 369 (long)scopestack_ix); 370 if (savestack_ix != 0) 371 warn("Unbalanced saves: %ld more saves than restores\n", 372 (long)savestack_ix); 373 if (tmps_floor != -1) 374 warn("Unbalanced tmps: %ld more allocs than frees\n", 375 (long)tmps_floor + 1); 376 if (cxstack_ix != -1) 377 warn("Unbalanced context: %ld more PUSHes than POPs\n", 378 (long)cxstack_ix + 1); 379 } 380 381 /* Now absolutely destruct everything, somehow or other, loops or no. */ 382 last_sv_count = 0; 383 SvFLAGS(strtab) |= SVTYPEMASK; /* don't clean out strtab now */ 384 while (sv_count != 0 && sv_count != last_sv_count) { 385 last_sv_count = sv_count; 386 sv_clean_all(); 387 } 388 SvFLAGS(strtab) &= ~SVTYPEMASK; 389 SvFLAGS(strtab) |= SVt_PVHV; 390 391 /* Destruct the global string table. */ 392 { 393 /* Yell and reset the HeVAL() slots that are still holding refcounts, 394 * so that sv_free() won't fail on them. 395 */ 396 I32 riter; 397 I32 max; 398 HE *hent; 399 HE **array; 400 401 riter = 0; 402 max = HvMAX(strtab); 403 array = HvARRAY(strtab); 404 hent = array[0]; 405 for (;;) { 406 if (hent) { 407 warn("Unbalanced string table refcount: (%d) for \"%s\"", 408 HeVAL(hent) - Nullsv, HeKEY(hent)); 409 HeVAL(hent) = Nullsv; 410 hent = HeNEXT(hent); 411 } 412 if (!hent) { 413 if (++riter > max) 414 break; 415 hent = array[riter]; 416 } 417 } 418 } 419 SvREFCNT_dec(strtab); 420 421 if (sv_count != 0) 422 warn("Scalars leaked: %ld\n", (long)sv_count); 423 424 sv_free_arenas(); 425 426 /* No SVs have survived, need to clean out */ 427 linestr = NULL; 428 pidstatus = Nullhv; 429 if (origfilename) 430 Safefree(origfilename); 431 nuke_stacks(); 432 hints = 0; /* Reset hints. Should hints be per-interpreter ? */ 433 434 DEBUG_P(debprofdump()); 435 436 /* As the absolutely last thing, free the non-arena SV for mess() */ 437 438 if (mess_sv) { 439 /* we know that type >= SVt_PV */ 440 SvOOK_off(mess_sv); 441 Safefree(SvPVX(mess_sv)); 442 Safefree(SvANY(mess_sv)); 443 Safefree(mess_sv); 444 mess_sv = Nullsv; 445 } 446 } 447 448 void 449 perl_free(sv_interp) 450 PerlInterpreter *sv_interp; 451 { 452 if (!(curinterp = sv_interp)) 453 return; 454 Safefree(sv_interp); 455 } 456 457 int 458 perl_parse(sv_interp, xsinit, argc, argv, env) 459 PerlInterpreter *sv_interp; 460 void (*xsinit)_((void)); 461 int argc; 462 char **argv; 463 char **env; 464 { 465 register SV *sv; 466 register char *s; 467 char *scriptname = NULL; 468 VOL bool dosearch = FALSE; 469 char *validarg = ""; 470 I32 oldscope; 471 AV* comppadlist; 472 dJMPENV; 473 int ret; 474 475 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW 476 #ifdef IAMSUID 477 #undef IAMSUID 478 croak("suidperl is no longer needed since the kernel can now execute\n\ 479 setuid perl scripts securely.\n"); 480 #endif 481 #endif 482 483 if (!(curinterp = sv_interp)) 484 return 255; 485 486 #if defined(NeXT) && defined(__DYNAMIC__) 487 _dyld_lookup_and_bind 488 ("__environ", (unsigned long *) &environ_pointer, NULL); 489 #endif /* environ */ 490 491 origargv = argv; 492 origargc = argc; 493 #ifndef VMS /* VMS doesn't have environ array */ 494 origenviron = environ; 495 #endif 496 e_tmpname = Nullch; 497 498 if (do_undump) { 499 500 /* Come here if running an undumped a.out. */ 501 502 origfilename = savepv(argv[0]); 503 do_undump = FALSE; 504 cxstack_ix = -1; /* start label stack again */ 505 init_ids(); 506 init_postdump_symbols(argc,argv,env); 507 return 0; 508 } 509 510 if (main_root) { 511 curpad = AvARRAY(comppad); 512 op_free(main_root); 513 main_root = Nullop; 514 } 515 main_start = Nullop; 516 SvREFCNT_dec(main_cv); 517 main_cv = Nullcv; 518 519 time(&basetime); 520 oldscope = scopestack_ix; 521 522 JMPENV_PUSH(ret); 523 switch (ret) { 524 case 1: 525 STATUS_ALL_FAILURE; 526 /* FALL THROUGH */ 527 case 2: 528 /* my_exit() was called */ 529 while (scopestack_ix > oldscope) 530 LEAVE; 531 FREETMPS; 532 curstash = defstash; 533 if (endav) 534 call_list(oldscope, endav); 535 JMPENV_POP; 536 return STATUS_NATIVE_EXPORT; 537 case 3: 538 JMPENV_POP; 539 PerlIO_printf(PerlIO_stderr(), "panic: top_env\n"); 540 return 1; 541 } 542 543 sv_setpvn(linestr,"",0); 544 sv = newSVpv("",0); /* first used for -I flags */ 545 SAVEFREESV(sv); 546 init_main_stash(); 547 548 for (argc--,argv++; argc > 0; argc--,argv++) { 549 if (argv[0][0] != '-' || !argv[0][1]) 550 break; 551 #ifdef DOSUID 552 if (*validarg) 553 validarg = " PHOOEY "; 554 else 555 validarg = argv[0]; 556 #endif 557 s = argv[0]+1; 558 reswitch: 559 switch (*s) { 560 case '0': 561 case 'F': 562 case 'a': 563 case 'c': 564 case 'd': 565 case 'D': 566 case 'h': 567 case 'i': 568 case 'l': 569 case 'M': 570 case 'm': 571 case 'n': 572 case 'p': 573 case 's': 574 case 'u': 575 case 'U': 576 case 'v': 577 case 'w': 578 if (s = moreswitches(s)) 579 goto reswitch; 580 break; 581 582 case 'T': 583 tainting = TRUE; 584 s++; 585 goto reswitch; 586 587 case 'e': 588 if (euid != uid || egid != gid) 589 croak("No -e allowed in setuid scripts"); 590 if (!e_fp) { 591 int fd; 592 593 e_tmpname = savepv(TMPPATH); 594 fd = mkstemp(e_tmpname); 595 if (fd == -1) 596 croak("Can't mkstemp()"); 597 e_fp = PerlIO_fdopen(fd,"w"); 598 if (!e_fp) { 599 (void)close(fd); 600 croak("Cannot open temporary file"); 601 } 602 } 603 if (*++s) 604 PerlIO_puts(e_fp,s); 605 else if (argv[1]) { 606 PerlIO_puts(e_fp,argv[1]); 607 argc--,argv++; 608 } 609 else 610 croak("No code specified for -e"); 611 (void)PerlIO_putc(e_fp,'\n'); 612 break; 613 case 'I': /* -I handled both here and in moreswitches() */ 614 forbid_setid("-I"); 615 if (!*++s && (s=argv[1]) != Nullch) { 616 argc--,argv++; 617 } 618 while (s && isSPACE(*s)) 619 ++s; 620 if (s && *s) { 621 char *e, *p; 622 for (e = s; *e && !isSPACE(*e); e++) ; 623 p = savepvn(s, e-s); 624 incpush(p, TRUE); 625 sv_catpv(sv,"-I"); 626 sv_catpv(sv,p); 627 sv_catpv(sv," "); 628 Safefree(p); 629 } /* XXX else croak? */ 630 break; 631 case 'P': 632 forbid_setid("-P"); 633 preprocess = TRUE; 634 s++; 635 goto reswitch; 636 case 'S': 637 forbid_setid("-S"); 638 dosearch = TRUE; 639 s++; 640 goto reswitch; 641 case 'V': 642 if (!preambleav) 643 preambleav = newAV(); 644 av_push(preambleav, newSVpv("use Config qw(myconfig config_vars)",0)); 645 if (*++s != ':') { 646 Sv = newSVpv("print myconfig();",0); 647 #ifdef VMS 648 sv_catpv(Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\","); 649 #else 650 sv_catpv(Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\","); 651 #endif 652 #if defined(DEBUGGING) || defined(NO_EMBED) || defined(MULTIPLICITY) 653 sv_catpv(Sv,"\" Compile-time options:"); 654 # ifdef DEBUGGING 655 sv_catpv(Sv," DEBUGGING"); 656 # endif 657 # ifdef NO_EMBED 658 sv_catpv(Sv," NO_EMBED"); 659 # endif 660 # ifdef MULTIPLICITY 661 sv_catpv(Sv," MULTIPLICITY"); 662 # endif 663 sv_catpv(Sv,"\\n\","); 664 #endif 665 #if defined(LOCAL_PATCH_COUNT) 666 if (LOCAL_PATCH_COUNT > 0) { 667 int i; 668 sv_catpv(Sv,"\" Locally applied patches:\\n\","); 669 for (i = 1; i <= LOCAL_PATCH_COUNT; i++) { 670 if (localpatches[i]) 671 sv_catpvf(Sv,"\" \\t%s\\n\",",localpatches[i]); 672 } 673 } 674 #endif 675 sv_catpvf(Sv,"\" Built under %s\\n\"",OSNAME); 676 #ifdef __DATE__ 677 # ifdef __TIME__ 678 sv_catpvf(Sv,",\" Compiled at %s %s\\n\"",__DATE__,__TIME__); 679 # else 680 sv_catpvf(Sv,",\" Compiled on %s\\n\"",__DATE__); 681 # endif 682 #endif 683 sv_catpv(Sv, "; \ 684 $\"=\"\\n \"; \ 685 @env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; \ 686 print \" \\%ENV:\\n @env\\n\" if @env; \ 687 print \" \\@INC:\\n @INC\\n\";"); 688 } 689 else { 690 Sv = newSVpv("config_vars(qw(",0); 691 sv_catpv(Sv, ++s); 692 sv_catpv(Sv, "))"); 693 s += strlen(s); 694 } 695 av_push(preambleav, Sv); 696 scriptname = BIT_BUCKET; /* don't look for script or read stdin */ 697 goto reswitch; 698 case 'x': 699 doextract = TRUE; 700 s++; 701 if (*s) 702 cddir = savepv(s); 703 break; 704 case 0: 705 break; 706 case '-': 707 if (!*++s || isSPACE(*s)) { 708 argc--,argv++; 709 goto switch_end; 710 } 711 /* catch use of gnu style long options */ 712 if (strEQ(s, "version")) { 713 s = "v"; 714 goto reswitch; 715 } 716 if (strEQ(s, "help")) { 717 s = "h"; 718 goto reswitch; 719 } 720 s--; 721 /* FALL THROUGH */ 722 default: 723 croak("Unrecognized switch: -%s (-h will show valid options)",s); 724 } 725 } 726 switch_end: 727 728 if (!tainting && (s = getenv("PERL5OPT"))) { 729 while (s && *s) { 730 while (isSPACE(*s)) 731 s++; 732 if (*s == '-') { 733 s++; 734 if (isSPACE(*s)) 735 continue; 736 } 737 if (!*s) 738 break; 739 if (!strchr("DIMUdmw", *s)) 740 croak("Illegal switch in PERL5OPT: -%c", *s); 741 s = moreswitches(s); 742 } 743 } 744 745 if (!scriptname) 746 scriptname = argv[0]; 747 if (e_fp) { 748 if (PerlIO_flush(e_fp) || PerlIO_error(e_fp) || PerlIO_close(e_fp)) { 749 #ifndef MULTIPLICITY 750 warn("Did you forget to compile with -DMULTIPLICITY?"); 751 #endif 752 croak("Can't write to temp file for -e: %s", Strerror(errno)); 753 } 754 e_fp = Nullfp; 755 argc++,argv--; 756 scriptname = e_tmpname; 757 } 758 else if (scriptname == Nullch) { 759 #ifdef MSDOS 760 if ( isatty(PerlIO_fileno(PerlIO_stdin())) ) 761 moreswitches("h"); 762 #endif 763 scriptname = "-"; 764 } 765 766 init_perllib(); 767 768 open_script(scriptname,dosearch,sv); 769 770 validate_suid(validarg, scriptname); 771 772 if (doextract) 773 find_beginning(); 774 775 main_cv = compcv = (CV*)NEWSV(1104,0); 776 sv_upgrade((SV *)compcv, SVt_PVCV); 777 CvUNIQUE_on(compcv); 778 779 comppad = newAV(); 780 av_push(comppad, Nullsv); 781 curpad = AvARRAY(comppad); 782 comppad_name = newAV(); 783 comppad_name_fill = 0; 784 min_intro_pending = 0; 785 padix = 0; 786 787 comppadlist = newAV(); 788 AvREAL_off(comppadlist); 789 av_store(comppadlist, 0, (SV*)comppad_name); 790 av_store(comppadlist, 1, (SV*)comppad); 791 CvPADLIST(compcv) = comppadlist; 792 793 boot_core_UNIVERSAL(); 794 if (xsinit) 795 (*xsinit)(); /* in case linked C routines want magical variables */ 796 #if defined(VMS) || defined(WIN32) 797 init_os_extras(); 798 #endif 799 800 init_predump_symbols(); 801 if (!do_undump) 802 init_postdump_symbols(argc,argv,env); 803 804 init_lexer(); 805 806 /* now parse the script */ 807 808 error_count = 0; 809 if (yyparse() || error_count) { 810 if (minus_c) 811 croak("%s had compilation errors.\n", origfilename); 812 else { 813 croak("Execution of %s aborted due to compilation errors.\n", 814 origfilename); 815 } 816 } 817 curcop->cop_line = 0; 818 curstash = defstash; 819 preprocess = FALSE; 820 if (e_tmpname) { 821 (void)UNLINK(e_tmpname); 822 Safefree(e_tmpname); 823 e_tmpname = Nullch; 824 } 825 826 /* now that script is parsed, we can modify record separator */ 827 SvREFCNT_dec(rs); 828 rs = SvREFCNT_inc(nrs); 829 sv_setsv(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), rs); 830 831 if (do_undump) 832 my_unexec(); 833 834 if (dowarn) 835 gv_check(defstash); 836 837 LEAVE; 838 FREETMPS; 839 840 #ifdef MYMALLOC 841 if ((s=getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2) 842 dump_mstats("after compilation:"); 843 #endif 844 845 ENTER; 846 restartop = 0; 847 JMPENV_POP; 848 return 0; 849 } 850 851 int 852 perl_run(sv_interp) 853 PerlInterpreter *sv_interp; 854 { 855 I32 oldscope; 856 dJMPENV; 857 int ret; 858 859 if (!(curinterp = sv_interp)) 860 return 255; 861 862 oldscope = scopestack_ix; 863 864 JMPENV_PUSH(ret); 865 switch (ret) { 866 case 1: 867 cxstack_ix = -1; /* start context stack again */ 868 break; 869 case 2: 870 /* my_exit() was called */ 871 while (scopestack_ix > oldscope) 872 LEAVE; 873 FREETMPS; 874 curstash = defstash; 875 if (endav) 876 call_list(oldscope, endav); 877 #ifdef MYMALLOC 878 if (getenv("PERL_DEBUG_MSTATS")) 879 dump_mstats("after execution: "); 880 #endif 881 JMPENV_POP; 882 return STATUS_NATIVE_EXPORT; 883 case 3: 884 if (!restartop) { 885 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n"); 886 FREETMPS; 887 JMPENV_POP; 888 return 1; 889 } 890 if (curstack != mainstack) { 891 dSP; 892 SWITCHSTACK(curstack, mainstack); 893 } 894 break; 895 } 896 897 DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n", 898 sawampersand ? "Enabling" : "Omitting")); 899 900 if (!restartop) { 901 DEBUG_x(dump_all()); 902 DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n")); 903 904 if (minus_c) { 905 PerlIO_printf(PerlIO_stderr(), "%s syntax OK\n", origfilename); 906 my_exit(0); 907 } 908 if (PERLDB_SINGLE && DBsingle) 909 sv_setiv(DBsingle, 1); 910 } 911 912 /* do it */ 913 914 if (restartop) { 915 op = restartop; 916 restartop = 0; 917 runops(); 918 } 919 else if (main_start) { 920 CvDEPTH(main_cv) = 1; 921 op = main_start; 922 runops(); 923 } 924 925 my_exit(0); 926 /* NOTREACHED */ 927 return 0; 928 } 929 930 SV* 931 perl_get_sv(name, create) 932 char* name; 933 I32 create; 934 { 935 GV* gv = gv_fetchpv(name, create, SVt_PV); 936 if (gv) 937 return GvSV(gv); 938 return Nullsv; 939 } 940 941 AV* 942 perl_get_av(name, create) 943 char* name; 944 I32 create; 945 { 946 GV* gv = gv_fetchpv(name, create, SVt_PVAV); 947 if (create) 948 return GvAVn(gv); 949 if (gv) 950 return GvAV(gv); 951 return Nullav; 952 } 953 954 HV* 955 perl_get_hv(name, create) 956 char* name; 957 I32 create; 958 { 959 GV* gv = gv_fetchpv(name, create, SVt_PVHV); 960 if (create) 961 return GvHVn(gv); 962 if (gv) 963 return GvHV(gv); 964 return Nullhv; 965 } 966 967 CV* 968 perl_get_cv(name, create) 969 char* name; 970 I32 create; 971 { 972 GV* gv = gv_fetchpv(name, create, SVt_PVCV); 973 if (create && !GvCVu(gv)) 974 return newSUB(start_subparse(FALSE, 0), 975 newSVOP(OP_CONST, 0, newSVpv(name,0)), 976 Nullop, 977 Nullop); 978 if (gv) 979 return GvCVu(gv); 980 return Nullcv; 981 } 982 983 /* Be sure to refetch the stack pointer after calling these routines. */ 984 985 I32 986 perl_call_argv(subname, flags, argv) 987 char *subname; 988 I32 flags; /* See G_* flags in cop.h */ 989 register char **argv; /* null terminated arg list */ 990 { 991 dSP; 992 993 PUSHMARK(sp); 994 if (argv) { 995 while (*argv) { 996 XPUSHs(sv_2mortal(newSVpv(*argv,0))); 997 argv++; 998 } 999 PUTBACK; 1000 } 1001 return perl_call_pv(subname, flags); 1002 } 1003 1004 I32 1005 perl_call_pv(subname, flags) 1006 char *subname; /* name of the subroutine */ 1007 I32 flags; /* See G_* flags in cop.h */ 1008 { 1009 return perl_call_sv((SV*)perl_get_cv(subname, TRUE), flags); 1010 } 1011 1012 I32 1013 perl_call_method(methname, flags) 1014 char *methname; /* name of the subroutine */ 1015 I32 flags; /* See G_* flags in cop.h */ 1016 { 1017 dSP; 1018 OP myop; 1019 if (!op) 1020 op = &myop; 1021 XPUSHs(sv_2mortal(newSVpv(methname,0))); 1022 PUTBACK; 1023 pp_method(); 1024 return perl_call_sv(*stack_sp--, flags); 1025 } 1026 1027 /* May be called with any of a CV, a GV, or an SV containing the name. */ 1028 I32 1029 perl_call_sv(sv, flags) 1030 SV* sv; 1031 I32 flags; /* See G_* flags in cop.h */ 1032 { 1033 LOGOP myop; /* fake syntax tree node */ 1034 SV** sp = stack_sp; 1035 I32 oldmark; 1036 I32 retval; 1037 I32 oldscope; 1038 static CV *DBcv; 1039 bool oldcatch = CATCH_GET; 1040 dJMPENV; 1041 int ret; 1042 OP* oldop = op; 1043 1044 if (flags & G_DISCARD) { 1045 ENTER; 1046 SAVETMPS; 1047 } 1048 1049 Zero(&myop, 1, LOGOP); 1050 myop.op_next = Nullop; 1051 if (!(flags & G_NOARGS)) 1052 myop.op_flags |= OPf_STACKED; 1053 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID : 1054 (flags & G_ARRAY) ? OPf_WANT_LIST : 1055 OPf_WANT_SCALAR); 1056 SAVESPTR(op); 1057 op = (OP*)&myop; 1058 1059 EXTEND(stack_sp, 1); 1060 *++stack_sp = sv; 1061 oldmark = TOPMARK; 1062 oldscope = scopestack_ix; 1063 1064 if (PERLDB_SUB && curstash != debstash 1065 /* Handle first BEGIN of -d. */ 1066 && (DBcv || (DBcv = GvCV(DBsub))) 1067 /* Try harder, since this may have been a sighandler, thus 1068 * curstash may be meaningless. */ 1069 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != debstash)) 1070 op->op_private |= OPpENTERSUB_DB; 1071 1072 if (flags & G_EVAL) { 1073 cLOGOP->op_other = op; 1074 markstack_ptr--; 1075 /* we're trying to emulate pp_entertry() here */ 1076 { 1077 register CONTEXT *cx; 1078 I32 gimme = GIMME_V; 1079 1080 ENTER; 1081 SAVETMPS; 1082 1083 push_return(op->op_next); 1084 PUSHBLOCK(cx, CXt_EVAL, stack_sp); 1085 PUSHEVAL(cx, 0, 0); 1086 eval_root = op; /* Only needed so that goto works right. */ 1087 1088 in_eval = 1; 1089 if (flags & G_KEEPERR) 1090 in_eval |= 4; 1091 else 1092 sv_setpv(GvSV(errgv),""); 1093 } 1094 markstack_ptr++; 1095 1096 JMPENV_PUSH(ret); 1097 switch (ret) { 1098 case 0: 1099 break; 1100 case 1: 1101 STATUS_ALL_FAILURE; 1102 /* FALL THROUGH */ 1103 case 2: 1104 /* my_exit() was called */ 1105 curstash = defstash; 1106 FREETMPS; 1107 JMPENV_POP; 1108 if (statusvalue) 1109 croak("Callback called exit"); 1110 my_exit_jump(); 1111 /* NOTREACHED */ 1112 case 3: 1113 if (restartop) { 1114 op = restartop; 1115 restartop = 0; 1116 break; 1117 } 1118 stack_sp = stack_base + oldmark; 1119 if (flags & G_ARRAY) 1120 retval = 0; 1121 else { 1122 retval = 1; 1123 *++stack_sp = &sv_undef; 1124 } 1125 goto cleanup; 1126 } 1127 } 1128 else 1129 CATCH_SET(TRUE); 1130 1131 if (op == (OP*)&myop) 1132 op = pp_entersub(); 1133 if (op) 1134 runops(); 1135 retval = stack_sp - (stack_base + oldmark); 1136 if ((flags & G_EVAL) && !(flags & G_KEEPERR)) 1137 sv_setpv(GvSV(errgv),""); 1138 1139 cleanup: 1140 if (flags & G_EVAL) { 1141 if (scopestack_ix > oldscope) { 1142 SV **newsp; 1143 PMOP *newpm; 1144 I32 gimme; 1145 register CONTEXT *cx; 1146 I32 optype; 1147 1148 POPBLOCK(cx,newpm); 1149 POPEVAL(cx); 1150 pop_return(); 1151 curpm = newpm; 1152 LEAVE; 1153 } 1154 JMPENV_POP; 1155 } 1156 else 1157 CATCH_SET(oldcatch); 1158 1159 if (flags & G_DISCARD) { 1160 stack_sp = stack_base + oldmark; 1161 retval = 0; 1162 FREETMPS; 1163 LEAVE; 1164 } 1165 op = oldop; 1166 return retval; 1167 } 1168 1169 /* Eval a string. The G_EVAL flag is always assumed. */ 1170 1171 I32 1172 perl_eval_sv(sv, flags) 1173 SV* sv; 1174 I32 flags; /* See G_* flags in cop.h */ 1175 { 1176 UNOP myop; /* fake syntax tree node */ 1177 SV** sp = stack_sp; 1178 I32 oldmark = sp - stack_base; 1179 I32 retval; 1180 I32 oldscope; 1181 dJMPENV; 1182 int ret; 1183 OP* oldop = op; 1184 1185 if (flags & G_DISCARD) { 1186 ENTER; 1187 SAVETMPS; 1188 } 1189 1190 SAVESPTR(op); 1191 op = (OP*)&myop; 1192 Zero(op, 1, UNOP); 1193 EXTEND(stack_sp, 1); 1194 *++stack_sp = sv; 1195 oldscope = scopestack_ix; 1196 1197 if (!(flags & G_NOARGS)) 1198 myop.op_flags = OPf_STACKED; 1199 myop.op_next = Nullop; 1200 myop.op_type = OP_ENTEREVAL; 1201 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID : 1202 (flags & G_ARRAY) ? OPf_WANT_LIST : 1203 OPf_WANT_SCALAR); 1204 if (flags & G_KEEPERR) 1205 myop.op_flags |= OPf_SPECIAL; 1206 1207 JMPENV_PUSH(ret); 1208 switch (ret) { 1209 case 0: 1210 break; 1211 case 1: 1212 STATUS_ALL_FAILURE; 1213 /* FALL THROUGH */ 1214 case 2: 1215 /* my_exit() was called */ 1216 curstash = defstash; 1217 FREETMPS; 1218 JMPENV_POP; 1219 if (statusvalue) 1220 croak("Callback called exit"); 1221 my_exit_jump(); 1222 /* NOTREACHED */ 1223 case 3: 1224 if (restartop) { 1225 op = restartop; 1226 restartop = 0; 1227 break; 1228 } 1229 stack_sp = stack_base + oldmark; 1230 if (flags & G_ARRAY) 1231 retval = 0; 1232 else { 1233 retval = 1; 1234 *++stack_sp = &sv_undef; 1235 } 1236 goto cleanup; 1237 } 1238 1239 if (op == (OP*)&myop) 1240 op = pp_entereval(); 1241 if (op) 1242 runops(); 1243 retval = stack_sp - (stack_base + oldmark); 1244 if (!(flags & G_KEEPERR)) 1245 sv_setpv(GvSV(errgv),""); 1246 1247 cleanup: 1248 JMPENV_POP; 1249 if (flags & G_DISCARD) { 1250 stack_sp = stack_base + oldmark; 1251 retval = 0; 1252 FREETMPS; 1253 LEAVE; 1254 } 1255 op = oldop; 1256 return retval; 1257 } 1258 1259 SV* 1260 perl_eval_pv(p, croak_on_error) 1261 char* p; 1262 I32 croak_on_error; 1263 { 1264 dSP; 1265 SV* sv = newSVpv(p, 0); 1266 1267 PUSHMARK(sp); 1268 perl_eval_sv(sv, G_SCALAR); 1269 SvREFCNT_dec(sv); 1270 1271 SPAGAIN; 1272 sv = POPs; 1273 PUTBACK; 1274 1275 if (croak_on_error && SvTRUE(GvSV(errgv))) 1276 croak(SvPVx(GvSV(errgv), na)); 1277 1278 return sv; 1279 } 1280 1281 /* Require a module. */ 1282 1283 void 1284 perl_require_pv(pv) 1285 char* pv; 1286 { 1287 SV* sv = sv_newmortal(); 1288 sv_setpv(sv, "require '"); 1289 sv_catpv(sv, pv); 1290 sv_catpv(sv, "'"); 1291 perl_eval_sv(sv, G_DISCARD); 1292 } 1293 1294 void 1295 magicname(sym,name,namlen) 1296 char *sym; 1297 char *name; 1298 I32 namlen; 1299 { 1300 register GV *gv; 1301 1302 if (gv = gv_fetchpv(sym,TRUE, SVt_PV)) 1303 sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen); 1304 } 1305 1306 static void 1307 usage(name) /* XXX move this out into a module ? */ 1308 char *name; 1309 { 1310 /* This message really ought to be max 23 lines. 1311 * Removed -h because the user already knows that opton. Others? */ 1312 1313 static char *usage[] = { 1314 "-0[octal] specify record separator (\\0, if no argument)", 1315 "-a autosplit mode with -n or -p (splits $_ into @F)", 1316 "-c check syntax only (runs BEGIN and END blocks)", 1317 "-d[:debugger] run scripts under debugger", 1318 "-D[number/list] set debugging flags (argument is a bit mask or flags)", 1319 "-e 'command' one line of script. Several -e's allowed. Omit [programfile].", 1320 "-F/pattern/ split() pattern for autosplit (-a). The //'s are optional.", 1321 "-i[extension] edit <> files in place (make backup if extension supplied)", 1322 "-Idirectory specify @INC/#include directory (may be used more than once)", 1323 "-l[octal] enable line ending processing, specifies line terminator", 1324 "-[mM][-]module.. executes `use/no module...' before executing your script.", 1325 "-n assume 'while (<>) { ... }' loop around your script", 1326 "-p assume loop like -n but print line also like sed", 1327 "-P run script through C preprocessor before compilation", 1328 "-s enable some switch parsing for switches after script name", 1329 "-S look for the script using PATH environment variable", 1330 "-T turn on tainting checks", 1331 "-u dump core after parsing script", 1332 "-U allow unsafe operations", 1333 "-v print version number and patchlevel of perl", 1334 "-V[:variable] print perl configuration information", 1335 "-w TURN WARNINGS ON FOR COMPILATION OF YOUR SCRIPT. Recommended.", 1336 "-x[directory] strip off text before #!perl line and perhaps cd to directory", 1337 "\n", 1338 NULL 1339 }; 1340 char **p = usage; 1341 1342 printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name); 1343 while (*p) 1344 printf("\n %s", *p++); 1345 } 1346 1347 /* This routine handles any switches that can be given during run */ 1348 1349 char * 1350 moreswitches(s) 1351 char *s; 1352 { 1353 I32 numlen; 1354 U32 rschar; 1355 1356 switch (*s) { 1357 case '0': 1358 rschar = scan_oct(s, 4, &numlen); 1359 SvREFCNT_dec(nrs); 1360 if (rschar & ~((U8)~0)) 1361 nrs = &sv_undef; 1362 else if (!rschar && numlen >= 2) 1363 nrs = newSVpv("", 0); 1364 else { 1365 char ch = rschar; 1366 nrs = newSVpv(&ch, 1); 1367 } 1368 return s + numlen; 1369 case 'F': 1370 minus_F = TRUE; 1371 splitstr = savepv(s + 1); 1372 s += strlen(s); 1373 return s; 1374 case 'a': 1375 minus_a = TRUE; 1376 s++; 1377 return s; 1378 case 'c': 1379 minus_c = TRUE; 1380 s++; 1381 return s; 1382 case 'd': 1383 forbid_setid("-d"); 1384 s++; 1385 if (*s == ':' || *s == '=') { 1386 my_setenv("PERL5DB", form("use Devel::%s;", ++s)); 1387 s += strlen(s); 1388 } 1389 if (!perldb) { 1390 perldb = PERLDB_ALL; 1391 init_debugger(); 1392 } 1393 return s; 1394 case 'D': 1395 #ifdef DEBUGGING 1396 forbid_setid("-D"); 1397 if (isALPHA(s[1])) { 1398 static char debopts[] = "psltocPmfrxuLHXD"; 1399 char *d; 1400 1401 for (s++; *s && (d = strchr(debopts,*s)); s++) 1402 debug |= 1 << (d - debopts); 1403 } 1404 else { 1405 debug = atoi(s+1); 1406 for (s++; isDIGIT(*s); s++) ; 1407 } 1408 debug |= 0x80000000; 1409 #else 1410 warn("Recompile perl with -DDEBUGGING to use -D switch\n"); 1411 for (s++; isALNUM(*s); s++) ; 1412 #endif 1413 /*SUPPRESS 530*/ 1414 return s; 1415 case 'h': 1416 usage(origargv[0]); 1417 exit(0); 1418 case 'i': 1419 if (inplace) 1420 Safefree(inplace); 1421 inplace = savepv(s+1); 1422 /*SUPPRESS 530*/ 1423 for (s = inplace; *s && !isSPACE(*s); s++) ; 1424 if (*s) 1425 *s++ = '\0'; 1426 return s; 1427 case 'I': /* -I handled both here and in parse_perl() */ 1428 forbid_setid("-I"); 1429 ++s; 1430 while (*s && isSPACE(*s)) 1431 ++s; 1432 if (*s) { 1433 char *e, *p; 1434 for (e = s; *e && !isSPACE(*e); e++) ; 1435 p = savepvn(s, e-s); 1436 incpush(p, TRUE); 1437 Safefree(p); 1438 s = e; 1439 } 1440 else 1441 croak("No space allowed after -I"); 1442 return s; 1443 case 'l': 1444 minus_l = TRUE; 1445 s++; 1446 if (ors) 1447 Safefree(ors); 1448 if (isDIGIT(*s)) { 1449 ors = savepv("\n"); 1450 orslen = 1; 1451 *ors = scan_oct(s, 3 + (*s == '0'), &numlen); 1452 s += numlen; 1453 } 1454 else { 1455 if (RsPARA(nrs)) { 1456 ors = "\n\n"; 1457 orslen = 2; 1458 } 1459 else 1460 ors = SvPV(nrs, orslen); 1461 ors = savepvn(ors, orslen); 1462 } 1463 return s; 1464 case 'M': 1465 forbid_setid("-M"); /* XXX ? */ 1466 /* FALL THROUGH */ 1467 case 'm': 1468 forbid_setid("-m"); /* XXX ? */ 1469 if (*++s) { 1470 char *start; 1471 char *use = "use "; 1472 /* -M-foo == 'no foo' */ 1473 if (*s == '-') { use = "no "; ++s; } 1474 Sv = newSVpv(use,0); 1475 start = s; 1476 /* We allow -M'Module qw(Foo Bar)' */ 1477 while(isALNUM(*s) || *s==':') ++s; 1478 if (*s != '=') { 1479 sv_catpv(Sv, start); 1480 if (*(start-1) == 'm') { 1481 if (*s != '\0') 1482 croak("Can't use '%c' after -mname", *s); 1483 sv_catpv( Sv, " ()"); 1484 } 1485 } else { 1486 sv_catpvn(Sv, start, s-start); 1487 sv_catpv(Sv, " split(/,/,q{"); 1488 sv_catpv(Sv, ++s); 1489 sv_catpv(Sv, "})"); 1490 } 1491 s += strlen(s); 1492 if (preambleav == NULL) 1493 preambleav = newAV(); 1494 av_push(preambleav, Sv); 1495 } 1496 else 1497 croak("No space allowed after -%c", *(s-1)); 1498 return s; 1499 case 'n': 1500 minus_n = TRUE; 1501 s++; 1502 return s; 1503 case 'p': 1504 minus_p = TRUE; 1505 s++; 1506 return s; 1507 case 's': 1508 forbid_setid("-s"); 1509 doswitches = TRUE; 1510 s++; 1511 return s; 1512 case 'T': 1513 if (!tainting) 1514 croak("Too late for \"-T\" option"); 1515 s++; 1516 return s; 1517 case 'u': 1518 do_undump = TRUE; 1519 s++; 1520 return s; 1521 case 'U': 1522 unsafe = TRUE; 1523 s++; 1524 return s; 1525 case 'v': 1526 #if defined(SUBVERSION) && SUBVERSION > 0 1527 printf("\nThis is perl, version 5.%03d_%02d built for %s", 1528 PATCHLEVEL, SUBVERSION, ARCHNAME); 1529 #else 1530 printf("\nThis is perl, version %s built for %s", 1531 patchlevel, ARCHNAME); 1532 #endif 1533 #if defined(LOCAL_PATCH_COUNT) 1534 if (LOCAL_PATCH_COUNT > 0) 1535 printf("\n(with %d registered patch%s, see perl -V for more detail)", 1536 LOCAL_PATCH_COUNT, (LOCAL_PATCH_COUNT!=1) ? "es" : ""); 1537 #endif 1538 1539 printf("\n\nCopyright 1987-1997, Larry Wall\n"); 1540 #ifdef MSDOS 1541 printf("\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n"); 1542 #endif 1543 #ifdef DJGPP 1544 printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n"); 1545 #endif 1546 #ifdef OS2 1547 printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n" 1548 "Version 5 port Copyright (c) 1994-1997, Andreas Kaiser, Ilya Zakharevich\n"); 1549 #endif 1550 #ifdef atarist 1551 printf("atariST series port, ++jrb bammi@cadence.com\n"); 1552 #endif 1553 printf("\n\ 1554 Perl may be copied only under the terms of either the Artistic License or the\n\ 1555 GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n"); 1556 exit(0); 1557 case 'w': 1558 dowarn = TRUE; 1559 s++; 1560 return s; 1561 case '*': 1562 case ' ': 1563 if (s[1] == '-') /* Additional switches on #! line. */ 1564 return s+2; 1565 break; 1566 case '-': 1567 case 0: 1568 case '\n': 1569 case '\t': 1570 break; 1571 #ifdef ALTERNATE_SHEBANG 1572 case 'S': /* OS/2 needs -S on "extproc" line. */ 1573 break; 1574 #endif 1575 case 'P': 1576 if (preprocess) 1577 return s+1; 1578 /* FALL THROUGH */ 1579 default: 1580 croak("Can't emulate -%.1s on #! line",s); 1581 } 1582 return Nullch; 1583 } 1584 1585 /* compliments of Tom Christiansen */ 1586 1587 /* unexec() can be found in the Gnu emacs distribution */ 1588 1589 void 1590 my_unexec() 1591 { 1592 #ifdef UNEXEC 1593 SV* prog; 1594 SV* file; 1595 int status; 1596 extern int etext; 1597 1598 prog = newSVpv(BIN_EXP); 1599 sv_catpv(prog, "/perl"); 1600 file = newSVpv(origfilename); 1601 sv_catpv(file, ".perldump"); 1602 1603 status = unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0); 1604 if (status) 1605 PerlIO_printf(PerlIO_stderr(), "unexec of %s into %s failed!\n", 1606 SvPVX(prog), SvPVX(file)); 1607 exit(status); 1608 #else 1609 # ifdef VMS 1610 # include <lib$routines.h> 1611 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */ 1612 # else 1613 ABORT(); /* for use with undump */ 1614 # endif 1615 #endif 1616 } 1617 1618 static void 1619 init_main_stash() 1620 { 1621 GV *gv; 1622 1623 /* Note that strtab is a rather special HV. Assumptions are made 1624 about not iterating on it, and not adding tie magic to it. 1625 It is properly deallocated in perl_destruct() */ 1626 strtab = newHV(); 1627 HvSHAREKEYS_off(strtab); /* mandatory */ 1628 Newz(506,((XPVHV*)SvANY(strtab))->xhv_array, 1629 sizeof(HE*) * (((XPVHV*)SvANY(strtab))->xhv_max + 1), char); 1630 1631 curstash = defstash = newHV(); 1632 curstname = newSVpv("main",4); 1633 gv = gv_fetchpv("main::",TRUE, SVt_PVHV); 1634 SvREFCNT_dec(GvHV(gv)); 1635 GvHV(gv) = (HV*)SvREFCNT_inc(defstash); 1636 SvREADONLY_on(gv); 1637 HvNAME(defstash) = savepv("main"); 1638 incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV))); 1639 GvMULTI_on(incgv); 1640 defgv = gv_fetchpv("_",TRUE, SVt_PVAV); 1641 errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV)); 1642 GvMULTI_on(errgv); 1643 (void)form("%240s",""); /* Preallocate temp - for immediate signals. */ 1644 sv_grow(GvSV(errgv), 240); /* Preallocate - for immediate signals. */ 1645 sv_setpvn(GvSV(errgv), "", 0); 1646 curstash = defstash; 1647 compiling.cop_stash = defstash; 1648 debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV)); 1649 /* We must init $/ before switches are processed. */ 1650 sv_setpvn(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), "\n", 1); 1651 } 1652 1653 #ifdef CAN_PROTOTYPE 1654 static void 1655 open_script(char *scriptname, bool dosearch, SV *sv) 1656 #else 1657 static void 1658 open_script(scriptname,dosearch,sv) 1659 char *scriptname; 1660 bool dosearch; 1661 SV *sv; 1662 #endif 1663 { 1664 char *xfound = Nullch; 1665 char *xfailed = Nullch; 1666 register char *s; 1667 I32 len; 1668 int retval; 1669 #if defined(DOSISH) && !defined(OS2) && !defined(atarist) 1670 # define SEARCH_EXTS ".bat", ".cmd", NULL 1671 # define MAX_EXT_LEN 4 1672 #endif 1673 #ifdef OS2 1674 # define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL 1675 # define MAX_EXT_LEN 4 1676 #endif 1677 #ifdef VMS 1678 # define SEARCH_EXTS ".pl", ".com", NULL 1679 # define MAX_EXT_LEN 4 1680 #endif 1681 /* additional extensions to try in each dir if scriptname not found */ 1682 #ifdef SEARCH_EXTS 1683 char *ext[] = { SEARCH_EXTS }; 1684 int extidx = 0, i = 0; 1685 char *curext = Nullch; 1686 #else 1687 # define MAX_EXT_LEN 0 1688 #endif 1689 1690 /* 1691 * If dosearch is true and if scriptname does not contain path 1692 * delimiters, search the PATH for scriptname. 1693 * 1694 * If SEARCH_EXTS is also defined, will look for each 1695 * scriptname{SEARCH_EXTS} whenever scriptname is not found 1696 * while searching the PATH. 1697 * 1698 * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search 1699 * proceeds as follows: 1700 * If DOSISH: 1701 * + look for ./scriptname{,.foo,.bar} 1702 * + search the PATH for scriptname{,.foo,.bar} 1703 * 1704 * If !DOSISH: 1705 * + look *only* in the PATH for scriptname{,.foo,.bar} (note 1706 * this will not look in '.' if it's not in the PATH) 1707 */ 1708 1709 #ifdef VMS 1710 if (dosearch) { 1711 int hasdir, idx = 0, deftypes = 1; 1712 bool seen_dot = 1; 1713 1714 hasdir = (strpbrk(scriptname,":[</") != Nullch) ; 1715 /* The first time through, just add SEARCH_EXTS to whatever we 1716 * already have, so we can check for default file types. */ 1717 while (deftypes || 1718 (!hasdir && my_trnlnm("DCL$PATH",tokenbuf,idx++)) ) 1719 { 1720 if (deftypes) { 1721 deftypes = 0; 1722 *tokenbuf = '\0'; 1723 } 1724 if ((strlen(tokenbuf) + strlen(scriptname) 1725 + MAX_EXT_LEN) >= sizeof tokenbuf) 1726 continue; /* don't search dir with too-long name */ 1727 strcat(tokenbuf, scriptname); 1728 #else /* !VMS */ 1729 1730 #ifdef DOSISH 1731 if (strEQ(scriptname, "-")) 1732 dosearch = 0; 1733 if (dosearch) { /* Look in '.' first. */ 1734 char *cur = scriptname; 1735 #ifdef SEARCH_EXTS 1736 if ((curext = strrchr(scriptname,'.'))) /* possible current ext */ 1737 while (ext[i]) 1738 if (strEQ(ext[i++],curext)) { 1739 extidx = -1; /* already has an ext */ 1740 break; 1741 } 1742 do { 1743 #endif 1744 DEBUG_p(PerlIO_printf(Perl_debug_log, 1745 "Looking for %s\n",cur)); 1746 if (Stat(cur,&statbuf) >= 0) { 1747 dosearch = 0; 1748 scriptname = cur; 1749 #ifdef SEARCH_EXTS 1750 break; 1751 #endif 1752 } 1753 #ifdef SEARCH_EXTS 1754 if (cur == scriptname) { 1755 len = strlen(scriptname); 1756 if (len+MAX_EXT_LEN+1 >= sizeof(tokenbuf)) 1757 break; 1758 cur = strcpy(tokenbuf, scriptname); 1759 } 1760 } while (extidx >= 0 && ext[extidx] /* try an extension? */ 1761 && strcpy(tokenbuf+len, ext[extidx++])); 1762 #endif 1763 } 1764 #endif 1765 1766 if (dosearch && !strchr(scriptname, '/') 1767 #ifdef DOSISH 1768 && !strchr(scriptname, '\\') 1769 #endif 1770 && (s = getenv("PATH"))) { 1771 bool seen_dot = 0; 1772 1773 bufend = s + strlen(s); 1774 while (s < bufend) { 1775 #if defined(atarist) || defined(DOSISH) 1776 for (len = 0; *s 1777 # ifdef atarist 1778 && *s != ',' 1779 # endif 1780 && *s != ';'; len++, s++) { 1781 if (len < sizeof tokenbuf) 1782 tokenbuf[len] = *s; 1783 } 1784 if (len < sizeof tokenbuf) 1785 tokenbuf[len] = '\0'; 1786 #else /* ! (atarist || DOSISH) */ 1787 s = delimcpy(tokenbuf, tokenbuf + sizeof tokenbuf, s, bufend, 1788 ':', 1789 &len); 1790 #endif /* ! (atarist || DOSISH) */ 1791 if (s < bufend) 1792 s++; 1793 if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tokenbuf) 1794 continue; /* don't search dir with too-long name */ 1795 if (len 1796 #if defined(atarist) || defined(DOSISH) 1797 && tokenbuf[len - 1] != '/' 1798 && tokenbuf[len - 1] != '\\' 1799 #endif 1800 ) 1801 tokenbuf[len++] = '/'; 1802 if (len == 2 && tokenbuf[0] == '.') 1803 seen_dot = 1; 1804 (void)strcpy(tokenbuf + len, scriptname); 1805 #endif /* !VMS */ 1806 1807 #ifdef SEARCH_EXTS 1808 len = strlen(tokenbuf); 1809 if (extidx > 0) /* reset after previous loop */ 1810 extidx = 0; 1811 do { 1812 #endif 1813 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tokenbuf)); 1814 retval = Stat(tokenbuf,&statbuf); 1815 #ifdef SEARCH_EXTS 1816 } while ( retval < 0 /* not there */ 1817 && extidx>=0 && ext[extidx] /* try an extension? */ 1818 && strcpy(tokenbuf+len, ext[extidx++]) 1819 ); 1820 #endif 1821 if (retval < 0) 1822 continue; 1823 if (S_ISREG(statbuf.st_mode) 1824 && cando(S_IRUSR,TRUE,&statbuf) 1825 #ifndef DOSISH 1826 && cando(S_IXUSR,TRUE,&statbuf) 1827 #endif 1828 ) 1829 { 1830 xfound = tokenbuf; /* bingo! */ 1831 break; 1832 } 1833 if (!xfailed) 1834 xfailed = savepv(tokenbuf); 1835 } 1836 #ifndef DOSISH 1837 if (!xfound && !seen_dot && !xfailed && (Stat(scriptname,&statbuf) < 0)) 1838 #endif 1839 seen_dot = 1; /* Disable message. */ 1840 if (!xfound) 1841 croak("Can't %s %s%s%s", 1842 (xfailed ? "execute" : "find"), 1843 (xfailed ? xfailed : scriptname), 1844 (xfailed ? "" : " on PATH"), 1845 (xfailed || seen_dot) ? "" : ", '.' not in PATH"); 1846 if (xfailed) 1847 Safefree(xfailed); 1848 scriptname = xfound; 1849 } 1850 1851 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) { 1852 char *s = scriptname + 8; 1853 fdscript = atoi(s); 1854 while (isDIGIT(*s)) 1855 s++; 1856 if (*s) 1857 scriptname = s + 1; 1858 } 1859 else 1860 fdscript = -1; 1861 origfilename = savepv(e_tmpname ? "-e" : scriptname); 1862 curcop->cop_filegv = gv_fetchfile(origfilename); 1863 if (strEQ(origfilename,"-")) 1864 scriptname = ""; 1865 if (fdscript >= 0) { 1866 rsfp = PerlIO_fdopen(fdscript,"r"); 1867 #if defined(HAS_FCNTL) && defined(F_SETFD) 1868 if (rsfp) 1869 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */ 1870 #endif 1871 } 1872 else if (preprocess) { 1873 char *cpp_cfg = CPPSTDIN; 1874 SV *cpp = NEWSV(0,0); 1875 SV *cmd = NEWSV(0,0); 1876 1877 if (strEQ(cpp_cfg, "cppstdin")) 1878 sv_catpvf(cpp, "%s/", BIN_EXP); 1879 sv_catpv(cpp, cpp_cfg); 1880 1881 sv_catpv(sv,"-I"); 1882 sv_catpv(sv,PRIVLIB_EXP); 1883 1884 #ifdef MSDOS 1885 sv_setpvf(cmd, "\ 1886 sed %s -e \"/^[^#]/b\" \ 1887 -e \"/^#[ ]*include[ ]/b\" \ 1888 -e \"/^#[ ]*define[ ]/b\" \ 1889 -e \"/^#[ ]*if[ ]/b\" \ 1890 -e \"/^#[ ]*ifdef[ ]/b\" \ 1891 -e \"/^#[ ]*ifndef[ ]/b\" \ 1892 -e \"/^#[ ]*else/b\" \ 1893 -e \"/^#[ ]*elif[ ]/b\" \ 1894 -e \"/^#[ ]*undef[ ]/b\" \ 1895 -e \"/^#[ ]*endif/b\" \ 1896 -e \"s/^#.*//\" \ 1897 %s | %_ -C %_ %s", 1898 (doextract ? "-e \"1,/^#/d\n\"" : ""), 1899 #else 1900 sv_setpvf(cmd, "\ 1901 %s %s -e '/^[^#]/b' \ 1902 -e '/^#[ ]*include[ ]/b' \ 1903 -e '/^#[ ]*define[ ]/b' \ 1904 -e '/^#[ ]*if[ ]/b' \ 1905 -e '/^#[ ]*ifdef[ ]/b' \ 1906 -e '/^#[ ]*ifndef[ ]/b' \ 1907 -e '/^#[ ]*else/b' \ 1908 -e '/^#[ ]*elif[ ]/b' \ 1909 -e '/^#[ ]*undef[ ]/b' \ 1910 -e '/^#[ ]*endif/b' \ 1911 -e 's/^[ ]*#.*//' \ 1912 %s | %_ -C %_ %s", 1913 #ifdef LOC_SED 1914 LOC_SED, 1915 #else 1916 "sed", 1917 #endif 1918 (doextract ? "-e '1,/^#/d\n'" : ""), 1919 #endif 1920 scriptname, cpp, sv, CPPMINUS); 1921 doextract = FALSE; 1922 #ifdef IAMSUID /* actually, this is caught earlier */ 1923 if (euid != uid && !euid) { /* if running suidperl */ 1924 #ifdef HAS_SETEUID 1925 (void)seteuid(uid); /* musn't stay setuid root */ 1926 #else 1927 #ifdef HAS_SETREUID 1928 (void)setreuid((Uid_t)-1, uid); 1929 #else 1930 #ifdef HAS_SETRESUID 1931 (void)setresuid((Uid_t)-1, uid, (Uid_t)-1); 1932 #else 1933 setuid(uid); 1934 #endif 1935 #endif 1936 #endif 1937 if (geteuid() != uid) 1938 croak("Can't do seteuid!\n"); 1939 } 1940 #endif /* IAMSUID */ 1941 rsfp = my_popen(SvPVX(cmd), "r"); 1942 SvREFCNT_dec(cmd); 1943 SvREFCNT_dec(cpp); 1944 } 1945 else if (!*scriptname) { 1946 forbid_setid("program input from stdin"); 1947 rsfp = PerlIO_stdin(); 1948 } 1949 else { 1950 rsfp = PerlIO_open(scriptname,"r"); 1951 #if defined(HAS_FCNTL) && defined(F_SETFD) 1952 if (rsfp) 1953 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */ 1954 #endif 1955 } 1956 if (e_tmpname) { 1957 e_fp = rsfp; 1958 } 1959 if (!rsfp) { 1960 #ifdef DOSUID 1961 #ifndef IAMSUID /* in case script is not readable before setuid */ 1962 if (euid && Stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 && 1963 statbuf.st_mode & (S_ISUID|S_ISGID)) { 1964 /* try again */ 1965 execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv); 1966 croak("Can't do setuid\n"); 1967 } 1968 #endif 1969 #endif 1970 croak("Can't open perl script \"%s\": %s\n", 1971 SvPVX(GvSV(curcop->cop_filegv)), Strerror(errno)); 1972 } 1973 } 1974 1975 static void 1976 validate_suid(validarg, scriptname) 1977 char *validarg; 1978 char *scriptname; 1979 { 1980 int which; 1981 1982 /* do we need to emulate setuid on scripts? */ 1983 1984 /* This code is for those BSD systems that have setuid #! scripts disabled 1985 * in the kernel because of a security problem. Merely defining DOSUID 1986 * in perl will not fix that problem, but if you have disabled setuid 1987 * scripts in the kernel, this will attempt to emulate setuid and setgid 1988 * on scripts that have those now-otherwise-useless bits set. The setuid 1989 * root version must be called suidperl or sperlN.NNN. If regular perl 1990 * discovers that it has opened a setuid script, it calls suidperl with 1991 * the same argv that it had. If suidperl finds that the script it has 1992 * just opened is NOT setuid root, it sets the effective uid back to the 1993 * uid. We don't just make perl setuid root because that loses the 1994 * effective uid we had before invoking perl, if it was different from the 1995 * uid. 1996 * 1997 * DOSUID must be defined in both perl and suidperl, and IAMSUID must 1998 * be defined in suidperl only. suidperl must be setuid root. The 1999 * Configure script will set this up for you if you want it. 2000 */ 2001 2002 #ifdef DOSUID 2003 char *s, *s2; 2004 2005 if (Fstat(PerlIO_fileno(rsfp),&statbuf) < 0) /* normal stat is insecure */ 2006 croak("Can't stat script \"%s\"",origfilename); 2007 if (fdscript < 0 && statbuf.st_mode & (S_ISUID|S_ISGID)) { 2008 I32 len; 2009 2010 #ifdef IAMSUID 2011 #ifndef HAS_SETREUID 2012 /* On this access check to make sure the directories are readable, 2013 * there is actually a small window that the user could use to make 2014 * filename point to an accessible directory. So there is a faint 2015 * chance that someone could execute a setuid script down in a 2016 * non-accessible directory. I don't know what to do about that. 2017 * But I don't think it's too important. The manual lies when 2018 * it says access() is useful in setuid programs. 2019 */ 2020 if (access(SvPVX(GvSV(curcop->cop_filegv)),1)) /*double check*/ 2021 croak("Permission denied"); 2022 #else 2023 /* If we can swap euid and uid, then we can determine access rights 2024 * with a simple stat of the file, and then compare device and 2025 * inode to make sure we did stat() on the same file we opened. 2026 * Then we just have to make sure he or she can execute it. 2027 */ 2028 { 2029 struct stat tmpstatbuf; 2030 2031 if ( 2032 #ifdef HAS_SETREUID 2033 setreuid(euid,uid) < 0 2034 #else 2035 # if HAS_SETRESUID 2036 setresuid(euid,uid,(Uid_t)-1) < 0 2037 # endif 2038 #endif 2039 || getuid() != euid || geteuid() != uid) 2040 croak("Can't swap uid and euid"); /* really paranoid */ 2041 if (Stat(SvPVX(GvSV(curcop->cop_filegv)),&tmpstatbuf) < 0) 2042 croak("Permission denied"); /* testing full pathname here */ 2043 if (tmpstatbuf.st_dev != statbuf.st_dev || 2044 tmpstatbuf.st_ino != statbuf.st_ino) { 2045 (void)PerlIO_close(rsfp); 2046 if (rsfp = my_popen("/bin/mail root","w")) { /* heh, heh */ 2047 PerlIO_printf(rsfp, 2048 "User %ld tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\ 2049 (Filename of set-id script was %s, uid %ld gid %ld.)\n\nSincerely,\nperl\n", 2050 (long)uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino, 2051 (long)statbuf.st_dev, (long)statbuf.st_ino, 2052 SvPVX(GvSV(curcop->cop_filegv)), 2053 (long)statbuf.st_uid, (long)statbuf.st_gid); 2054 (void)my_pclose(rsfp); 2055 } 2056 croak("Permission denied\n"); 2057 } 2058 if ( 2059 #ifdef HAS_SETREUID 2060 setreuid(uid,euid) < 0 2061 #else 2062 # if defined(HAS_SETRESUID) 2063 setresuid(uid,euid,(Uid_t)-1) < 0 2064 # endif 2065 #endif 2066 || getuid() != uid || geteuid() != euid) 2067 croak("Can't reswap uid and euid"); 2068 if (!cando(S_IXUSR,FALSE,&statbuf)) /* can real uid exec? */ 2069 croak("Permission denied\n"); 2070 } 2071 #endif /* HAS_SETREUID */ 2072 #endif /* IAMSUID */ 2073 2074 if (!S_ISREG(statbuf.st_mode)) 2075 croak("Permission denied"); 2076 if (statbuf.st_mode & S_IWOTH) 2077 croak("Setuid/gid script is writable by world"); 2078 doswitches = FALSE; /* -s is insecure in suid */ 2079 curcop->cop_line++; 2080 if (sv_gets(linestr, rsfp, 0) == Nullch || 2081 strnNE(SvPV(linestr,na),"#!",2) ) /* required even on Sys V */ 2082 croak("No #! line"); 2083 s = SvPV(linestr,na)+2; 2084 if (*s == ' ') s++; 2085 while (!isSPACE(*s)) s++; 2086 for (s2 = s; (s2 > SvPV(linestr,na)+2 && 2087 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ; 2088 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */ 2089 croak("Not a perl script"); 2090 while (*s == ' ' || *s == '\t') s++; 2091 /* 2092 * #! arg must be what we saw above. They can invoke it by 2093 * mentioning suidperl explicitly, but they may not add any strange 2094 * arguments beyond what #! says if they do invoke suidperl that way. 2095 */ 2096 len = strlen(validarg); 2097 if (strEQ(validarg," PHOOEY ") || 2098 strnNE(s,validarg,len) || !isSPACE(s[len])) 2099 croak("Args must match #! line"); 2100 2101 #ifndef IAMSUID 2102 if (euid != uid && (statbuf.st_mode & S_ISUID) && 2103 euid == statbuf.st_uid) 2104 if (!do_undump) 2105 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\ 2106 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n"); 2107 #endif /* IAMSUID */ 2108 2109 if (euid) { /* oops, we're not the setuid root perl */ 2110 (void)PerlIO_close(rsfp); 2111 #ifndef IAMSUID 2112 /* try again */ 2113 execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv); 2114 #endif 2115 croak("Can't do setuid\n"); 2116 } 2117 2118 if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid) { 2119 #ifdef HAS_SETEGID 2120 (void)setegid(statbuf.st_gid); 2121 #else 2122 #ifdef HAS_SETREGID 2123 (void)setregid((Gid_t)-1,statbuf.st_gid); 2124 #else 2125 #ifdef HAS_SETRESGID 2126 (void)setresgid((Gid_t)-1,statbuf.st_gid,(Gid_t)-1); 2127 #else 2128 setgid(statbuf.st_gid); 2129 #endif 2130 #endif 2131 #endif 2132 if (getegid() != statbuf.st_gid) 2133 croak("Can't do setegid!\n"); 2134 } 2135 if (statbuf.st_mode & S_ISUID) { 2136 if (statbuf.st_uid != euid) 2137 #ifdef HAS_SETEUID 2138 (void)seteuid(statbuf.st_uid); /* all that for this */ 2139 #else 2140 #ifdef HAS_SETREUID 2141 (void)setreuid((Uid_t)-1,statbuf.st_uid); 2142 #else 2143 #ifdef HAS_SETRESUID 2144 (void)setresuid((Uid_t)-1,statbuf.st_uid,(Uid_t)-1); 2145 #else 2146 setuid(statbuf.st_uid); 2147 #endif 2148 #endif 2149 #endif 2150 if (geteuid() != statbuf.st_uid) 2151 croak("Can't do seteuid!\n"); 2152 } 2153 else if (uid) { /* oops, mustn't run as root */ 2154 #ifdef HAS_SETEUID 2155 (void)seteuid((Uid_t)uid); 2156 #else 2157 #ifdef HAS_SETREUID 2158 (void)setreuid((Uid_t)-1,(Uid_t)uid); 2159 #else 2160 #ifdef HAS_SETRESUID 2161 (void)setresuid((Uid_t)-1,(Uid_t)uid,(Uid_t)-1); 2162 #else 2163 setuid((Uid_t)uid); 2164 #endif 2165 #endif 2166 #endif 2167 if (geteuid() != uid) 2168 croak("Can't do seteuid!\n"); 2169 } 2170 init_ids(); 2171 if (!cando(S_IXUSR,TRUE,&statbuf)) 2172 croak("Permission denied\n"); /* they can't do this */ 2173 } 2174 #ifdef IAMSUID 2175 else if (preprocess) 2176 croak("-P not allowed for setuid/setgid script\n"); 2177 else if (fdscript >= 0) 2178 croak("fd script not allowed in suidperl\n"); 2179 else 2180 croak("Script is not setuid/setgid in suidperl\n"); 2181 2182 /* We absolutely must clear out any saved ids here, so we */ 2183 /* exec the real perl, substituting fd script for scriptname. */ 2184 /* (We pass script name as "subdir" of fd, which perl will grok.) */ 2185 PerlIO_rewind(rsfp); 2186 lseek(PerlIO_fileno(rsfp),(Off_t)0,0); /* just in case rewind didn't */ 2187 for (which = 1; origargv[which] && origargv[which] != scriptname; which++) ; 2188 if (!origargv[which]) 2189 croak("Permission denied"); 2190 origargv[which] = savepv(form("/dev/fd/%d/%s", 2191 PerlIO_fileno(rsfp), origargv[which])); 2192 #if defined(HAS_FCNTL) && defined(F_SETFD) 2193 fcntl(PerlIO_fileno(rsfp),F_SETFD,0); /* ensure no close-on-exec */ 2194 #endif 2195 execv(form("%s/perl%s", BIN_EXP, patchlevel), origargv); /* try again */ 2196 croak("Can't do setuid\n"); 2197 #endif /* IAMSUID */ 2198 #else /* !DOSUID */ 2199 if (euid != uid || egid != gid) { /* (suidperl doesn't exist, in fact) */ 2200 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW 2201 Fstat(PerlIO_fileno(rsfp),&statbuf); /* may be either wrapped or real suid */ 2202 if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID) 2203 || 2204 (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID) 2205 ) 2206 if (!do_undump) 2207 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\ 2208 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n"); 2209 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */ 2210 /* not set-id, must be wrapped */ 2211 } 2212 #endif /* DOSUID */ 2213 } 2214 2215 static void 2216 find_beginning() 2217 { 2218 register char *s, *s2; 2219 2220 /* skip forward in input to the real script? */ 2221 2222 forbid_setid("-x"); 2223 while (doextract) { 2224 if ((s = sv_gets(linestr, rsfp, 0)) == Nullch) 2225 croak("No Perl script found in input\n"); 2226 if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) { 2227 PerlIO_ungetc(rsfp, '\n'); /* to keep line count right */ 2228 doextract = FALSE; 2229 while (*s && !(isSPACE (*s) || *s == '#')) s++; 2230 s2 = s; 2231 while (*s == ' ' || *s == '\t') s++; 2232 if (*s++ == '-') { 2233 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--; 2234 if (strnEQ(s2-4,"perl",4)) 2235 /*SUPPRESS 530*/ 2236 while (s = moreswitches(s)) ; 2237 } 2238 if (cddir && chdir(cddir) < 0) 2239 croak("Can't chdir to %s",cddir); 2240 } 2241 } 2242 } 2243 2244 static void 2245 init_ids() 2246 { 2247 uid = (int)getuid(); 2248 euid = (int)geteuid(); 2249 gid = (int)getgid(); 2250 egid = (int)getegid(); 2251 #ifdef VMS 2252 uid |= gid << 16; 2253 euid |= egid << 16; 2254 #endif 2255 tainting |= (uid && (euid != uid || egid != gid)); 2256 } 2257 2258 static void 2259 forbid_setid(s) 2260 char *s; 2261 { 2262 if (euid != uid) 2263 croak("No %s allowed while running setuid", s); 2264 if (egid != gid) 2265 croak("No %s allowed while running setgid", s); 2266 } 2267 2268 static void 2269 init_debugger() 2270 { 2271 curstash = debstash; 2272 dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV)))); 2273 AvREAL_off(dbargs); 2274 DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV); 2275 DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV); 2276 DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV)); 2277 DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV))); 2278 sv_setiv(DBsingle, 0); 2279 DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV))); 2280 sv_setiv(DBtrace, 0); 2281 DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV))); 2282 sv_setiv(DBsignal, 0); 2283 curstash = defstash; 2284 } 2285 2286 static void 2287 init_stacks() 2288 { 2289 curstack = newAV(); 2290 mainstack = curstack; /* remember in case we switch stacks */ 2291 AvREAL_off(curstack); /* not a real array */ 2292 av_extend(curstack,127); 2293 2294 stack_base = AvARRAY(curstack); 2295 stack_sp = stack_base; 2296 stack_max = stack_base + 127; 2297 2298 cxstack_max = 8192 / sizeof(CONTEXT) - 2; /* Use most of 8K. */ 2299 New(50,cxstack,cxstack_max + 1,CONTEXT); 2300 cxstack_ix = -1; 2301 2302 New(50,tmps_stack,128,SV*); 2303 tmps_ix = -1; 2304 tmps_max = 128; 2305 2306 DEBUG( { 2307 New(51,debname,128,char); 2308 New(52,debdelim,128,char); 2309 } ) 2310 2311 /* 2312 * The following stacks almost certainly should be per-interpreter, 2313 * but for now they're not. XXX 2314 */ 2315 2316 if (markstack) { 2317 markstack_ptr = markstack; 2318 } else { 2319 New(54,markstack,64,I32); 2320 markstack_ptr = markstack; 2321 markstack_max = markstack + 64; 2322 } 2323 2324 if (scopestack) { 2325 scopestack_ix = 0; 2326 } else { 2327 New(54,scopestack,32,I32); 2328 scopestack_ix = 0; 2329 scopestack_max = 32; 2330 } 2331 2332 if (savestack) { 2333 savestack_ix = 0; 2334 } else { 2335 New(54,savestack,128,ANY); 2336 savestack_ix = 0; 2337 savestack_max = 128; 2338 } 2339 2340 if (retstack) { 2341 retstack_ix = 0; 2342 } else { 2343 New(54,retstack,16,OP*); 2344 retstack_ix = 0; 2345 retstack_max = 16; 2346 } 2347 } 2348 2349 static void 2350 nuke_stacks() 2351 { 2352 Safefree(cxstack); 2353 Safefree(tmps_stack); 2354 DEBUG( { 2355 Safefree(debname); 2356 Safefree(debdelim); 2357 } ) 2358 } 2359 2360 static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */ 2361 2362 static void 2363 init_lexer() 2364 { 2365 tmpfp = rsfp; 2366 rsfp = Nullfp; 2367 lex_start(linestr); 2368 rsfp = tmpfp; 2369 subname = newSVpv("main",4); 2370 } 2371 2372 static void 2373 init_predump_symbols() 2374 { 2375 GV *tmpgv; 2376 GV *othergv; 2377 2378 sv_setpvn(GvSV(gv_fetchpv("\"", TRUE, SVt_PV)), " ", 1); 2379 2380 stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO); 2381 GvMULTI_on(stdingv); 2382 IoIFP(GvIOp(stdingv)) = PerlIO_stdin(); 2383 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV); 2384 GvMULTI_on(tmpgv); 2385 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(stdingv)); 2386 2387 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO); 2388 GvMULTI_on(tmpgv); 2389 IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = PerlIO_stdout(); 2390 setdefout(tmpgv); 2391 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV); 2392 GvMULTI_on(tmpgv); 2393 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(defoutgv)); 2394 2395 othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO); 2396 GvMULTI_on(othergv); 2397 IoOFP(GvIOp(othergv)) = IoIFP(GvIOp(othergv)) = PerlIO_stderr(); 2398 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV); 2399 GvMULTI_on(tmpgv); 2400 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(othergv)); 2401 2402 statname = NEWSV(66,0); /* last filename we did stat on */ 2403 2404 if (!osname) 2405 osname = savepv(OSNAME); 2406 } 2407 2408 static void 2409 init_postdump_symbols(argc,argv,env) 2410 register int argc; 2411 register char **argv; 2412 register char **env; 2413 { 2414 char *s; 2415 SV *sv; 2416 GV* tmpgv; 2417 2418 argc--,argv++; /* skip name of script */ 2419 if (doswitches) { 2420 for (; argc > 0 && **argv == '-'; argc--,argv++) { 2421 if (!argv[0][1]) 2422 break; 2423 if (argv[0][1] == '-') { 2424 argc--,argv++; 2425 break; 2426 } 2427 if (s = strchr(argv[0], '=')) { 2428 *s++ = '\0'; 2429 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s); 2430 } 2431 else 2432 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1); 2433 } 2434 } 2435 toptarget = NEWSV(0,0); 2436 sv_upgrade(toptarget, SVt_PVFM); 2437 sv_setpvn(toptarget, "", 0); 2438 bodytarget = NEWSV(0,0); 2439 sv_upgrade(bodytarget, SVt_PVFM); 2440 sv_setpvn(bodytarget, "", 0); 2441 formtarget = bodytarget; 2442 2443 TAINT; 2444 if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) { 2445 sv_setpv(GvSV(tmpgv),origfilename); 2446 magicname("0", "0", 1); 2447 } 2448 if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV)) 2449 sv_setpv(GvSV(tmpgv),origargv[0]); 2450 if (argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) { 2451 GvMULTI_on(argvgv); 2452 (void)gv_AVadd(argvgv); 2453 av_clear(GvAVn(argvgv)); 2454 for (; argc > 0; argc--,argv++) { 2455 av_push(GvAVn(argvgv),newSVpv(argv[0],0)); 2456 } 2457 } 2458 if (envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) { 2459 HV *hv; 2460 GvMULTI_on(envgv); 2461 hv = GvHVn(envgv); 2462 hv_magic(hv, envgv, 'E'); 2463 #ifndef VMS /* VMS doesn't have environ array */ 2464 /* Note that if the supplied env parameter is actually a copy 2465 of the global environ then it may now point to free'd memory 2466 if the environment has been modified since. To avoid this 2467 problem we treat env==NULL as meaning 'use the default' 2468 */ 2469 if (!env) 2470 env = environ; 2471 if (env != environ) 2472 environ[0] = Nullch; 2473 for (; *env; env++) { 2474 if (!(s = strchr(*env,'='))) 2475 continue; 2476 *s++ = '\0'; 2477 #ifdef WIN32 2478 (void)strupr(*env); 2479 #endif 2480 sv = newSVpv(s--,0); 2481 (void)hv_store(hv, *env, s - *env, sv, 0); 2482 *s = '='; 2483 #if defined(__BORLANDC__) && defined(USE_WIN32_RTL_ENV) 2484 /* Sins of the RTL. See note in my_setenv(). */ 2485 (void)putenv(savepv(*env)); 2486 #endif 2487 } 2488 #endif 2489 #ifdef DYNAMIC_ENV_FETCH 2490 HvNAME(hv) = savepv(ENV_HV_NAME); 2491 #endif 2492 } 2493 TAINT_NOT; 2494 if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV)) 2495 sv_setiv(GvSV(tmpgv), (IV)getpid()); 2496 } 2497 2498 static void 2499 init_perllib() 2500 { 2501 char *s; 2502 if (!tainting) { 2503 #ifndef VMS 2504 s = getenv("PERL5LIB"); 2505 if (s) 2506 incpush(s, TRUE); 2507 else 2508 incpush(getenv("PERLLIB"), FALSE); 2509 #else /* VMS */ 2510 /* Treat PERL5?LIB as a possible search list logical name -- the 2511 * "natural" VMS idiom for a Unix path string. We allow each 2512 * element to be a set of |-separated directories for compatibility. 2513 */ 2514 char buf[256]; 2515 int idx = 0; 2516 if (my_trnlnm("PERL5LIB",buf,0)) 2517 do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx)); 2518 else 2519 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE); 2520 #endif /* VMS */ 2521 } 2522 2523 /* Use the ~-expanded versions of APPLLIB (undocumented), 2524 ARCHLIB PRIVLIB SITEARCH SITELIB and OLDARCHLIB 2525 */ 2526 #ifdef APPLLIB_EXP 2527 incpush(APPLLIB_EXP, FALSE); 2528 #endif 2529 2530 #ifdef ARCHLIB_EXP 2531 incpush(ARCHLIB_EXP, FALSE); 2532 #endif 2533 #ifndef PRIVLIB_EXP 2534 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl" 2535 #endif 2536 incpush(PRIVLIB_EXP, FALSE); 2537 2538 #ifdef SITEARCH_EXP 2539 incpush(SITEARCH_EXP, FALSE); 2540 #endif 2541 #ifdef SITELIB_EXP 2542 incpush(SITELIB_EXP, FALSE); 2543 #endif 2544 #ifdef OLDARCHLIB_EXP /* 5.00[01] compatibility */ 2545 incpush(OLDARCHLIB_EXP, FALSE); 2546 #endif 2547 2548 if (!tainting) 2549 incpush(".", FALSE); 2550 } 2551 2552 #if defined(DOSISH) 2553 # define PERLLIB_SEP ';' 2554 #else 2555 # if defined(VMS) 2556 # define PERLLIB_SEP '|' 2557 # else 2558 # define PERLLIB_SEP ':' 2559 # endif 2560 #endif 2561 #ifndef PERLLIB_MANGLE 2562 # define PERLLIB_MANGLE(s,n) (s) 2563 #endif 2564 2565 static void 2566 incpush(p, addsubdirs) 2567 char *p; 2568 int addsubdirs; 2569 { 2570 SV *subdir = Nullsv; 2571 static char *archpat_auto; 2572 2573 if (!p) 2574 return; 2575 2576 if (addsubdirs) { 2577 subdir = newSV(0); 2578 if (!archpat_auto) { 2579 STRLEN len = (sizeof(ARCHNAME) + strlen(patchlevel) 2580 + sizeof("//auto")); 2581 New(55, archpat_auto, len, char); 2582 sprintf(archpat_auto, "/%s/%s/auto", ARCHNAME, patchlevel); 2583 #ifdef VMS 2584 for (len = sizeof(ARCHNAME) + 2; 2585 archpat_auto[len] != '\0' && archpat_auto[len] != '/'; len++) 2586 if (archpat_auto[len] == '.') archpat_auto[len] = '_'; 2587 #endif 2588 } 2589 } 2590 2591 /* Break at all separators */ 2592 while (p && *p) { 2593 SV *libdir = newSV(0); 2594 char *s; 2595 2596 /* skip any consecutive separators */ 2597 while ( *p == PERLLIB_SEP ) { 2598 /* Uncomment the next line for PATH semantics */ 2599 /* av_push(GvAVn(incgv), newSVpv(".", 1)); */ 2600 p++; 2601 } 2602 2603 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) { 2604 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)), 2605 (STRLEN)(s - p)); 2606 p = s + 1; 2607 } 2608 else { 2609 sv_setpv(libdir, PERLLIB_MANGLE(p, 0)); 2610 p = Nullch; /* break out */ 2611 } 2612 2613 /* 2614 * BEFORE pushing libdir onto @INC we may first push version- and 2615 * archname-specific sub-directories. 2616 */ 2617 if (addsubdirs) { 2618 struct stat tmpstatbuf; 2619 #ifdef VMS 2620 char *unix; 2621 STRLEN len; 2622 2623 if ((unix = tounixspec_ts(SvPV(libdir,na),Nullch)) != Nullch) { 2624 len = strlen(unix); 2625 while (unix[len-1] == '/') len--; /* Cosmetic */ 2626 sv_usepvn(libdir,unix,len); 2627 } 2628 else 2629 PerlIO_printf(PerlIO_stderr(), 2630 "Failed to unixify @INC element \"%s\"\n", 2631 SvPV(libdir,na)); 2632 #endif 2633 /* .../archname/version if -d .../archname/version/auto */ 2634 sv_setsv(subdir, libdir); 2635 sv_catpv(subdir, archpat_auto); 2636 if (Stat(SvPVX(subdir), &tmpstatbuf) >= 0 && 2637 S_ISDIR(tmpstatbuf.st_mode)) 2638 av_push(GvAVn(incgv), 2639 newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto")); 2640 2641 /* .../archname if -d .../archname/auto */ 2642 sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME), 2643 strlen(patchlevel) + 1, "", 0); 2644 if (Stat(SvPVX(subdir), &tmpstatbuf) >= 0 && 2645 S_ISDIR(tmpstatbuf.st_mode)) 2646 av_push(GvAVn(incgv), 2647 newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto")); 2648 } 2649 2650 /* finally push this lib directory on the end of @INC */ 2651 av_push(GvAVn(incgv), libdir); 2652 } 2653 2654 SvREFCNT_dec(subdir); 2655 } 2656 2657 void 2658 call_list(oldscope, list) 2659 I32 oldscope; 2660 AV* list; 2661 { 2662 line_t oldline = curcop->cop_line; 2663 STRLEN len; 2664 dJMPENV; 2665 int ret; 2666 2667 while (AvFILL(list) >= 0) { 2668 CV *cv = (CV*)av_shift(list); 2669 2670 SAVEFREESV(cv); 2671 2672 JMPENV_PUSH(ret); 2673 switch (ret) { 2674 case 0: { 2675 SV* atsv = GvSV(errgv); 2676 PUSHMARK(stack_sp); 2677 perl_call_sv((SV*)cv, G_EVAL|G_DISCARD); 2678 (void)SvPV(atsv, len); 2679 if (len) { 2680 JMPENV_POP; 2681 curcop = &compiling; 2682 curcop->cop_line = oldline; 2683 if (list == beginav) 2684 sv_catpv(atsv, "BEGIN failed--compilation aborted"); 2685 else 2686 sv_catpv(atsv, "END failed--cleanup aborted"); 2687 while (scopestack_ix > oldscope) 2688 LEAVE; 2689 croak("%s", SvPVX(atsv)); 2690 } 2691 } 2692 break; 2693 case 1: 2694 STATUS_ALL_FAILURE; 2695 /* FALL THROUGH */ 2696 case 2: 2697 /* my_exit() was called */ 2698 while (scopestack_ix > oldscope) 2699 LEAVE; 2700 FREETMPS; 2701 curstash = defstash; 2702 if (endav) 2703 call_list(oldscope, endav); 2704 JMPENV_POP; 2705 curcop = &compiling; 2706 curcop->cop_line = oldline; 2707 if (statusvalue) { 2708 if (list == beginav) 2709 croak("BEGIN failed--compilation aborted"); 2710 else 2711 croak("END failed--cleanup aborted"); 2712 } 2713 my_exit_jump(); 2714 /* NOTREACHED */ 2715 case 3: 2716 if (!restartop) { 2717 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n"); 2718 FREETMPS; 2719 break; 2720 } 2721 JMPENV_POP; 2722 curcop = &compiling; 2723 curcop->cop_line = oldline; 2724 JMPENV_JUMP(3); 2725 } 2726 JMPENV_POP; 2727 } 2728 } 2729 2730 void 2731 my_exit(status) 2732 U32 status; 2733 { 2734 switch (status) { 2735 case 0: 2736 STATUS_ALL_SUCCESS; 2737 break; 2738 case 1: 2739 STATUS_ALL_FAILURE; 2740 break; 2741 default: 2742 STATUS_NATIVE_SET(status); 2743 break; 2744 } 2745 my_exit_jump(); 2746 } 2747 2748 void 2749 my_failure_exit() 2750 { 2751 #ifdef VMS 2752 if (vaxc$errno & 1) { 2753 if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */ 2754 STATUS_NATIVE_SET(44); 2755 } 2756 else { 2757 if (!vaxc$errno && errno) /* unlikely */ 2758 STATUS_NATIVE_SET(44); 2759 else 2760 STATUS_NATIVE_SET(vaxc$errno); 2761 } 2762 #else 2763 if (errno & 255) 2764 STATUS_POSIX_SET(errno); 2765 else if (STATUS_POSIX == 0) 2766 STATUS_POSIX_SET(255); 2767 #endif 2768 my_exit_jump(); 2769 } 2770 2771 static void 2772 my_exit_jump() 2773 { 2774 register CONTEXT *cx; 2775 I32 gimme; 2776 SV **newsp; 2777 2778 if (e_tmpname) { 2779 if (e_fp) { 2780 PerlIO_close(e_fp); 2781 e_fp = Nullfp; 2782 } 2783 (void)UNLINK(e_tmpname); 2784 Safefree(e_tmpname); 2785 e_tmpname = Nullch; 2786 } 2787 2788 if (cxstack_ix >= 0) { 2789 if (cxstack_ix > 0) 2790 dounwind(0); 2791 POPBLOCK(cx,curpm); 2792 LEAVE; 2793 } 2794 2795 JMPENV_JUMP(2); 2796 } 2797