1 /* perl.c 2 * 3 * Copyright (c) 1987-1996 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 /* Omit -- it causes too much grief on mixed systems. 19 #ifdef I_UNISTD 20 #include <unistd.h> 21 #endif 22 */ 23 24 dEXT char rcsid[] = "perl.c\nPatch level: ###\n"; 25 26 #ifdef IAMSUID 27 #ifndef DOSUID 28 #define DOSUID 29 #endif 30 #endif 31 32 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW 33 #ifdef DOSUID 34 #undef DOSUID 35 #endif 36 #endif 37 38 static void find_beginning _((void)); 39 static void incpush _((char *)); 40 static void init_ids _((void)); 41 static void init_debugger _((void)); 42 static void init_lexer _((void)); 43 static void init_main_stash _((void)); 44 static void init_perllib _((void)); 45 static void init_postdump_symbols _((int, char **, char **)); 46 static void init_predump_symbols _((void)); 47 static void init_stacks _((void)); 48 static void open_script _((char *, bool, SV *)); 49 static void usage _((char *)); 50 static void validate_suid _((char *, char*)); 51 52 static int fdscript = -1; 53 54 PerlInterpreter * 55 perl_alloc() 56 { 57 PerlInterpreter *sv_interp; 58 59 curinterp = 0; 60 New(53, sv_interp, 1, PerlInterpreter); 61 return sv_interp; 62 } 63 64 void 65 perl_construct( sv_interp ) 66 register PerlInterpreter *sv_interp; 67 { 68 if (!(curinterp = sv_interp)) 69 return; 70 71 #ifdef MULTIPLICITY 72 Zero(sv_interp, 1, PerlInterpreter); 73 #endif 74 75 /* Init the real globals? */ 76 if (!linestr) { 77 linestr = NEWSV(65,80); 78 sv_upgrade(linestr,SVt_PVIV); 79 80 SvREADONLY_on(&sv_undef); 81 82 sv_setpv(&sv_no,No); 83 SvNV(&sv_no); 84 SvREADONLY_on(&sv_no); 85 86 sv_setpv(&sv_yes,Yes); 87 SvNV(&sv_yes); 88 SvREADONLY_on(&sv_yes); 89 90 nrs = newSVpv("\n", 1); 91 rs = SvREFCNT_inc(nrs); 92 93 #ifdef MSDOS 94 /* 95 * There is no way we can refer to them from Perl so close them to save 96 * space. The other alternative would be to provide STDAUX and STDPRN 97 * filehandles. 98 */ 99 (void)fclose(stdaux); 100 (void)fclose(stdprn); 101 #endif 102 } 103 104 #ifdef MULTIPLICITY 105 chopset = " \n-"; 106 copline = NOLINE; 107 curcop = &compiling; 108 dbargs = 0; 109 dlmax = 128; 110 laststatval = -1; 111 laststype = OP_STAT; 112 maxscream = -1; 113 maxsysfd = MAXSYSFD; 114 rsfp = Nullfp; 115 statname = Nullsv; 116 tmps_floor = -1; 117 #endif 118 119 init_ids(); 120 121 #if defined(SUBVERSION) && SUBVERSION > 0 122 sprintf(patchlevel, "%7.5f", 5.0 + (PATCHLEVEL / 1000.0) 123 + (SUBVERSION / 100000.0)); 124 #else 125 sprintf(patchlevel, "%5.3f", 5.0 + (PATCHLEVEL / 1000.0)); 126 #endif 127 128 #if defined(LOCAL_PATCH_COUNT) 129 Ilocalpatches = local_patches; /* For possible -v */ 130 #endif 131 132 fdpid = newAV(); /* for remembering popen pids by fd */ 133 pidstatus = newHV();/* for remembering status of dead pids */ 134 135 init_stacks(); 136 ENTER; 137 } 138 139 void 140 perl_destruct(sv_interp) 141 register PerlInterpreter *sv_interp; 142 { 143 int destruct_level; /* 0=none, 1=full, 2=full with checks */ 144 I32 last_sv_count; 145 HV *hv; 146 147 if (!(curinterp = sv_interp)) 148 return; 149 150 destruct_level = perl_destruct_level; 151 #ifdef DEBUGGING 152 { 153 char *s; 154 if (s = getenv("PERL_DESTRUCT_LEVEL")) 155 destruct_level = atoi(s); 156 } 157 #endif 158 159 LEAVE; 160 FREETMPS; 161 162 if (sv_objcount) { 163 /* We must account for everything. First the syntax tree. */ 164 if (main_root) { 165 curpad = AvARRAY(comppad); 166 op_free(main_root); 167 main_root = 0; 168 } 169 } 170 if (sv_objcount) { 171 /* 172 * Try to destruct global references. We do this first so that the 173 * destructors and destructees still exist. Some sv's might remain. 174 * Non-referenced objects are on their own. 175 */ 176 177 dirty = TRUE; 178 sv_clean_objs(); 179 } 180 181 if (destruct_level == 0){ 182 183 DEBUG_P(debprofdump()); 184 185 /* The exit() function will do everything that needs doing. */ 186 return; 187 } 188 189 /* Prepare to destruct main symbol table. */ 190 hv = defstash; 191 defstash = 0; 192 SvREFCNT_dec(hv); 193 194 FREETMPS; 195 if (destruct_level >= 2) { 196 if (scopestack_ix != 0) 197 warn("Unbalanced scopes: %d more ENTERs than LEAVEs\n", scopestack_ix); 198 if (savestack_ix != 0) 199 warn("Unbalanced saves: %d more saves than restores\n", savestack_ix); 200 if (tmps_floor != -1) 201 warn("Unbalanced tmps: %d more allocs than frees\n", tmps_floor + 1); 202 if (cxstack_ix != -1) 203 warn("Unbalanced context: %d more PUSHes than POPs\n", cxstack_ix + 1); 204 } 205 206 /* Now absolutely destruct everything, somehow or other, loops or no. */ 207 last_sv_count = 0; 208 while (sv_count != 0 && sv_count != last_sv_count) { 209 last_sv_count = sv_count; 210 sv_clean_all(); 211 } 212 if (sv_count != 0) 213 warn("Scalars leaked: %d\n", sv_count); 214 sv_free_arenas(); 215 216 DEBUG_P(debprofdump()); 217 } 218 219 void 220 perl_free(sv_interp) 221 PerlInterpreter *sv_interp; 222 { 223 if (!(curinterp = sv_interp)) 224 return; 225 Safefree(sv_interp); 226 } 227 #if !defined(STANDARD_C) && !defined(HAS_GETENV_PROTOTYPE) 228 char *getenv _((char *)); /* Usually in <stdlib.h> */ 229 #endif 230 231 int 232 perl_parse(sv_interp, xsinit, argc, argv, env) 233 PerlInterpreter *sv_interp; 234 void (*xsinit)_((void)); 235 int argc; 236 char **argv; 237 char **env; 238 { 239 register SV *sv; 240 register char *s; 241 char *scriptname = NULL; 242 VOL bool dosearch = FALSE; 243 char *validarg = ""; 244 AV* comppadlist; 245 246 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW 247 #ifdef IAMSUID 248 #undef IAMSUID 249 croak("suidperl is no longer needed since the kernel can now execute\n\ 250 setuid perl scripts securely.\n"); 251 #endif 252 #endif 253 254 if (!(curinterp = sv_interp)) 255 return 255; 256 257 origargv = argv; 258 origargc = argc; 259 #ifndef VMS /* VMS doesn't have environ array */ 260 origenviron = environ; 261 #endif 262 e_tmpname = Nullch; 263 264 if (do_undump) { 265 266 /* Come here if running an undumped a.out. */ 267 268 origfilename = savepv(argv[0]); 269 do_undump = FALSE; 270 cxstack_ix = -1; /* start label stack again */ 271 init_ids(); 272 init_postdump_symbols(argc,argv,env); 273 return 0; 274 } 275 276 if (main_root) 277 op_free(main_root); 278 main_root = 0; 279 280 switch (Sigsetjmp(top_env,1)) { 281 case 1: 282 #ifdef VMS 283 statusvalue = 255; 284 #else 285 statusvalue = 1; 286 #endif 287 case 2: 288 curstash = defstash; 289 if (endav) 290 calllist(endav); 291 return(statusvalue); /* my_exit() was called */ 292 case 3: 293 fprintf(stderr, "panic: top_env\n"); 294 return 1; 295 } 296 297 sv_setpvn(linestr,"",0); 298 sv = newSVpv("",0); /* first used for -I flags */ 299 SAVEFREESV(sv); 300 init_main_stash(); 301 for (argc--,argv++; argc > 0; argc--,argv++) { 302 if (argv[0][0] != '-' || !argv[0][1]) 303 break; 304 #ifdef DOSUID 305 if (*validarg) 306 validarg = " PHOOEY "; 307 else 308 validarg = argv[0]; 309 #endif 310 s = argv[0]+1; 311 reswitch: 312 switch (*s) { 313 case '0': 314 case 'F': 315 case 'a': 316 case 'c': 317 case 'd': 318 case 'D': 319 case 'h': 320 case 'i': 321 case 'l': 322 case 'M': 323 case 'm': 324 case 'n': 325 case 'p': 326 case 's': 327 case 'T': 328 case 'u': 329 case 'U': 330 case 'v': 331 case 'w': 332 if (s = moreswitches(s)) 333 goto reswitch; 334 break; 335 336 case 'e': 337 if (euid != uid || egid != gid) 338 croak("No -e allowed in setuid scripts"); 339 if (!e_fp) { 340 e_tmpname = savepv(TMPPATH); 341 (void)mktemp(e_tmpname); 342 if (!*e_tmpname) 343 croak("Can't mktemp()"); 344 e_fp = fopen(e_tmpname,"w"); 345 if (!e_fp) 346 croak("Cannot open temporary file"); 347 } 348 if (argv[1]) { 349 fputs(argv[1],e_fp); 350 argc--,argv++; 351 } 352 (void)putc('\n', e_fp); 353 break; 354 case 'I': 355 taint_not("-I"); 356 sv_catpv(sv,"-"); 357 sv_catpv(sv,s); 358 sv_catpv(sv," "); 359 if (*++s) { 360 av_push(GvAVn(incgv),newSVpv(s,0)); 361 } 362 else if (argv[1]) { 363 av_push(GvAVn(incgv),newSVpv(argv[1],0)); 364 sv_catpv(sv,argv[1]); 365 argc--,argv++; 366 sv_catpv(sv," "); 367 } 368 break; 369 case 'P': 370 taint_not("-P"); 371 preprocess = TRUE; 372 s++; 373 goto reswitch; 374 case 'S': 375 taint_not("-S"); 376 dosearch = TRUE; 377 s++; 378 goto reswitch; 379 case 'V': 380 if (!preambleav) 381 preambleav = newAV(); 382 av_push(preambleav, newSVpv("use Config qw(myconfig config_vars)",0)); 383 if (*++s != ':') { 384 Sv = newSVpv("print myconfig(),'@INC: '.\"@INC\\n\"",0); 385 } 386 else { 387 Sv = newSVpv("config_vars(qw(",0); 388 sv_catpv(Sv, ++s); 389 sv_catpv(Sv, "))"); 390 s += strlen(s); 391 } 392 av_push(preambleav, Sv); 393 scriptname = BIT_BUCKET; /* don't look for script or read stdin */ 394 goto reswitch; 395 case 'x': 396 doextract = TRUE; 397 s++; 398 if (*s) 399 cddir = savepv(s); 400 break; 401 case '-': 402 argc--,argv++; 403 goto switch_end; 404 case 0: 405 break; 406 default: 407 croak("Unrecognized switch: -%s",s); 408 } 409 } 410 switch_end: 411 if (!scriptname) 412 scriptname = argv[0]; 413 if (e_fp) { 414 if (Fflush(e_fp) || ferror(e_fp) || fclose(e_fp)) 415 croak("Can't write to temp file for -e: %s", Strerror(errno)); 416 e_fp = Nullfp; 417 argc++,argv--; 418 scriptname = e_tmpname; 419 } 420 else if (scriptname == Nullch) { 421 #ifdef MSDOS 422 if ( isatty(fileno(stdin)) ) 423 moreswitches("v"); 424 #endif 425 scriptname = "-"; 426 } 427 428 init_perllib(); 429 430 open_script(scriptname,dosearch,sv); 431 432 validate_suid(validarg, scriptname); 433 434 if (doextract) 435 find_beginning(); 436 437 compcv = (CV*)NEWSV(1104,0); 438 sv_upgrade((SV *)compcv, SVt_PVCV); 439 440 pad = newAV(); 441 comppad = pad; 442 av_push(comppad, Nullsv); 443 curpad = AvARRAY(comppad); 444 padname = newAV(); 445 comppad_name = padname; 446 comppad_name_fill = 0; 447 min_intro_pending = 0; 448 padix = 0; 449 450 comppadlist = newAV(); 451 AvREAL_off(comppadlist); 452 av_store(comppadlist, 0, (SV*)comppad_name); 453 av_store(comppadlist, 1, (SV*)comppad); 454 CvPADLIST(compcv) = comppadlist; 455 456 if (xsinit) 457 (*xsinit)(); /* in case linked C routines want magical variables */ 458 #ifdef VMS 459 init_os_extras(); 460 #endif 461 462 init_predump_symbols(); 463 if (!do_undump) 464 init_postdump_symbols(argc,argv,env); 465 466 init_lexer(); 467 468 /* now parse the script */ 469 470 error_count = 0; 471 if (yyparse() || error_count) { 472 if (minus_c) 473 croak("%s had compilation errors.\n", origfilename); 474 else { 475 croak("Execution of %s aborted due to compilation errors.\n", 476 origfilename); 477 } 478 } 479 curcop->cop_line = 0; 480 curstash = defstash; 481 preprocess = FALSE; 482 if (e_tmpname) { 483 (void)UNLINK(e_tmpname); 484 Safefree(e_tmpname); 485 e_tmpname = Nullch; 486 } 487 488 /* now that script is parsed, we can modify record separator */ 489 SvREFCNT_dec(rs); 490 rs = SvREFCNT_inc(nrs); 491 sv_setsv(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), rs); 492 493 if (do_undump) 494 my_unexec(); 495 496 if (dowarn) 497 gv_check(defstash); 498 499 LEAVE; 500 FREETMPS; 501 502 #ifdef DEBUGGING_MSTATS 503 if ((s=getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2) 504 dump_mstats("after compilation:"); 505 #endif 506 507 ENTER; 508 restartop = 0; 509 return 0; 510 } 511 512 int 513 perl_run(sv_interp) 514 PerlInterpreter *sv_interp; 515 { 516 if (!(curinterp = sv_interp)) 517 return 255; 518 switch (Sigsetjmp(top_env,1)) { 519 case 1: 520 cxstack_ix = -1; /* start context stack again */ 521 break; 522 case 2: 523 curstash = defstash; 524 if (endav) 525 calllist(endav); 526 FREETMPS; 527 #ifdef DEBUGGING_MSTATS 528 if (getenv("PERL_DEBUG_MSTATS")) 529 dump_mstats("after execution: "); 530 #endif 531 return(statusvalue); /* my_exit() was called */ 532 case 3: 533 if (!restartop) { 534 fprintf(stderr, "panic: restartop\n"); 535 FREETMPS; 536 return 1; 537 } 538 if (stack != mainstack) { 539 dSP; 540 SWITCHSTACK(stack, mainstack); 541 } 542 break; 543 } 544 545 if (!restartop) { 546 DEBUG_x(dump_all()); 547 DEBUG(fprintf(stderr,"\nEXECUTING...\n\n")); 548 549 if (minus_c) { 550 fprintf(stderr,"%s syntax OK\n", origfilename); 551 my_exit(0); 552 } 553 if (perldb && DBsingle) 554 sv_setiv(DBsingle, 1); 555 } 556 557 /* do it */ 558 559 if (restartop) { 560 op = restartop; 561 restartop = 0; 562 runops(); 563 } 564 else if (main_start) { 565 op = main_start; 566 runops(); 567 } 568 569 my_exit(0); 570 return 0; 571 } 572 573 void 574 my_exit(status) 575 U32 status; 576 { 577 register CONTEXT *cx; 578 I32 gimme; 579 SV **newsp; 580 581 statusvalue = FIXSTATUS(status); 582 if (cxstack_ix >= 0) { 583 if (cxstack_ix > 0) 584 dounwind(0); 585 POPBLOCK(cx,curpm); 586 LEAVE; 587 } 588 Siglongjmp(top_env, 2); 589 } 590 591 SV* 592 perl_get_sv(name, create) 593 char* name; 594 I32 create; 595 { 596 GV* gv = gv_fetchpv(name, create, SVt_PV); 597 if (gv) 598 return GvSV(gv); 599 return Nullsv; 600 } 601 602 AV* 603 perl_get_av(name, create) 604 char* name; 605 I32 create; 606 { 607 GV* gv = gv_fetchpv(name, create, SVt_PVAV); 608 if (create) 609 return GvAVn(gv); 610 if (gv) 611 return GvAV(gv); 612 return Nullav; 613 } 614 615 HV* 616 perl_get_hv(name, create) 617 char* name; 618 I32 create; 619 { 620 GV* gv = gv_fetchpv(name, create, SVt_PVHV); 621 if (create) 622 return GvHVn(gv); 623 if (gv) 624 return GvHV(gv); 625 return Nullhv; 626 } 627 628 CV* 629 perl_get_cv(name, create) 630 char* name; 631 I32 create; 632 { 633 GV* gv = gv_fetchpv(name, create, SVt_PVCV); 634 if (create && !GvCV(gv)) 635 return newSUB(start_subparse(), 636 newSVOP(OP_CONST, 0, newSVpv(name,0)), 637 Nullop, 638 Nullop); 639 if (gv) 640 return GvCV(gv); 641 return Nullcv; 642 } 643 644 /* Be sure to refetch the stack pointer after calling these routines. */ 645 646 I32 647 perl_call_argv(subname, flags, argv) 648 char *subname; 649 I32 flags; /* See G_* flags in cop.h */ 650 register char **argv; /* null terminated arg list */ 651 { 652 dSP; 653 654 PUSHMARK(sp); 655 if (argv) { 656 while (*argv) { 657 XPUSHs(sv_2mortal(newSVpv(*argv,0))); 658 argv++; 659 } 660 PUTBACK; 661 } 662 return perl_call_pv(subname, flags); 663 } 664 665 I32 666 perl_call_pv(subname, flags) 667 char *subname; /* name of the subroutine */ 668 I32 flags; /* See G_* flags in cop.h */ 669 { 670 return perl_call_sv((SV*)perl_get_cv(subname, TRUE), flags); 671 } 672 673 I32 674 perl_call_method(methname, flags) 675 char *methname; /* name of the subroutine */ 676 I32 flags; /* See G_* flags in cop.h */ 677 { 678 dSP; 679 OP myop; 680 if (!op) 681 op = &myop; 682 XPUSHs(sv_2mortal(newSVpv(methname,0))); 683 PUTBACK; 684 pp_method(); 685 return perl_call_sv(*stack_sp--, flags); 686 } 687 688 /* May be called with any of a CV, a GV, or an SV containing the name. */ 689 I32 690 perl_call_sv(sv, flags) 691 SV* sv; 692 I32 flags; /* See G_* flags in cop.h */ 693 { 694 LOGOP myop; /* fake syntax tree node */ 695 SV** sp = stack_sp; 696 I32 oldmark = TOPMARK; 697 I32 retval; 698 Sigjmp_buf oldtop; 699 I32 oldscope; 700 701 if (flags & G_DISCARD) { 702 ENTER; 703 SAVETMPS; 704 } 705 706 SAVESPTR(op); 707 op = (OP*)&myop; 708 Zero(op, 1, LOGOP); 709 EXTEND(stack_sp, 1); 710 *++stack_sp = sv; 711 oldscope = scopestack_ix; 712 713 if (!(flags & G_NOARGS)) 714 myop.op_flags = OPf_STACKED; 715 myop.op_next = Nullop; 716 myop.op_flags |= OPf_KNOW; 717 if (flags & G_ARRAY) 718 myop.op_flags |= OPf_LIST; 719 720 if (flags & G_EVAL) { 721 Copy(top_env, oldtop, 1, Sigjmp_buf); 722 723 cLOGOP->op_other = op; 724 markstack_ptr--; 725 /* we're trying to emulate pp_entertry() here */ 726 { 727 register CONTEXT *cx; 728 I32 gimme = GIMME; 729 730 ENTER; 731 SAVETMPS; 732 733 push_return(op->op_next); 734 PUSHBLOCK(cx, CXt_EVAL, stack_sp); 735 PUSHEVAL(cx, 0, 0); 736 eval_root = op; /* Only needed so that goto works right. */ 737 738 in_eval = 1; 739 if (flags & G_KEEPERR) 740 in_eval |= 4; 741 else 742 sv_setpv(GvSV(errgv),""); 743 } 744 markstack_ptr++; 745 746 restart: 747 switch (Sigsetjmp(top_env,1)) { 748 case 0: 749 break; 750 case 1: 751 #ifdef VMS 752 statusvalue = 255; /* XXX I don't think we use 1 anymore. */ 753 #else 754 statusvalue = 1; 755 #endif 756 /* FALL THROUGH */ 757 case 2: 758 /* my_exit() was called */ 759 curstash = defstash; 760 FREETMPS; 761 Copy(oldtop, top_env, 1, Sigjmp_buf); 762 if (statusvalue) 763 croak("Callback called exit"); 764 my_exit(statusvalue); 765 /* NOTREACHED */ 766 case 3: 767 if (restartop) { 768 op = restartop; 769 restartop = 0; 770 goto restart; 771 } 772 stack_sp = stack_base + oldmark; 773 if (flags & G_ARRAY) 774 retval = 0; 775 else { 776 retval = 1; 777 *++stack_sp = &sv_undef; 778 } 779 goto cleanup; 780 } 781 } 782 783 if (op == (OP*)&myop) 784 op = pp_entersub(); 785 if (op) 786 runops(); 787 retval = stack_sp - (stack_base + oldmark); 788 if ((flags & G_EVAL) && !(flags & G_KEEPERR)) 789 sv_setpv(GvSV(errgv),""); 790 791 cleanup: 792 if (flags & G_EVAL) { 793 if (scopestack_ix > oldscope) { 794 SV **newsp; 795 PMOP *newpm; 796 I32 gimme; 797 register CONTEXT *cx; 798 I32 optype; 799 800 POPBLOCK(cx,newpm); 801 POPEVAL(cx); 802 pop_return(); 803 curpm = newpm; 804 LEAVE; 805 } 806 Copy(oldtop, top_env, 1, Sigjmp_buf); 807 } 808 if (flags & G_DISCARD) { 809 stack_sp = stack_base + oldmark; 810 retval = 0; 811 FREETMPS; 812 LEAVE; 813 } 814 return retval; 815 } 816 817 /* Eval a string. */ 818 819 I32 820 perl_eval_sv(sv, flags) 821 SV* sv; 822 I32 flags; /* See G_* flags in cop.h */ 823 { 824 UNOP myop; /* fake syntax tree node */ 825 SV** sp = stack_sp; 826 I32 oldmark = sp - stack_base; 827 I32 retval; 828 Sigjmp_buf oldtop; 829 I32 oldscope; 830 831 if (flags & G_DISCARD) { 832 ENTER; 833 SAVETMPS; 834 } 835 836 SAVESPTR(op); 837 op = (OP*)&myop; 838 Zero(op, 1, UNOP); 839 EXTEND(stack_sp, 1); 840 *++stack_sp = sv; 841 oldscope = scopestack_ix; 842 843 if (!(flags & G_NOARGS)) 844 myop.op_flags = OPf_STACKED; 845 myop.op_next = Nullop; 846 myop.op_flags |= OPf_KNOW; 847 if (flags & G_ARRAY) 848 myop.op_flags |= OPf_LIST; 849 850 Copy(top_env, oldtop, 1, Sigjmp_buf); 851 852 restart: 853 switch (Sigsetjmp(top_env,1)) { 854 case 0: 855 break; 856 case 1: 857 #ifdef VMS 858 statusvalue = 255; /* XXX I don't think we use 1 anymore. */ 859 #else 860 statusvalue = 1; 861 #endif 862 /* FALL THROUGH */ 863 case 2: 864 /* my_exit() was called */ 865 curstash = defstash; 866 FREETMPS; 867 Copy(oldtop, top_env, 1, Sigjmp_buf); 868 if (statusvalue) 869 croak("Callback called exit"); 870 my_exit(statusvalue); 871 /* NOTREACHED */ 872 case 3: 873 if (restartop) { 874 op = restartop; 875 restartop = 0; 876 goto restart; 877 } 878 stack_sp = stack_base + oldmark; 879 if (flags & G_ARRAY) 880 retval = 0; 881 else { 882 retval = 1; 883 *++stack_sp = &sv_undef; 884 } 885 goto cleanup; 886 } 887 888 if (op == (OP*)&myop) 889 op = pp_entereval(); 890 if (op) 891 runops(); 892 retval = stack_sp - (stack_base + oldmark); 893 if ((flags & G_EVAL) && !(flags & G_KEEPERR)) 894 sv_setpv(GvSV(errgv),""); 895 896 cleanup: 897 Copy(oldtop, top_env, 1, Sigjmp_buf); 898 if (flags & G_DISCARD) { 899 stack_sp = stack_base + oldmark; 900 retval = 0; 901 FREETMPS; 902 LEAVE; 903 } 904 return retval; 905 } 906 907 /* Require a module. */ 908 909 void 910 perl_require_pv(pv) 911 char* pv; 912 { 913 SV* sv = sv_newmortal(); 914 sv_setpv(sv, "require '"); 915 sv_catpv(sv, pv); 916 sv_catpv(sv, "'"); 917 perl_eval_sv(sv, G_DISCARD); 918 } 919 920 void 921 magicname(sym,name,namlen) 922 char *sym; 923 char *name; 924 I32 namlen; 925 { 926 register GV *gv; 927 928 if (gv = gv_fetchpv(sym,TRUE, SVt_PV)) 929 sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen); 930 } 931 932 #if defined(DOSISH) 933 # define PERLLIB_SEP ';' 934 #else 935 # if defined(VMS) 936 # define PERLLIB_SEP '|' 937 # else 938 # define PERLLIB_SEP ':' 939 # endif 940 #endif 941 942 static void 943 incpush(p) 944 char *p; 945 { 946 char *s; 947 948 if (!p) 949 return; 950 951 /* Break at all separators */ 952 while (*p) { 953 /* First, skip any consecutive separators */ 954 while ( *p == PERLLIB_SEP ) { 955 /* Uncomment the next line for PATH semantics */ 956 /* av_push(GvAVn(incgv), newSVpv(".", 1)); */ 957 p++; 958 } 959 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) { 960 av_push(GvAVn(incgv), newSVpv(p, (STRLEN)(s - p))); 961 p = s + 1; 962 } else { 963 av_push(GvAVn(incgv), newSVpv(p, 0)); 964 break; 965 } 966 } 967 } 968 969 static void 970 usage(name) /* XXX move this out into a module ? */ 971 char *name; 972 { 973 /* This message really ought to be max 23 lines. 974 * Removed -h because the user already knows that opton. Others? */ 975 printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name); 976 printf("\n -0[octal] specify record separator (\\0, if no argument)"); 977 printf("\n -a autosplit mode with -n or -p (splits $_ into @F)"); 978 printf("\n -c check syntax only (runs BEGIN and END blocks)"); 979 printf("\n -d[:debugger] run scripts under debugger"); 980 printf("\n -D[number/list] set debugging flags (argument is a bit mask or flags)"); 981 printf("\n -e 'command' one line of script. Several -e's allowed. Omit [programfile]."); 982 printf("\n -F/pattern/ split() pattern for autosplit (-a). The //'s are optional."); 983 printf("\n -i[extension] edit <> files in place (make backup if extension supplied)"); 984 printf("\n -Idirectory specify @INC/#include directory (may be used more then once)"); 985 printf("\n -l[octal] enable line ending processing, specifies line teminator"); 986 printf("\n -[mM][-]module.. executes `use/no module...' before executing your script."); 987 printf("\n -n assume 'while (<>) { ... }' loop arround your script"); 988 printf("\n -p assume loop like -n but print line also like sed"); 989 printf("\n -P run script through C preprocessor before compilation"); 990 #ifdef OS2 991 printf("\n -R enable REXX variable pool"); 992 #endif 993 printf("\n -s enable some switch parsing for switches after script name"); 994 printf("\n -S look for the script using PATH environment variable"); 995 printf("\n -T turn on tainting checks"); 996 printf("\n -u dump core after parsing script"); 997 printf("\n -U allow unsafe operations"); 998 printf("\n -v print version number and patchlevel of perl"); 999 printf("\n -V[:variable] print perl configuration information"); 1000 printf("\n -w TURN WARNINGS ON FOR COMPILATION OF YOUR SCRIPT."); 1001 printf("\n -x[directory] strip off text before #!perl line and perhaps cd to directory\n"); 1002 } 1003 1004 /* This routine handles any switches that can be given during run */ 1005 1006 char * 1007 moreswitches(s) 1008 char *s; 1009 { 1010 I32 numlen; 1011 U32 rschar; 1012 1013 switch (*s) { 1014 case '0': 1015 rschar = scan_oct(s, 4, &numlen); 1016 SvREFCNT_dec(nrs); 1017 if (rschar & ~((U8)~0)) 1018 nrs = &sv_undef; 1019 else if (!rschar && numlen >= 2) 1020 nrs = newSVpv("", 0); 1021 else { 1022 char ch = rschar; 1023 nrs = newSVpv(&ch, 1); 1024 } 1025 return s + numlen; 1026 case 'F': 1027 minus_F = TRUE; 1028 splitstr = savepv(s + 1); 1029 s += strlen(s); 1030 return s; 1031 case 'a': 1032 minus_a = TRUE; 1033 s++; 1034 return s; 1035 case 'c': 1036 minus_c = TRUE; 1037 s++; 1038 return s; 1039 case 'd': 1040 taint_not("-d"); 1041 s++; 1042 if (*s == ':' || *s == '=') { 1043 sprintf(buf, "use Devel::%s;", ++s); 1044 s += strlen(s); 1045 my_setenv("PERL5DB",buf); 1046 } 1047 if (!perldb) { 1048 perldb = TRUE; 1049 init_debugger(); 1050 } 1051 return s; 1052 case 'D': 1053 #ifdef DEBUGGING 1054 taint_not("-D"); 1055 if (isALPHA(s[1])) { 1056 static char debopts[] = "psltocPmfrxuLHXD"; 1057 char *d; 1058 1059 for (s++; *s && (d = strchr(debopts,*s)); s++) 1060 debug |= 1 << (d - debopts); 1061 } 1062 else { 1063 debug = atoi(s+1); 1064 for (s++; isDIGIT(*s); s++) ; 1065 } 1066 debug |= 0x80000000; 1067 #else 1068 warn("Recompile perl with -DDEBUGGING to use -D switch\n"); 1069 for (s++; isALNUM(*s); s++) ; 1070 #endif 1071 /*SUPPRESS 530*/ 1072 return s; 1073 case 'h': 1074 usage(origargv[0]); 1075 exit(0); 1076 case 'i': 1077 if (inplace) 1078 Safefree(inplace); 1079 inplace = savepv(s+1); 1080 /*SUPPRESS 530*/ 1081 for (s = inplace; *s && !isSPACE(*s); s++) ; 1082 *s = '\0'; 1083 break; 1084 case 'I': 1085 taint_not("-I"); 1086 if (*++s) { 1087 char *e; 1088 for (e = s; *e && !isSPACE(*e); e++) ; 1089 av_push(GvAVn(incgv),newSVpv(s,e-s)); 1090 if (*e) 1091 return e; 1092 } 1093 else 1094 croak("No space allowed after -I"); 1095 break; 1096 case 'l': 1097 minus_l = TRUE; 1098 s++; 1099 if (ors) 1100 Safefree(ors); 1101 if (isDIGIT(*s)) { 1102 ors = savepv("\n"); 1103 orslen = 1; 1104 *ors = scan_oct(s, 3 + (*s == '0'), &numlen); 1105 s += numlen; 1106 } 1107 else { 1108 if (RsPARA(nrs)) { 1109 ors = savepvn("\n\n", 2); 1110 orslen = 2; 1111 } 1112 else 1113 ors = SvPV(nrs, orslen); 1114 } 1115 return s; 1116 case 'M': 1117 taint_not("-M"); /* XXX ? */ 1118 /* FALL THROUGH */ 1119 case 'm': 1120 taint_not("-m"); /* XXX ? */ 1121 if (*++s) { 1122 char *start; 1123 char *use = "use "; 1124 /* -M-foo == 'no foo' */ 1125 if (*s == '-') { use = "no "; ++s; } 1126 Sv = newSVpv(use,0); 1127 start = s; 1128 /* We allow -M'Module qw(Foo Bar)' */ 1129 while(isALNUM(*s) || *s==':') ++s; 1130 if (*s != '=') { 1131 sv_catpv(Sv, start); 1132 if (*(start-1) == 'm') { 1133 if (*s != '\0') 1134 croak("Can't use '%c' after -mname", *s); 1135 sv_catpv( Sv, " ()"); 1136 } 1137 } else { 1138 sv_catpvn(Sv, start, s-start); 1139 sv_catpv(Sv, " split(/,/,q{"); 1140 sv_catpv(Sv, ++s); 1141 sv_catpv(Sv, "})"); 1142 } 1143 s += strlen(s); 1144 if (preambleav == NULL) 1145 preambleav = newAV(); 1146 av_push(preambleav, Sv); 1147 } 1148 else 1149 croak("No space allowed after -%c", *(s-1)); 1150 return s; 1151 case 'n': 1152 minus_n = TRUE; 1153 s++; 1154 return s; 1155 case 'p': 1156 minus_p = TRUE; 1157 s++; 1158 return s; 1159 case 's': 1160 taint_not("-s"); 1161 doswitches = TRUE; 1162 s++; 1163 return s; 1164 case 'T': 1165 tainting = TRUE; 1166 s++; 1167 return s; 1168 case 'u': 1169 do_undump = TRUE; 1170 s++; 1171 return s; 1172 case 'U': 1173 unsafe = TRUE; 1174 s++; 1175 return s; 1176 case 'v': 1177 #if defined(SUBVERSION) && SUBVERSION > 0 1178 printf("\nThis is perl, version 5.%03d_%02d", PATCHLEVEL, SUBVERSION); 1179 #else 1180 printf("\nThis is perl, version %s",patchlevel); 1181 #endif 1182 1183 #if defined(DEBUGGING) || defined(EMBED) || defined(MULTIPLICITY) 1184 fputs(" with", stdout); 1185 #ifdef DEBUGGING 1186 fputs(" DEBUGGING", stdout); 1187 #endif 1188 #ifdef EMBED 1189 fputs(" EMBED", stdout); 1190 #endif 1191 #ifdef MULTIPLICITY 1192 fputs(" MULTIPLICITY", stdout); 1193 #endif 1194 #endif 1195 1196 #if defined(LOCAL_PATCH_COUNT) 1197 if (LOCAL_PATCH_COUNT > 0) 1198 { int i; 1199 fputs("\n\tLocally applied patches:\n", stdout); 1200 for (i = 1; i <= LOCAL_PATCH_COUNT; i++) { 1201 if (Ilocalpatches[i]) 1202 fprintf(stdout, "\t %s\n", Ilocalpatches[i]); 1203 } 1204 } 1205 #endif 1206 printf("\n\tbuilt under %s",OSNAME); 1207 #ifdef __DATE__ 1208 # ifdef __TIME__ 1209 printf(" at %s %s",__DATE__,__TIME__); 1210 # else 1211 printf(" on %s",__DATE__); 1212 # endif 1213 #endif 1214 fputs("\n\t+ suidperl security patch", stdout); 1215 fputs("\n\nCopyright 1987-1996, Larry Wall\n",stdout); 1216 #ifdef MSDOS 1217 fputs("MS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n", 1218 stdout); 1219 #endif 1220 #ifdef OS2 1221 fputs("OS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n" 1222 "Version 5 port Copyright (c) 1994-1995, Andreas Kaiser\n", stdout); 1223 #endif 1224 #ifdef atarist 1225 fputs("atariST series port, ++jrb bammi@cadence.com\n", stdout); 1226 #endif 1227 fputs("\n\ 1228 Perl may be copied only under the terms of either the Artistic License or the\n\ 1229 GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n",stdout); 1230 #ifdef MSDOS 1231 usage(origargv[0]); 1232 #endif 1233 exit(0); 1234 case 'w': 1235 dowarn = TRUE; 1236 s++; 1237 return s; 1238 case '*': 1239 case ' ': 1240 if (s[1] == '-') /* Additional switches on #! line. */ 1241 return s+2; 1242 break; 1243 case '-': 1244 case 0: 1245 case '\n': 1246 case '\t': 1247 break; 1248 case 'P': 1249 if (preprocess) 1250 return s+1; 1251 /* FALL THROUGH */ 1252 default: 1253 croak("Can't emulate -%.1s on #! line",s); 1254 } 1255 return Nullch; 1256 } 1257 1258 /* compliments of Tom Christiansen */ 1259 1260 /* unexec() can be found in the Gnu emacs distribution */ 1261 1262 void 1263 my_unexec() 1264 { 1265 #ifdef UNEXEC 1266 int status; 1267 extern int etext; 1268 1269 sprintf (buf, "%s.perldump", origfilename); 1270 sprintf (tokenbuf, "%s/perl", BIN); 1271 1272 status = unexec(buf, tokenbuf, &etext, sbrk(0), 0); 1273 if (status) 1274 fprintf(stderr, "unexec of %s into %s failed!\n", tokenbuf, buf); 1275 exit(status); 1276 #else 1277 # ifdef VMS 1278 # include <lib$routines.h> 1279 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */ 1280 #else 1281 ABORT(); /* for use with undump */ 1282 #endif 1283 #endif 1284 } 1285 1286 static void 1287 init_main_stash() 1288 { 1289 GV *gv; 1290 curstash = defstash = newHV(); 1291 curstname = newSVpv("main",4); 1292 gv = gv_fetchpv("main::",TRUE, SVt_PVHV); 1293 SvREFCNT_dec(GvHV(gv)); 1294 GvHV(gv) = (HV*)SvREFCNT_inc(defstash); 1295 SvREADONLY_on(gv); 1296 HvNAME(defstash) = savepv("main"); 1297 incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV))); 1298 GvMULTI_on(incgv); 1299 defgv = gv_fetchpv("_",TRUE, SVt_PVAV); 1300 errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV)); 1301 GvMULTI_on(errgv); 1302 curstash = defstash; 1303 compiling.cop_stash = defstash; 1304 debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV)); 1305 /* We must init $/ before switches are processed. */ 1306 sv_setpvn(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), "\n", 1); 1307 } 1308 1309 #ifdef CAN_PROTOTYPE 1310 static void 1311 open_script(char *scriptname, bool dosearch, SV *sv) 1312 #else 1313 static void 1314 open_script(scriptname,dosearch,sv) 1315 char *scriptname; 1316 bool dosearch; 1317 SV *sv; 1318 #endif 1319 { 1320 char *xfound = Nullch; 1321 char *xfailed = Nullch; 1322 register char *s; 1323 I32 len; 1324 int retval; 1325 #if defined(DOSISH) && !defined(OS2) && !defined(atarist) 1326 #define SEARCH_EXTS ".bat", ".cmd", NULL 1327 #endif 1328 #ifdef VMS 1329 # define SEARCH_EXTS ".pl", ".com", NULL 1330 #endif 1331 /* additional extensions to try in each dir if scriptname not found */ 1332 #ifdef SEARCH_EXTS 1333 char *ext[] = { SEARCH_EXTS }; 1334 int extidx = (strchr(scriptname,'.')) ? -1 : 0; /* has ext already */ 1335 #endif 1336 1337 #ifdef VMS 1338 if (dosearch && !strpbrk(scriptname,":[</") && (my_getenv("DCL$PATH"))) { 1339 int idx = 0; 1340 1341 while (my_trnlnm("DCL$PATH",tokenbuf,idx++)) { 1342 strcat(tokenbuf,scriptname); 1343 #else /* !VMS */ 1344 if (dosearch && !strchr(scriptname, '/') && (s = getenv("PATH"))) { 1345 1346 bufend = s + strlen(s); 1347 while (*s) { 1348 #ifndef DOSISH 1349 s = cpytill(tokenbuf,s,bufend,':',&len); 1350 #else 1351 #ifdef atarist 1352 for (len = 0; *s && *s != ',' && *s != ';'; tokenbuf[len++] = *s++); 1353 tokenbuf[len] = '\0'; 1354 #else 1355 for (len = 0; *s && *s != ';'; tokenbuf[len++] = *s++); 1356 tokenbuf[len] = '\0'; 1357 #endif 1358 #endif 1359 if (*s) 1360 s++; 1361 #ifndef DOSISH 1362 if (len && tokenbuf[len-1] != '/') 1363 #else 1364 #ifdef atarist 1365 if (len && ((tokenbuf[len-1] != '\\') && (tokenbuf[len-1] != '/'))) 1366 #else 1367 if (len && tokenbuf[len-1] != '\\') 1368 #endif 1369 #endif 1370 (void)strcat(tokenbuf+len,"/"); 1371 (void)strcat(tokenbuf+len,scriptname); 1372 #endif /* !VMS */ 1373 1374 #ifdef SEARCH_EXTS 1375 len = strlen(tokenbuf); 1376 if (extidx > 0) /* reset after previous loop */ 1377 extidx = 0; 1378 do { 1379 #endif 1380 DEBUG_p(fprintf(stderr,"Looking for %s\n",tokenbuf)); 1381 retval = Stat(tokenbuf,&statbuf); 1382 #ifdef SEARCH_EXTS 1383 } while ( retval < 0 /* not there */ 1384 && extidx>=0 && ext[extidx] /* try an extension? */ 1385 && strcpy(tokenbuf+len, ext[extidx++]) 1386 ); 1387 #endif 1388 if (retval < 0) 1389 continue; 1390 if (S_ISREG(statbuf.st_mode) 1391 && cando(S_IRUSR,TRUE,&statbuf) && cando(S_IXUSR,TRUE,&statbuf)) { 1392 xfound = tokenbuf; /* bingo! */ 1393 break; 1394 } 1395 if (!xfailed) 1396 xfailed = savepv(tokenbuf); 1397 } 1398 if (!xfound) 1399 croak("Can't execute %s", xfailed ? xfailed : scriptname ); 1400 if (xfailed) 1401 Safefree(xfailed); 1402 scriptname = xfound; 1403 } 1404 1405 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) { 1406 char *s = scriptname + 8; 1407 fdscript = atoi(s); 1408 while (isDIGIT(*s)) 1409 s++; 1410 if (*s) 1411 scriptname = s + 1; 1412 } 1413 else 1414 fdscript = -1; 1415 origfilename = savepv(e_tmpname ? "-e" : scriptname); 1416 curcop->cop_filegv = gv_fetchfile(origfilename); 1417 if (strEQ(origfilename,"-")) 1418 scriptname = ""; 1419 if (fdscript >= 0) { 1420 rsfp = fdopen(fdscript,"r"); 1421 #if defined(HAS_FCNTL) && defined(F_SETFD) 1422 fcntl(fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */ 1423 #endif 1424 } 1425 else if (preprocess) { 1426 char *cpp = CPPSTDIN; 1427 1428 if (strEQ(cpp,"cppstdin")) 1429 sprintf(tokenbuf, "%s/%s", SCRIPTDIR, cpp); 1430 else 1431 sprintf(tokenbuf, "%s", cpp); 1432 sv_catpv(sv,"-I"); 1433 sv_catpv(sv,PRIVLIB_EXP); 1434 #ifdef MSDOS 1435 (void)sprintf(buf, "\ 1436 sed %s -e \"/^[^#]/b\" \ 1437 -e \"/^#[ ]*include[ ]/b\" \ 1438 -e \"/^#[ ]*define[ ]/b\" \ 1439 -e \"/^#[ ]*if[ ]/b\" \ 1440 -e \"/^#[ ]*ifdef[ ]/b\" \ 1441 -e \"/^#[ ]*ifndef[ ]/b\" \ 1442 -e \"/^#[ ]*else/b\" \ 1443 -e \"/^#[ ]*elif[ ]/b\" \ 1444 -e \"/^#[ ]*undef[ ]/b\" \ 1445 -e \"/^#[ ]*endif/b\" \ 1446 -e \"s/^#.*//\" \ 1447 %s | %s -C %s %s", 1448 (doextract ? "-e \"1,/^#/d\n\"" : ""), 1449 #else 1450 (void)sprintf(buf, "\ 1451 %s %s -e '/^[^#]/b' \ 1452 -e '/^#[ ]*include[ ]/b' \ 1453 -e '/^#[ ]*define[ ]/b' \ 1454 -e '/^#[ ]*if[ ]/b' \ 1455 -e '/^#[ ]*ifdef[ ]/b' \ 1456 -e '/^#[ ]*ifndef[ ]/b' \ 1457 -e '/^#[ ]*else/b' \ 1458 -e '/^#[ ]*elif[ ]/b' \ 1459 -e '/^#[ ]*undef[ ]/b' \ 1460 -e '/^#[ ]*endif/b' \ 1461 -e 's/^[ ]*#.*//' \ 1462 %s | %s -C %s %s", 1463 #ifdef LOC_SED 1464 LOC_SED, 1465 #else 1466 "sed", 1467 #endif 1468 (doextract ? "-e '1,/^#/d\n'" : ""), 1469 #endif 1470 scriptname, tokenbuf, SvPV(sv, na), CPPMINUS); 1471 doextract = FALSE; 1472 #ifdef IAMSUID /* actually, this is caught earlier */ 1473 if (euid != uid && !euid) { /* if running suidperl */ 1474 #ifdef HAS_SETEUID 1475 (void)seteuid(uid); /* musn't stay setuid root */ 1476 #else 1477 #ifdef HAS_SETREUID 1478 (void)setreuid((Uid_t)-1, uid); 1479 #else 1480 #ifdef HAS_SETRESUID 1481 (void)setresuid((Uid_t)-1, uid, (Uid_t)-1); 1482 #else 1483 setuid(uid); 1484 #endif 1485 #endif 1486 #endif 1487 if (geteuid() != uid) 1488 croak("Can't do seteuid!\n"); 1489 } 1490 #endif /* IAMSUID */ 1491 rsfp = my_popen(buf,"r"); 1492 } 1493 else if (!*scriptname) { 1494 taint_not("program input from stdin"); 1495 rsfp = stdin; 1496 } 1497 else { 1498 rsfp = fopen(scriptname,"r"); 1499 #if defined(HAS_FCNTL) && defined(F_SETFD) 1500 fcntl(fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */ 1501 #endif 1502 } 1503 if ((FILE*)rsfp == Nullfp) { 1504 #ifdef DOSUID 1505 #ifndef IAMSUID /* in case script is not readable before setuid */ 1506 if (euid && Stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 && 1507 statbuf.st_mode & (S_ISUID|S_ISGID)) { 1508 (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel); 1509 execv(buf, origargv); /* try again */ 1510 croak("Can't do setuid\n"); 1511 } 1512 #endif 1513 #endif 1514 croak("Can't open perl script \"%s\": %s\n", 1515 SvPVX(GvSV(curcop->cop_filegv)), Strerror(errno)); 1516 } 1517 } 1518 1519 static void 1520 validate_suid(validarg, scriptname) 1521 char *validarg; 1522 char *scriptname; 1523 { 1524 int which; 1525 1526 /* do we need to emulate setuid on scripts? */ 1527 1528 /* This code is for those BSD systems that have setuid #! scripts disabled 1529 * in the kernel because of a security problem. Merely defining DOSUID 1530 * in perl will not fix that problem, but if you have disabled setuid 1531 * scripts in the kernel, this will attempt to emulate setuid and setgid 1532 * on scripts that have those now-otherwise-useless bits set. The setuid 1533 * root version must be called suidperl or sperlN.NNN. If regular perl 1534 * discovers that it has opened a setuid script, it calls suidperl with 1535 * the same argv that it had. If suidperl finds that the script it has 1536 * just opened is NOT setuid root, it sets the effective uid back to the 1537 * uid. We don't just make perl setuid root because that loses the 1538 * effective uid we had before invoking perl, if it was different from the 1539 * uid. 1540 * 1541 * DOSUID must be defined in both perl and suidperl, and IAMSUID must 1542 * be defined in suidperl only. suidperl must be setuid root. The 1543 * Configure script will set this up for you if you want it. 1544 */ 1545 1546 #ifdef DOSUID 1547 char *s; 1548 1549 if (Fstat(fileno(rsfp),&statbuf) < 0) /* normal stat is insecure */ 1550 croak("Can't stat script \"%s\"",origfilename); 1551 if (fdscript < 0 && statbuf.st_mode & (S_ISUID|S_ISGID)) { 1552 I32 len; 1553 1554 #ifdef IAMSUID 1555 #ifndef HAS_SETREUID 1556 /* On this access check to make sure the directories are readable, 1557 * there is actually a small window that the user could use to make 1558 * filename point to an accessible directory. So there is a faint 1559 * chance that someone could execute a setuid script down in a 1560 * non-accessible directory. I don't know what to do about that. 1561 * But I don't think it's too important. The manual lies when 1562 * it says access() is useful in setuid programs. 1563 */ 1564 if (access(SvPVX(GvSV(curcop->cop_filegv)),1)) /*double check*/ 1565 croak("Permission denied"); 1566 #else 1567 /* If we can swap euid and uid, then we can determine access rights 1568 * with a simple stat of the file, and then compare device and 1569 * inode to make sure we did stat() on the same file we opened. 1570 * Then we just have to make sure he or she can execute it. 1571 */ 1572 { 1573 struct stat tmpstatbuf; 1574 1575 if ( 1576 #ifdef HAS_SETREUID 1577 setreuid(euid,uid) < 0 1578 #else 1579 # if HAS_SETRESUID 1580 setresuid(euid,uid,(Uid_t)-1) < 0 1581 # endif 1582 #endif 1583 || getuid() != euid || geteuid() != uid) 1584 croak("Can't swap uid and euid"); /* really paranoid */ 1585 if (Stat(SvPVX(GvSV(curcop->cop_filegv)),&tmpstatbuf) < 0) 1586 croak("Permission denied"); /* testing full pathname here */ 1587 if (tmpstatbuf.st_dev != statbuf.st_dev || 1588 tmpstatbuf.st_ino != statbuf.st_ino) { 1589 (void)fclose(rsfp); 1590 if (rsfp = my_popen("/bin/mail root","w")) { /* heh, heh */ 1591 fprintf(rsfp, 1592 "User %d tried to run dev %d ino %d in place of dev %d ino %d!\n\ 1593 (Filename of set-id script was %s, uid %d gid %d.)\n\nSincerely,\nperl\n", 1594 uid,tmpstatbuf.st_dev, tmpstatbuf.st_ino, 1595 statbuf.st_dev, statbuf.st_ino, 1596 SvPVX(GvSV(curcop->cop_filegv)), 1597 statbuf.st_uid, statbuf.st_gid); 1598 (void)my_pclose(rsfp); 1599 } 1600 croak("Permission denied\n"); 1601 } 1602 if ( 1603 #ifdef HAS_SETREUID 1604 setreuid(uid,euid) < 0 1605 #else 1606 # if defined(HAS_SETRESUID) 1607 setresuid(uid,euid,(Uid_t)-1) < 0 1608 # endif 1609 #endif 1610 || getuid() != uid || geteuid() != euid) 1611 croak("Can't reswap uid and euid"); 1612 if (!cando(S_IXUSR,FALSE,&statbuf)) /* can real uid exec? */ 1613 croak("Permission denied\n"); 1614 } 1615 #endif /* HAS_SETREUID */ 1616 #endif /* IAMSUID */ 1617 1618 if (!S_ISREG(statbuf.st_mode)) 1619 croak("Permission denied"); 1620 if (statbuf.st_mode & S_IWOTH) 1621 croak("Setuid/gid script is writable by world"); 1622 doswitches = FALSE; /* -s is insecure in suid */ 1623 curcop->cop_line++; 1624 if (fgets(tokenbuf,sizeof tokenbuf, rsfp) == Nullch || 1625 strnNE(tokenbuf,"#!",2) ) /* required even on Sys V */ 1626 croak("No #! line"); 1627 s = tokenbuf+2; 1628 if (*s == ' ') s++; 1629 while (!isSPACE(*s)) s++; 1630 if (strnNE(s-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */ 1631 croak("Not a perl script"); 1632 while (*s == ' ' || *s == '\t') s++; 1633 /* 1634 * #! arg must be what we saw above. They can invoke it by 1635 * mentioning suidperl explicitly, but they may not add any strange 1636 * arguments beyond what #! says if they do invoke suidperl that way. 1637 */ 1638 len = strlen(validarg); 1639 if (strEQ(validarg," PHOOEY ") || 1640 strnNE(s,validarg,len) || !isSPACE(s[len])) 1641 croak("Args must match #! line"); 1642 1643 #ifndef IAMSUID 1644 if (euid != uid && (statbuf.st_mode & S_ISUID) && 1645 euid == statbuf.st_uid) 1646 if (!do_undump) 1647 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\ 1648 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n"); 1649 #endif /* IAMSUID */ 1650 1651 if (euid) { /* oops, we're not the setuid root perl */ 1652 (void)fclose(rsfp); 1653 #ifndef IAMSUID 1654 (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel); 1655 execv(buf, origargv); /* try again */ 1656 #endif 1657 croak("Can't do setuid\n"); 1658 } 1659 1660 if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid) { 1661 #ifdef HAS_SETEGID 1662 (void)setegid(statbuf.st_gid); 1663 #else 1664 #ifdef HAS_SETREGID 1665 (void)setregid((Gid_t)-1,statbuf.st_gid); 1666 #else 1667 #ifdef HAS_SETRESGID 1668 (void)setresgid((Gid_t)-1,statbuf.st_gid,(Gid_t)-1); 1669 #else 1670 setgid(statbuf.st_gid); 1671 #endif 1672 #endif 1673 #endif 1674 if (getegid() != statbuf.st_gid) 1675 croak("Can't do setegid!\n"); 1676 } 1677 if (statbuf.st_mode & S_ISUID) { 1678 if (statbuf.st_uid != euid) 1679 #ifdef HAS_SETEUID 1680 (void)seteuid(statbuf.st_uid); /* all that for this */ 1681 #else 1682 #ifdef HAS_SETREUID 1683 (void)setreuid((Uid_t)-1,statbuf.st_uid); 1684 #else 1685 #ifdef HAS_SETRESUID 1686 (void)setresuid((Uid_t)-1,statbuf.st_uid,(Uid_t)-1); 1687 #else 1688 setuid(statbuf.st_uid); 1689 #endif 1690 #endif 1691 #endif 1692 if (geteuid() != statbuf.st_uid) 1693 croak("Can't do seteuid!\n"); 1694 } 1695 else if (uid) { /* oops, mustn't run as root */ 1696 #ifdef HAS_SETEUID 1697 (void)seteuid((Uid_t)uid); 1698 #else 1699 #ifdef HAS_SETREUID 1700 (void)setreuid((Uid_t)-1,(Uid_t)uid); 1701 #else 1702 #ifdef HAS_SETRESUID 1703 (void)setresuid((Uid_t)-1,(Uid_t)uid,(Uid_t)-1); 1704 #else 1705 setuid((Uid_t)uid); 1706 #endif 1707 #endif 1708 #endif 1709 if (geteuid() != uid) 1710 croak("Can't do seteuid!\n"); 1711 } 1712 init_ids(); 1713 if (!cando(S_IXUSR,TRUE,&statbuf)) 1714 croak("Permission denied\n"); /* they can't do this */ 1715 } 1716 #ifdef IAMSUID 1717 else if (preprocess) 1718 croak("-P not allowed for setuid/setgid script\n"); 1719 else if (fdscript >= 0) 1720 croak("fd script not allowed in suidperl\n"); 1721 else 1722 croak("Script is not setuid/setgid in suidperl\n"); 1723 1724 /* We absolutely must clear out any saved ids here, so we */ 1725 /* exec the real perl, substituting fd script for scriptname. */ 1726 /* (We pass script name as "subdir" of fd, which perl will grok.) */ 1727 rewind(rsfp); 1728 for (which = 1; origargv[which] && origargv[which] != scriptname; which++) ; 1729 if (!origargv[which]) 1730 croak("Permission denied"); 1731 (void)sprintf(buf, "/dev/fd/%d/%.127s", fileno(rsfp), origargv[which]); 1732 origargv[which] = buf; 1733 1734 #if defined(HAS_FCNTL) && defined(F_SETFD) 1735 fcntl(fileno(rsfp),F_SETFD,0); /* ensure no close-on-exec */ 1736 #endif 1737 1738 (void)sprintf(tokenbuf, "%s/perl%s", BIN, patchlevel); 1739 execv(tokenbuf, origargv); /* try again */ 1740 croak("Can't do setuid\n"); 1741 #endif /* IAMSUID */ 1742 #else /* !DOSUID */ 1743 if (euid != uid || egid != gid) { /* (suidperl doesn't exist, in fact) */ 1744 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW 1745 Fstat(fileno(rsfp),&statbuf); /* may be either wrapped or real suid */ 1746 if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID) 1747 || 1748 (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID) 1749 ) 1750 if (!do_undump) 1751 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\ 1752 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n"); 1753 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */ 1754 /* not set-id, must be wrapped */ 1755 } 1756 #endif /* DOSUID */ 1757 } 1758 1759 static void 1760 find_beginning() 1761 { 1762 register char *s; 1763 1764 /* skip forward in input to the real script? */ 1765 1766 taint_not("-x"); 1767 while (doextract) { 1768 if ((s = sv_gets(linestr, rsfp, 0)) == Nullch) 1769 croak("No Perl script found in input\n"); 1770 if (*s == '#' && s[1] == '!' && instr(s,"perl")) { 1771 ungetc('\n',rsfp); /* to keep line count right */ 1772 doextract = FALSE; 1773 if (s = instr(s,"perl -")) { 1774 s += 6; 1775 /*SUPPRESS 530*/ 1776 while (s = moreswitches(s)) ; 1777 } 1778 if (cddir && chdir(cddir) < 0) 1779 croak("Can't chdir to %s",cddir); 1780 } 1781 } 1782 } 1783 1784 static void 1785 init_ids() 1786 { 1787 uid = (int)getuid(); 1788 euid = (int)geteuid(); 1789 gid = (int)getgid(); 1790 egid = (int)getegid(); 1791 #ifdef VMS 1792 uid |= gid << 16; 1793 euid |= egid << 16; 1794 #endif 1795 tainting |= (uid && (euid != uid || egid != gid)); 1796 } 1797 1798 static void 1799 init_debugger() 1800 { 1801 curstash = debstash; 1802 dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV)))); 1803 AvREAL_off(dbargs); 1804 DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV); 1805 DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV); 1806 DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV)); 1807 DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV))); 1808 sv_setiv(DBsingle, 0); 1809 DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV))); 1810 sv_setiv(DBtrace, 0); 1811 DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV))); 1812 sv_setiv(DBsignal, 0); 1813 curstash = defstash; 1814 } 1815 1816 static void 1817 init_stacks() 1818 { 1819 stack = newAV(); 1820 mainstack = stack; /* remember in case we switch stacks */ 1821 AvREAL_off(stack); /* not a real array */ 1822 av_extend(stack,127); 1823 1824 stack_base = AvARRAY(stack); 1825 stack_sp = stack_base; 1826 stack_max = stack_base + 127; 1827 1828 New(54,markstack,64,I32); 1829 markstack_ptr = markstack; 1830 markstack_max = markstack + 64; 1831 1832 New(54,scopestack,32,I32); 1833 scopestack_ix = 0; 1834 scopestack_max = 32; 1835 1836 New(54,savestack,128,ANY); 1837 savestack_ix = 0; 1838 savestack_max = 128; 1839 1840 New(54,retstack,16,OP*); 1841 retstack_ix = 0; 1842 retstack_max = 16; 1843 1844 cxstack_max = 8192 / sizeof(CONTEXT) - 2; /* Use most of 8K. */ 1845 New(50,cxstack,cxstack_max + 1,CONTEXT); 1846 cxstack_ix = -1; 1847 1848 New(50,tmps_stack,128,SV*); 1849 tmps_ix = -1; 1850 tmps_max = 128; 1851 1852 DEBUG( { 1853 New(51,debname,128,char); 1854 New(52,debdelim,128,char); 1855 } ) 1856 } 1857 1858 static FILE *tmpfp; /* moved outside init_lexer() because of UNICOS bug */ 1859 static void 1860 init_lexer() 1861 { 1862 tmpfp = rsfp; 1863 1864 lex_start(linestr); 1865 rsfp = tmpfp; 1866 subname = newSVpv("main",4); 1867 } 1868 1869 static void 1870 init_predump_symbols() 1871 { 1872 GV *tmpgv; 1873 GV *othergv; 1874 1875 sv_setpvn(GvSV(gv_fetchpv("\"", TRUE, SVt_PV)), " ", 1); 1876 1877 stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO); 1878 GvMULTI_on(stdingv); 1879 IoIFP(GvIOp(stdingv)) = stdin; 1880 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV); 1881 GvMULTI_on(tmpgv); 1882 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(stdingv)); 1883 1884 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO); 1885 GvMULTI_on(tmpgv); 1886 IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = stdout; 1887 setdefout(tmpgv); 1888 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV); 1889 GvMULTI_on(tmpgv); 1890 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(defoutgv)); 1891 1892 othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO); 1893 GvMULTI_on(othergv); 1894 IoOFP(GvIOp(othergv)) = IoIFP(GvIOp(othergv)) = stderr; 1895 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV); 1896 GvMULTI_on(tmpgv); 1897 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(othergv)); 1898 1899 statname = NEWSV(66,0); /* last filename we did stat on */ 1900 1901 osname = savepv(OSNAME); 1902 } 1903 1904 static void 1905 init_postdump_symbols(argc,argv,env) 1906 register int argc; 1907 register char **argv; 1908 register char **env; 1909 { 1910 char *s; 1911 SV *sv; 1912 GV* tmpgv; 1913 1914 argc--,argv++; /* skip name of script */ 1915 if (doswitches) { 1916 for (; argc > 0 && **argv == '-'; argc--,argv++) { 1917 if (!argv[0][1]) 1918 break; 1919 if (argv[0][1] == '-') { 1920 argc--,argv++; 1921 break; 1922 } 1923 if (s = strchr(argv[0], '=')) { 1924 *s++ = '\0'; 1925 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s); 1926 } 1927 else 1928 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1); 1929 } 1930 } 1931 toptarget = NEWSV(0,0); 1932 sv_upgrade(toptarget, SVt_PVFM); 1933 sv_setpvn(toptarget, "", 0); 1934 bodytarget = NEWSV(0,0); 1935 sv_upgrade(bodytarget, SVt_PVFM); 1936 sv_setpvn(bodytarget, "", 0); 1937 formtarget = bodytarget; 1938 1939 tainted = 1; 1940 if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) { 1941 sv_setpv(GvSV(tmpgv),origfilename); 1942 magicname("0", "0", 1); 1943 } 1944 if (tmpgv = gv_fetchpv("\024",TRUE, SVt_PV)) 1945 time(&basetime); 1946 if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV)) 1947 sv_setpv(GvSV(tmpgv),origargv[0]); 1948 if (argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) { 1949 GvMULTI_on(argvgv); 1950 (void)gv_AVadd(argvgv); 1951 av_clear(GvAVn(argvgv)); 1952 for (; argc > 0; argc--,argv++) { 1953 av_push(GvAVn(argvgv),newSVpv(argv[0],0)); 1954 } 1955 } 1956 if (envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) { 1957 HV *hv; 1958 GvMULTI_on(envgv); 1959 hv = GvHVn(envgv); 1960 hv_clear(hv); 1961 #ifndef VMS /* VMS doesn't have environ array */ 1962 /* Note that if the supplied env parameter is actually a copy 1963 of the global environ then it may now point to free'd memory 1964 if the environment has been modified since. To avoid this 1965 problem we treat env==NULL as meaning 'use the default' 1966 */ 1967 if (!env) 1968 env = environ; 1969 if (env != environ) { 1970 environ[0] = Nullch; 1971 hv_magic(hv, envgv, 'E'); 1972 } 1973 for (; *env; env++) { 1974 if (!(s = strchr(*env,'='))) 1975 continue; 1976 *s++ = '\0'; 1977 sv = newSVpv(s--,0); 1978 sv_magic(sv, sv, 'e', *env, s - *env); 1979 (void)hv_store(hv, *env, s - *env, sv, 0); 1980 *s = '='; 1981 } 1982 #endif 1983 #ifdef DYNAMIC_ENV_FETCH 1984 HvNAME(hv) = savepv(ENV_HV_NAME); 1985 #endif 1986 hv_magic(hv, envgv, 'E'); 1987 } 1988 tainted = 0; 1989 if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV)) 1990 sv_setiv(GvSV(tmpgv),(I32)getpid()); 1991 1992 } 1993 1994 static void 1995 init_perllib() 1996 { 1997 char *s; 1998 if (!tainting) { 1999 s = getenv("PERL5LIB"); 2000 if (s) 2001 incpush(s); 2002 else 2003 incpush(getenv("PERLLIB")); 2004 } 2005 2006 #ifdef APPLLIB_EXP 2007 incpush(APPLLIB_EXP); 2008 #endif 2009 2010 #ifdef ARCHLIB_EXP 2011 incpush(ARCHLIB_EXP); 2012 #endif 2013 #ifndef PRIVLIB_EXP 2014 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl" 2015 #endif 2016 incpush(PRIVLIB_EXP); 2017 2018 #ifdef SITEARCH_EXP 2019 incpush(SITEARCH_EXP); 2020 #endif 2021 #ifdef SITELIB_EXP 2022 incpush(SITELIB_EXP); 2023 #endif 2024 #ifdef OLDARCHLIB_EXP /* 5.00[01] compatibility */ 2025 incpush(OLDARCHLIB_EXP); 2026 #endif 2027 2028 if (!tainting) 2029 incpush("."); 2030 } 2031 2032 void 2033 calllist(list) 2034 AV* list; 2035 { 2036 Sigjmp_buf oldtop; 2037 STRLEN len; 2038 line_t oldline = curcop->cop_line; 2039 2040 Copy(top_env, oldtop, 1, Sigjmp_buf); 2041 2042 while (AvFILL(list) >= 0) { 2043 CV *cv = (CV*)av_shift(list); 2044 2045 SAVEFREESV(cv); 2046 2047 switch (Sigsetjmp(top_env,1)) { 2048 case 0: { 2049 SV* atsv = GvSV(errgv); 2050 PUSHMARK(stack_sp); 2051 perl_call_sv((SV*)cv, G_EVAL|G_DISCARD); 2052 (void)SvPV(atsv, len); 2053 if (len) { 2054 Copy(oldtop, top_env, 1, Sigjmp_buf); 2055 curcop = &compiling; 2056 curcop->cop_line = oldline; 2057 if (list == beginav) 2058 sv_catpv(atsv, "BEGIN failed--compilation aborted"); 2059 else 2060 sv_catpv(atsv, "END failed--cleanup aborted"); 2061 croak("%s", SvPVX(atsv)); 2062 } 2063 } 2064 break; 2065 case 1: 2066 #ifdef VMS 2067 statusvalue = 255; /* XXX I don't think we use 1 anymore. */ 2068 #else 2069 statusvalue = 1; 2070 #endif 2071 /* FALL THROUGH */ 2072 case 2: 2073 /* my_exit() was called */ 2074 curstash = defstash; 2075 if (endav) 2076 calllist(endav); 2077 FREETMPS; 2078 Copy(oldtop, top_env, 1, Sigjmp_buf); 2079 curcop = &compiling; 2080 curcop->cop_line = oldline; 2081 if (statusvalue) { 2082 if (list == beginav) 2083 croak("BEGIN failed--compilation aborted"); 2084 else 2085 croak("END failed--cleanup aborted"); 2086 } 2087 my_exit(statusvalue); 2088 /* NOTREACHED */ 2089 return; 2090 case 3: 2091 if (!restartop) { 2092 fprintf(stderr, "panic: restartop\n"); 2093 FREETMPS; 2094 break; 2095 } 2096 Copy(oldtop, top_env, 1, Sigjmp_buf); 2097 curcop = &compiling; 2098 curcop->cop_line = oldline; 2099 Siglongjmp(top_env, 3); 2100 } 2101 } 2102 2103 Copy(oldtop, top_env, 1, Sigjmp_buf); 2104 } 2105 2106