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 beta3",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
1275 #ifdef VMS
1276     if (dosearch && !strpbrk(scriptname,":[</") && (my_getenv("DCL$PATH"))) {
1277         int idx = 0;
1278
1279         while (my_trnlnm("DCL$PATH",tokenbuf,idx++)) {
1280             strcat(tokenbuf,scriptname);
1281 #else  /* !VMS */
1282     if (dosearch && !strchr(scriptname, '/') && (s = getenv("PATH"))) {
1283
1284         bufend = s + strlen(s);
1285         while (*s) {
1286 #ifndef DOSISH
1287             s = cpytill(tokenbuf,s,bufend,':',&len);
1288 #else
1289 #ifdef atarist
1290             for (len = 0; *s && *s != ',' && *s != ';'; tokenbuf[len++] = *s++);
1291             tokenbuf[len] = '\0';
1292 #else
1293             for (len = 0; *s && *s != ';'; tokenbuf[len++] = *s++);
1294             tokenbuf[len] = '\0';
1295 #endif
1296 #endif
1297             if (*s)
1298                 s++;
1299 #ifndef DOSISH
1300             if (len && tokenbuf[len-1] != '/')
1301 #else
1302 #ifdef atarist
1303             if (len && ((tokenbuf[len-1] != '\\') && (tokenbuf[len-1] != '/')))
1304 #else
1305             if (len && tokenbuf[len-1] != '\\')
1306 #endif
1307 #endif
1308                 (void)strcat(tokenbuf+len,"/");
1309             (void)strcat(tokenbuf+len,scriptname);
1310 #endif  /* !VMS */
1311             DEBUG_p(fprintf(stderr,"Looking for %s\n",tokenbuf));
1312             if (Stat(tokenbuf,&statbuf) < 0)            /* not there? */
1313                 continue;
1314             if (S_ISREG(statbuf.st_mode)
1315              && cando(S_IRUSR,TRUE,&statbuf) && cando(S_IXUSR,TRUE,&statbuf)) {
1316                 xfound = tokenbuf;              /* bingo! */
1317                 break;
1318             }
1319             if (!xfailed)
1320                 xfailed = savepv(tokenbuf);
1321         }
1322         if (!xfound)
1323             croak("Can't execute %s", xfailed ? xfailed : scriptname );
1324         if (xfailed)
1325             Safefree(xfailed);
1326         scriptname = xfound;
1327     }
1328
1329     origfilename = savepv(e_fp ? "-e" : scriptname);
1330     curcop->cop_filegv = gv_fetchfile(origfilename);
1331     if (strEQ(origfilename,"-"))
1332         scriptname = "";
1333     if (preprocess) {
1334         char *cpp = CPPSTDIN;
1335
1336         if (strEQ(cpp,"cppstdin"))
1337             sprintf(tokenbuf, "%s/%s", SCRIPTDIR, cpp);
1338         else
1339             sprintf(tokenbuf, "%s", cpp);
1340         sv_catpv(sv,"-I");
1341         sv_catpv(sv,PRIVLIB_EXP);
1342 #ifdef MSDOS
1343         (void)sprintf(buf, "\
1344 sed %s -e \"/^[^#]/b\" \
1345  -e \"/^#[      ]*include[      ]/b\" \
1346  -e \"/^#[      ]*define[       ]/b\" \
1347  -e \"/^#[      ]*if[   ]/b\" \
1348  -e \"/^#[      ]*ifdef[        ]/b\" \
1349  -e \"/^#[      ]*ifndef[       ]/b\" \
1350  -e \"/^#[      ]*else/b\" \
1351  -e \"/^#[      ]*elif[         ]/b\" \
1352  -e \"/^#[      ]*undef[        ]/b\" \
1353  -e \"/^#[      ]*endif/b\" \
1354  -e \"s/^#.*//\" \
1355  %s | %s -C %s %s",
1356           (doextract ? "-e \"1,/^#/d\n\"" : ""),
1357 #else
1358         (void)sprintf(buf, "\
1359 %s %s -e '/^[^#]/b' \
1360  -e '/^#[       ]*include[      ]/b' \
1361  -e '/^#[       ]*define[       ]/b' \
1362  -e '/^#[       ]*if[   ]/b' \
1363  -e '/^#[       ]*ifdef[        ]/b' \
1364  -e '/^#[       ]*ifndef[       ]/b' \
1365  -e '/^#[       ]*else/b' \
1366  -e '/^#[       ]*elif[         ]/b' \
1367  -e '/^#[       ]*undef[        ]/b' \
1368  -e '/^#[       ]*endif/b' \
1369  -e 's/^[       ]*#.*//' \
1370  %s | %s -C %s %s",
1371 #ifdef LOC_SED
1372           LOC_SED,
1373 #else
1374           "sed",
1375 #endif
1376           (doextract ? "-e '1,/^#/d\n'" : ""),
1377 #endif
1378           scriptname, tokenbuf, SvPV(sv, na), CPPMINUS);
1379         doextract = FALSE;
1380 #ifdef IAMSUID                          /* actually, this is caught earlier */
1381         if (euid != uid && !euid) {     /* if running suidperl */
1382 #ifdef HAS_SETEUID
1383             (void)seteuid(uid);         /* musn't stay setuid root */
1384 #else
1385 #ifdef HAS_SETREUID
1386             (void)setreuid((Uid_t)-1, uid);
1387 #else
1388 #ifdef HAS_SETRESUID
1389             (void)setresuid((Uid_t)-1, uid, (Uid_t)-1);
1390 #else
1391             setuid(uid);
1392 #endif
1393 #endif
1394 #endif
1395             if (geteuid() != uid)
1396                 croak("Can't do seteuid!\n");
1397         }
1398 #endif /* IAMSUID */
1399         rsfp = my_popen(buf,"r");
1400     }
1401     else if (!*scriptname) {
1402         taint_not("program input from stdin");
1403         rsfp = stdin;
1404     }
1405     else
1406         rsfp = fopen(scriptname,"r");
1407     if ((FILE*)rsfp == Nullfp) {
1408 #ifdef DOSUID
1409 #ifndef IAMSUID         /* in case script is not readable before setuid */
1410         if (euid && Stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 &&
1411           statbuf.st_mode & (S_ISUID|S_ISGID)) {
1412             (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel);
1413             execv(buf, origargv);       /* try again */
1414             croak("Can't do setuid\n");
1415         }
1416 #endif
1417 #endif
1418         croak("Can't open perl script \"%s\": %s\n",
1419           SvPVX(GvSV(curcop->cop_filegv)), Strerror(errno));
1420     }
1421 }
1422
1423 static void
1424 validate_suid(validarg)
1425 char *validarg;
1426 {
1427     /* do we need to emulate setuid on scripts? */
1428
1429     /* This code is for those BSD systems that have setuid #! scripts disabled
1430      * in the kernel because of a security problem.  Merely defining DOSUID
1431      * in perl will not fix that problem, but if you have disabled setuid
1432      * scripts in the kernel, this will attempt to emulate setuid and setgid
1433      * on scripts that have those now-otherwise-useless bits set.  The setuid
1434      * root version must be called suidperl or sperlN.NNN.  If regular perl
1435      * discovers that it has opened a setuid script, it calls suidperl with
1436      * the same argv that it had.  If suidperl finds that the script it has
1437      * just opened is NOT setuid root, it sets the effective uid back to the
1438      * uid.  We don't just make perl setuid root because that loses the
1439      * effective uid we had before invoking perl, if it was different from the
1440      * uid.
1441      *
1442      * DOSUID must be defined in both perl and suidperl, and IAMSUID must
1443      * be defined in suidperl only.  suidperl must be setuid root.  The
1444      * Configure script will set this up for you if you want it.
1445      */
1446
1447 #ifdef DOSUID
1448     char *s;
1449
1450     if (Fstat(fileno(rsfp),&statbuf) < 0)       /* normal stat is insecure */
1451         croak("Can't stat script \"%s\"",origfilename);
1452     if (statbuf.st_mode & (S_ISUID|S_ISGID)) {
1453         I32 len;
1454
1455 #ifdef IAMSUID
1456 #ifndef HAS_SETREUID
1457         /* On this access check to make sure the directories are readable,
1458          * there is actually a small window that the user could use to make
1459          * filename point to an accessible directory.  So there is a faint
1460          * chance that someone could execute a setuid script down in a
1461          * non-accessible directory.  I don't know what to do about that.
1462          * But I don't think it's too important.  The manual lies when
1463          * it says access() is useful in setuid programs.
1464          */
1465         if (access(SvPVX(GvSV(curcop->cop_filegv)),1))  /*double check*/
1466             croak("Permission denied");
1467 #else
1468         /* If we can swap euid and uid, then we can determine access rights
1469          * with a simple stat of the file, and then compare device and
1470          * inode to make sure we did stat() on the same file we opened.
1471          * Then we just have to make sure he or she can execute it.
1472          */
1473         {
1474             struct stat tmpstatbuf;
1475
1476             if (
1477 #ifdef HAS_SETREUID
1478                 setreuid(euid,uid) < 0
1479 #else
1480 # if HAS_SETRESUID
1481                 setresuid(euid,uid,(Uid_t)-1) < 0
1482 # endif
1483 #endif
1484                 || getuid() != euid || geteuid() != uid)
1485                 croak("Can't swap uid and euid");       /* really paranoid */
1486             if (Stat(SvPVX(GvSV(curcop->cop_filegv)),&tmpstatbuf) < 0)
1487                 croak("Permission denied");     /* testing full pathname here */
1488             if (tmpstatbuf.st_dev != statbuf.st_dev ||
1489                 tmpstatbuf.st_ino != statbuf.st_ino) {
1490                 (void)fclose(rsfp);
1491                 if (rsfp = my_popen("/bin/mail root","w")) {    /* heh, heh */
1492                     fprintf(rsfp,
1493 "User %d tried to run dev %d ino %d in place of dev %d ino %d!\n\
1494 (Filename of set-id script was %s, uid %d gid %d.)\n\nSincerely,\nperl\n",
1495                         uid,tmpstatbuf.st_dev, tmpstatbuf.st_ino,
1496                         statbuf.st_dev, statbuf.st_ino,
1497                         SvPVX(GvSV(curcop->cop_filegv)),
1498                         statbuf.st_uid, statbuf.st_gid);
1499                     (void)my_pclose(rsfp);
1500                 }
1501                 croak("Permission denied\n");
1502             }
1503             if (
1504 #ifdef HAS_SETREUID
1505               setreuid(uid,euid) < 0
1506 #else
1507 # if defined(HAS_SETRESUID)
1508               setresuid(uid,euid,(Uid_t)-1) < 0
1509 # endif
1510 #endif
1511               || getuid() != uid || geteuid() != euid)
1512                 croak("Can't reswap uid and euid");
1513             if (!cando(S_IXUSR,FALSE,&statbuf))         /* can real uid exec? */
1514                 croak("Permission denied\n");
1515         }
1516 #endif /* HAS_SETREUID */
1517 #endif /* IAMSUID */
1518
1519         if (!S_ISREG(statbuf.st_mode))
1520             croak("Permission denied");
1521         if (statbuf.st_mode & S_IWOTH)
1522             croak("Setuid/gid script is writable by world");
1523         doswitches = FALSE;             /* -s is insecure in suid */
1524         curcop->cop_line++;
1525         if (fgets(tokenbuf,sizeof tokenbuf, rsfp) == Nullch ||
1526           strnNE(tokenbuf,"#!",2) )     /* required even on Sys V */
1527             croak("No #! line");
1528         s = tokenbuf+2;
1529         if (*s == ' ') s++;
1530         while (!isSPACE(*s)) s++;
1531         if (strnNE(s-4,"perl",4) && strnNE(s-9,"perl",4))  /* sanity check */
1532             croak("Not a perl script");
1533         while (*s == ' ' || *s == '\t') s++;
1534         /*
1535          * #! arg must be what we saw above.  They can invoke it by
1536          * mentioning suidperl explicitly, but they may not add any strange
1537          * arguments beyond what #! says if they do invoke suidperl that way.
1538          */
1539         len = strlen(validarg);
1540         if (strEQ(validarg," PHOOEY ") ||
1541             strnNE(s,validarg,len) || !isSPACE(s[len]))
1542             croak("Args must match #! line");
1543
1544 #ifndef IAMSUID
1545         if (euid != uid && (statbuf.st_mode & S_ISUID) &&
1546             euid == statbuf.st_uid)
1547             if (!do_undump)
1548                 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
1549 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
1550 #endif /* IAMSUID */
1551
1552         if (euid) {     /* oops, we're not the setuid root perl */
1553             (void)fclose(rsfp);
1554 #ifndef IAMSUID
1555             (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel);
1556             execv(buf, origargv);       /* try again */
1557 #endif
1558             croak("Can't do setuid\n");
1559         }
1560
1561         if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid) {
1562 #ifdef HAS_SETEGID
1563             (void)setegid(statbuf.st_gid);
1564 #else
1565 #ifdef HAS_SETREGID
1566            (void)setregid((Gid_t)-1,statbuf.st_gid);
1567 #else
1568 #ifdef HAS_SETRESGID
1569            (void)setresgid((Gid_t)-1,statbuf.st_gid,(Gid_t)-1);
1570 #else
1571             setgid(statbuf.st_gid);
1572 #endif
1573 #endif
1574 #endif
1575             if (getegid() != statbuf.st_gid)
1576                 croak("Can't do setegid!\n");
1577         }
1578         if (statbuf.st_mode & S_ISUID) {
1579             if (statbuf.st_uid != euid)
1580 #ifdef HAS_SETEUID
1581                 (void)seteuid(statbuf.st_uid);  /* all that for this */
1582 #else
1583 #ifdef HAS_SETREUID
1584                 (void)setreuid((Uid_t)-1,statbuf.st_uid);
1585 #else
1586 #ifdef HAS_SETRESUID
1587                 (void)setresuid((Uid_t)-1,statbuf.st_uid,(Uid_t)-1);
1588 #else
1589                 setuid(statbuf.st_uid);
1590 #endif
1591 #endif
1592 #endif
1593             if (geteuid() != statbuf.st_uid)
1594                 croak("Can't do seteuid!\n");
1595         }
1596         else if (uid) {                 /* oops, mustn't run as root */
1597 #ifdef HAS_SETEUID
1598           (void)seteuid((Uid_t)uid);
1599 #else
1600 #ifdef HAS_SETREUID
1601           (void)setreuid((Uid_t)-1,(Uid_t)uid);
1602 #else
1603 #ifdef HAS_SETRESUID
1604           (void)setresuid((Uid_t)-1,(Uid_t)uid,(Uid_t)-1);
1605 #else
1606           setuid((Uid_t)uid);
1607 #endif
1608 #endif
1609 #endif
1610             if (geteuid() != uid)
1611                 croak("Can't do seteuid!\n");
1612         }
1613         init_ids();
1614         if (!cando(S_IXUSR,TRUE,&statbuf))
1615             croak("Permission denied\n");       /* they can't do this */
1616     }
1617 #ifdef IAMSUID
1618     else if (preprocess)
1619         croak("-P not allowed for setuid/setgid script\n");
1620     else
1621         croak("Script is not setuid/setgid in suidperl\n");
1622 #endif /* IAMSUID */
1623 #else /* !DOSUID */
1624     if (euid != uid || egid != gid) {   /* (suidperl doesn't exist, in fact) */
1625 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
1626         Fstat(fileno(rsfp),&statbuf);   /* may be either wrapped or real suid */
1627         if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
1628             ||
1629             (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
1630            )
1631             if (!do_undump)
1632                 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
1633 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
1634 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
1635         /* not set-id, must be wrapped */
1636     }
1637 #endif /* DOSUID */
1638 }
1639
1640 static void
1641 find_beginning()
1642 {
1643     register char *s;
1644
1645     /* skip forward in input to the real script? */
1646
1647     taint_not("-x");
1648     while (doextract) {
1649         if ((s = sv_gets(linestr, rsfp, 0)) == Nullch)
1650             croak("No Perl script found in input\n");
1651         if (*s == '#' && s[1] == '!' && instr(s,"perl")) {
1652             ungetc('\n',rsfp);          /* to keep line count right */
1653             doextract = FALSE;
1654             if (s = instr(s,"perl -")) {
1655                 s += 6;
1656                 /*SUPPRESS 530*/
1657                 while (s = moreswitches(s)) ;
1658             }
1659             if (cddir && chdir(cddir) < 0)
1660                 croak("Can't chdir to %s",cddir);
1661         }
1662     }
1663 }
1664
1665 static void
1666 init_ids()
1667 {
1668     uid = (int)getuid();
1669     euid = (int)geteuid();
1670     gid = (int)getgid();
1671     egid = (int)getegid();
1672 #ifdef VMS
1673     uid |= gid << 16;
1674     euid |= egid << 16;
1675 #endif
1676     tainting |= (uid && (euid != uid || egid != gid));
1677 }
1678
1679 static void
1680 init_debugger()
1681 {
1682     curstash = debstash;
1683     dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
1684     AvREAL_off(dbargs);
1685     DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
1686     DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
1687     DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
1688     DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
1689     sv_setiv(DBsingle, 0);
1690     DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
1691     sv_setiv(DBtrace, 0);
1692     DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
1693     sv_setiv(DBsignal, 0);
1694     curstash = defstash;
1695 }
1696
1697 static void
1698 init_stacks()
1699 {
1700     stack = newAV();
1701     mainstack = stack;                  /* remember in case we switch stacks */
1702     AvREAL_off(stack);                  /* not a real array */
1703     av_extend(stack,127);
1704
1705     stack_base = AvARRAY(stack);
1706     stack_sp = stack_base;
1707     stack_max = stack_base + 127;
1708
1709     New(54,markstack,64,I32);
1710     markstack_ptr = markstack;
1711     markstack_max = markstack + 64;
1712
1713     New(54,scopestack,32,I32);
1714     scopestack_ix = 0;
1715     scopestack_max = 32;
1716
1717     New(54,savestack,128,ANY);
1718     savestack_ix = 0;
1719     savestack_max = 128;
1720
1721     New(54,retstack,16,OP*);
1722     retstack_ix = 0;
1723     retstack_max = 16;
1724
1725     New(50,cxstack,128,CONTEXT);
1726     cxstack_ix  = -1;
1727     cxstack_max = 128;
1728
1729     New(50,tmps_stack,128,SV*);
1730     tmps_ix = -1;
1731     tmps_max = 128;
1732
1733     DEBUG( {
1734         New(51,debname,128,char);
1735         New(52,debdelim,128,char);
1736     } )
1737 }
1738
1739 static FILE *tmpfp;  /* moved outside init_lexer() because of UNICOS bug */
1740 static void
1741 init_lexer()
1742 {
1743     tmpfp = rsfp;
1744
1745     lex_start(linestr);
1746     rsfp = tmpfp;
1747     subname = newSVpv("main",4);
1748 }
1749
1750 static void
1751 init_predump_symbols()
1752 {
1753     GV *tmpgv;
1754     GV *othergv;
1755
1756     sv_setpvn(GvSV(gv_fetchpv("\"", TRUE, SVt_PV)), " ", 1);
1757
1758     stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
1759     SvMULTI_on(stdingv);
1760     IoIFP(GvIOp(stdingv)) = stdin;
1761     tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
1762     GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(stdingv));
1763     SvMULTI_on(tmpgv);
1764
1765     tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
1766     SvMULTI_on(tmpgv);
1767     IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = stdout;
1768     setdefout(tmpgv);
1769     tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
1770     GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(defoutgv));
1771     SvMULTI_on(tmpgv);
1772
1773     othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
1774     SvMULTI_on(othergv);
1775     IoOFP(GvIOp(othergv)) = IoIFP(GvIOp(othergv)) = stderr;
1776     tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
1777     GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(othergv));
1778     SvMULTI_on(tmpgv);
1779
1780     statname = NEWSV(66,0);             /* last filename we did stat on */
1781 }
1782
1783 static void
1784 init_postdump_symbols(argc,argv,env)
1785 register int argc;
1786 register char **argv;
1787 register char **env;
1788 {
1789     char *s;
1790     SV *sv;
1791     GV* tmpgv;
1792
1793     argc--,argv++;      /* skip name of script */
1794     if (doswitches) {
1795         for (; argc > 0 && **argv == '-'; argc--,argv++) {
1796             if (!argv[0][1])
1797                 break;
1798             if (argv[0][1] == '-') {
1799                 argc--,argv++;
1800                 break;
1801             }
1802             if (s = strchr(argv[0], '=')) {
1803                 *s++ = '\0';
1804                 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
1805             }
1806             else
1807                 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
1808         }
1809     }
1810     toptarget = NEWSV(0,0);
1811     sv_upgrade(toptarget, SVt_PVFM);
1812     sv_setpvn(toptarget, "", 0);
1813     bodytarget = NEWSV(0,0);
1814     sv_upgrade(bodytarget, SVt_PVFM);
1815     sv_setpvn(bodytarget, "", 0);
1816     formtarget = bodytarget;
1817
1818     tainted = 1;
1819     if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
1820         sv_setpv(GvSV(tmpgv),origfilename);
1821         magicname("0", "0", 1);
1822     }
1823     if (tmpgv = gv_fetchpv("\024",TRUE, SVt_PV))
1824         time(&basetime);
1825     if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
1826         sv_setpv(GvSV(tmpgv),origargv[0]);
1827     if (argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
1828         SvMULTI_on(argvgv);
1829         (void)gv_AVadd(argvgv);
1830         av_clear(GvAVn(argvgv));
1831         for (; argc > 0; argc--,argv++) {
1832             av_push(GvAVn(argvgv),newSVpv(argv[0],0));
1833         }
1834     }
1835     if (envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
1836         HV *hv;
1837         SvMULTI_on(envgv);
1838         hv = GvHVn(envgv);
1839         hv_clear(hv);
1840 #ifndef VMS  /* VMS doesn't have environ array */
1841         /* Note that if the supplied env parameter is actually a copy
1842            of the global environ then it may now point to free'd memory
1843            if the environment has been modified since. To avoid this
1844            problem we treat env==NULL as meaning 'use the default'
1845         */
1846         if (!env)
1847             env = environ;
1848         if (env != environ) {
1849             environ[0] = Nullch;
1850             hv_magic(hv, envgv, 'E');
1851         }
1852         for (; *env; env++) {
1853             if (!(s = strchr(*env,'=')))
1854                 continue;
1855             *s++ = '\0';
1856             sv = newSVpv(s--,0);
1857             sv_magic(sv, sv, 'e', *env, s - *env);
1858             (void)hv_store(hv, *env, s - *env, sv, 0);
1859             *s = '=';
1860         }
1861 #endif
1862 #ifdef DYNAMIC_ENV_FETCH
1863         HvNAME(hv) = savepv(ENV_HV_NAME);
1864 #endif
1865         hv_magic(hv, envgv, 'E');
1866     }
1867     tainted = 0;
1868     if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
1869         sv_setiv(GvSV(tmpgv),(I32)getpid());
1870
1871 }
1872
1873 static void
1874 init_perllib()
1875 {
1876     char *s;
1877     if (!tainting) {
1878         s = getenv("PERL5LIB");
1879         if (s)
1880             incpush(s);
1881         else
1882             incpush(getenv("PERLLIB"));
1883     }
1884
1885 #ifdef APPLLIB_EXP
1886     incpush(APPLLIB_EXP);
1887 #endif
1888
1889 #ifdef ARCHLIB_EXP
1890     incpush(ARCHLIB_EXP);
1891 #endif
1892 #ifndef PRIVLIB_EXP
1893 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
1894 #endif
1895     incpush(PRIVLIB_EXP);
1896
1897 #ifdef SITEARCH_EXP
1898     incpush(SITEARCH_EXP);
1899 #endif
1900 #ifdef SITELIB_EXP
1901     incpush(SITELIB_EXP);
1902 #endif
1903 #ifdef OLDARCHLIB_EXP  /* 5.00[01] compatibility */
1904     incpush(OLDARCHLIB_EXP);
1905 #endif
1906
1907     if (!tainting)
1908         incpush(".");
1909 }
1910
1911 void
1912 calllist(list)
1913 AV* list;
1914 {
1915     jmp_buf oldtop;
1916     STRLEN len;
1917     line_t oldline = curcop->cop_line;
1918
1919     Copy(top_env, oldtop, 1, jmp_buf);
1920
1921     while (AvFILL(list) >= 0) {
1922         CV *cv = (CV*)av_shift(list);
1923
1924         SAVEFREESV(cv);
1925
1926         switch (setjmp(top_env)) {
1927         case 0: {
1928                 SV* atsv = GvSV(errgv);
1929                 PUSHMARK(stack_sp);
1930                 perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
1931                 (void)SvPV(atsv, len);
1932                 if (len) {
1933                     Copy(oldtop, top_env, 1, jmp_buf);
1934                     curcop = &compiling;
1935                     curcop->cop_line = oldline;
1936                     if (list == beginav)
1937                         sv_catpv(atsv, "BEGIN failed--compilation aborted");
1938                     else
1939                         sv_catpv(atsv, "END failed--cleanup aborted");
1940                     croak("%s", SvPVX(atsv));
1941                 }
1942             }
1943             break;
1944         case 1:
1945 #ifdef VMS
1946             statusvalue = 255;  /* XXX I don't think we use 1 anymore. */
1947 #else
1948         statusvalue = 1;
1949 #endif
1950             /* FALL THROUGH */
1951         case 2:
1952             /* my_exit() was called */
1953             curstash = defstash;
1954             if (endav)
1955                 calllist(endav);
1956             FREETMPS;
1957             Copy(oldtop, top_env, 1, jmp_buf);
1958             curcop = &compiling;
1959             curcop->cop_line = oldline;
1960             if (statusvalue) {
1961                 if (list == beginav)
1962                     croak("BEGIN failed--compilation aborted");
1963                 else
1964                     croak("END failed--cleanup aborted");
1965             }
1966             my_exit(statusvalue);
1967             /* NOTREACHED */
1968             return;
1969         case 3:
1970             if (!restartop) {
1971                 fprintf(stderr, "panic: restartop\n");
1972                 FREETMPS;
1973                 break;
1974             }
1975             Copy(oldtop, top_env, 1, jmp_buf);
1976             curcop = &compiling;
1977             curcop->cop_line = oldline;
1978             longjmp(top_env, 3);
1979         }
1980     }
1981
1982     Copy(oldtop, top_env, 1, jmp_buf);
1983 }
1984