perl.c

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