perl.c

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