perl.c

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