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, SvREFCNT_inc((SV*)comppad_name));
 411     av_store(comppadlist, 1, SvREFCNT_inc((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("\nCopyright 1987-1994, Larry Wall\n",stdout);
1000 #ifdef MSDOS
1001         fputs("MS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n",
1002         stdout);
1003 #ifdef OS2
1004         fputs("OS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n",
1005         stdout);
1006 #endif
1007 #endif
1008 #ifdef atarist
1009         fputs("atariST series port, ++jrb  bammi@cadence.com\n", stdout);
1010 #endif
1011         fputs("\n\
1012 Perl may be copied only under the terms of either the Artistic License or the\n\
1013 GNU General Public License, which may be found in the Perl 5.0 source kit.\n",stdout);
1014 #ifdef MSDOS
1015         usage(origargv[0]);
1016 #endif
1017         exit(0);
1018     case 'w':
1019         dowarn = TRUE;
1020         s++;
1021         return s;
1022     case '*':
1023     case ' ':
1024         if (s[1] == '-')        /* Additional switches on #! line. */
1025             return s+2;
1026         break;
1027     case '-':
1028     case 0:
1029     case '\n':
1030     case '\t':
1031         break;
1032     case 'P':
1033         if (preprocess)
1034             return s+1;
1035         /* FALL THROUGH */
1036     default:
1037         croak("Can't emulate -%.1s on #! line",s);
1038     }
1039     return Nullch;
1040 }
1041
1042 /* compliments of Tom Christiansen */
1043
1044 /* unexec() can be found in the Gnu emacs distribution */
1045
1046 void
1047 my_unexec()
1048 {
1049 #ifdef UNEXEC
1050     int    status;
1051     extern int etext;
1052
1053     sprintf (buf, "%s.perldump", origfilename);
1054     sprintf (tokenbuf, "%s/perl", BIN);
1055
1056     status = unexec(buf, tokenbuf, &etext, sbrk(0), 0);
1057     if (status)
1058         fprintf(stderr, "unexec of %s into %s failed!\n", tokenbuf, buf);
1059     exit(status);
1060 #else
1061     ABORT();            /* for use with undump */
1062 #endif
1063 }
1064
1065 static void
1066 init_main_stash()
1067 {
1068     GV *gv;
1069     curstash = defstash = newHV();
1070     curstname = newSVpv("main",4);
1071     gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
1072     SvREFCNT_dec(GvHV(gv));
1073     GvHV(gv) = (HV*)SvREFCNT_inc(defstash);
1074     SvREADONLY_on(gv);
1075     HvNAME(defstash) = savepv("main");
1076     incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
1077     SvMULTI_on(incgv);
1078     defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
1079     curstash = defstash;
1080     compiling.cop_stash = defstash;
1081     debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
1082 }
1083
1084 #ifdef CAN_PROTOTYPE
1085 static void
1086 open_script(char *scriptname, bool dosearch, SV *sv)
1087 #else
1088 static void
1089 open_script(scriptname,dosearch,sv)
1090 char *scriptname;
1091 bool dosearch;
1092 SV *sv;
1093 #endif
1094 {
1095     char *xfound = Nullch;
1096     char *xfailed = Nullch;
1097     register char *s;
1098     I32 len;
1099
1100     if (dosearch && !strchr(scriptname, '/') && (s = getenv("PATH"))) {
1101
1102         bufend = s + strlen(s);
1103         while (*s) {
1104 #ifndef DOSISH
1105             s = cpytill(tokenbuf,s,bufend,':',&len);
1106 #else
1107 #ifdef atarist
1108             for (len = 0; *s && *s != ',' && *s != ';'; tokenbuf[len++] = *s++);
1109             tokenbuf[len] = '\0';
1110 #else
1111             for (len = 0; *s && *s != ';'; tokenbuf[len++] = *s++);
1112             tokenbuf[len] = '\0';
1113 #endif
1114 #endif
1115             if (*s)
1116                 s++;
1117 #ifndef DOSISH
1118             if (len && tokenbuf[len-1] != '/')
1119 #else
1120 #ifdef atarist
1121             if (len && ((tokenbuf[len-1] != '\\') && (tokenbuf[len-1] != '/')))
1122 #else
1123             if (len && tokenbuf[len-1] != '\\')
1124 #endif
1125 #endif
1126                 (void)strcat(tokenbuf+len,"/");
1127             (void)strcat(tokenbuf+len,scriptname);
1128             DEBUG_p(fprintf(stderr,"Looking for %s\n",tokenbuf));
1129             if (Stat(tokenbuf,&statbuf) < 0)            /* not there? */
1130                 continue;
1131             if (S_ISREG(statbuf.st_mode)
1132              && cando(S_IRUSR,TRUE,&statbuf) && cando(S_IXUSR,TRUE,&statbuf)) {
1133                 xfound = tokenbuf;              /* bingo! */
1134                 break;
1135             }
1136             if (!xfailed)
1137                 xfailed = savepv(tokenbuf);
1138         }
1139         if (!xfound)
1140             croak("Can't execute %s", xfailed ? xfailed : scriptname );
1141         if (xfailed)
1142             Safefree(xfailed);
1143         scriptname = xfound;
1144     }
1145
1146     origfilename = savepv(e_fp ? "-e" : scriptname);
1147     curcop->cop_filegv = gv_fetchfile(origfilename);
1148     if (strEQ(origfilename,"-"))
1149         scriptname = "";
1150     if (preprocess) {
1151         char *cpp = CPPSTDIN;
1152
1153         if (strEQ(cpp,"cppstdin"))
1154             sprintf(tokenbuf, "%s/%s", SCRIPTDIR, cpp);
1155         else
1156             sprintf(tokenbuf, "%s", cpp);
1157         sv_catpv(sv,"-I");
1158         sv_catpv(sv,PRIVLIB_EXP);
1159 #ifdef MSDOS
1160         (void)sprintf(buf, "\
1161 sed %s -e \"/^[^#]/b\" \
1162  -e \"/^#[      ]*include[      ]/b\" \
1163  -e \"/^#[      ]*define[       ]/b\" \
1164  -e \"/^#[      ]*if[   ]/b\" \
1165  -e \"/^#[      ]*ifdef[        ]/b\" \
1166  -e \"/^#[      ]*ifndef[       ]/b\" \
1167  -e \"/^#[      ]*else/b\" \
1168  -e \"/^#[      ]*elif[         ]/b\" \
1169  -e \"/^#[      ]*undef[        ]/b\" \
1170  -e \"/^#[      ]*endif/b\" \
1171  -e \"s/^#.*//\" \
1172  %s | %s -C %s %s",
1173           (doextract ? "-e \"1,/^#/d\n\"" : ""),
1174 #else
1175         (void)sprintf(buf, "\
1176 %s %s -e '/^[^#]/b' \
1177  -e '/^#[       ]*include[      ]/b' \
1178  -e '/^#[       ]*define[       ]/b' \
1179  -e '/^#[       ]*if[   ]/b' \
1180  -e '/^#[       ]*ifdef[        ]/b' \
1181  -e '/^#[       ]*ifndef[       ]/b' \
1182  -e '/^#[       ]*else/b' \
1183  -e '/^#[       ]*elif[         ]/b' \
1184  -e '/^#[       ]*undef[        ]/b' \
1185  -e '/^#[       ]*endif/b' \
1186  -e 's/^[       ]*#.*//' \
1187  %s | %s -C %s %s",
1188 #ifdef LOC_SED
1189           LOC_SED,
1190 #else
1191           "sed",
1192 #endif
1193           (doextract ? "-e '1,/^#/d\n'" : ""),
1194 #endif
1195           scriptname, tokenbuf, SvPV(sv, na), CPPMINUS);
1196         doextract = FALSE;
1197 #ifdef IAMSUID                          /* actually, this is caught earlier */
1198         if (euid != uid && !euid) {     /* if running suidperl */
1199 #ifdef HAS_SETEUID
1200             (void)seteuid(uid);         /* musn't stay setuid root */
1201 #else
1202 #ifdef HAS_SETREUID
1203             (void)setreuid((Uid_t)-1, uid);
1204 #else
1205 #ifdef HAS_SETRESUID
1206             (void)setresuid((Uid_t)-1, uid, (Uid_t)-1);
1207 #else
1208             setuid(uid);
1209 #endif
1210 #endif
1211 #endif
1212             if (geteuid() != uid)
1213                 croak("Can't do seteuid!\n");
1214         }
1215 #endif /* IAMSUID */
1216         rsfp = my_popen(buf,"r");
1217     }
1218     else if (!*scriptname) {
1219         taint_not("program input from stdin");
1220         rsfp = stdin;
1221     }
1222     else
1223         rsfp = fopen(scriptname,"r");
1224     if ((FILE*)rsfp == Nullfp) {
1225 #ifdef DOSUID
1226 #ifndef IAMSUID         /* in case script is not readable before setuid */
1227         if (euid && Stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 &&
1228           statbuf.st_mode & (S_ISUID|S_ISGID)) {
1229             (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel);
1230             execv(buf, origargv);       /* try again */
1231             croak("Can't do setuid\n");
1232         }
1233 #endif
1234 #endif
1235         croak("Can't open perl script \"%s\": %s\n",
1236           SvPVX(GvSV(curcop->cop_filegv)), Strerror(errno));
1237     }
1238 }
1239
1240 static void
1241 validate_suid(validarg)
1242 char *validarg;
1243 {
1244     /* do we need to emulate setuid on scripts? */
1245
1246     /* This code is for those BSD systems that have setuid #! scripts disabled
1247      * in the kernel because of a security problem.  Merely defining DOSUID
1248      * in perl will not fix that problem, but if you have disabled setuid
1249      * scripts in the kernel, this will attempt to emulate setuid and setgid
1250      * on scripts that have those now-otherwise-useless bits set.  The setuid
1251      * root version must be called suidperl or sperlN.NNN.  If regular perl
1252      * discovers that it has opened a setuid script, it calls suidperl with
1253      * the same argv that it had.  If suidperl finds that the script it has
1254      * just opened is NOT setuid root, it sets the effective uid back to the
1255      * uid.  We don't just make perl setuid root because that loses the
1256      * effective uid we had before invoking perl, if it was different from the
1257      * uid.
1258      *
1259      * DOSUID must be defined in both perl and suidperl, and IAMSUID must
1260      * be defined in suidperl only.  suidperl must be setuid root.  The
1261      * Configure script will set this up for you if you want it.
1262      */
1263
1264 #ifdef DOSUID
1265     char *s;
1266
1267     if (Fstat(fileno(rsfp),&statbuf) < 0)       /* normal stat is insecure */
1268         croak("Can't stat script \"%s\"",origfilename);
1269     if (statbuf.st_mode & (S_ISUID|S_ISGID)) {
1270         I32 len;
1271
1272 #ifdef IAMSUID
1273 #ifndef HAS_SETREUID
1274         /* On this access check to make sure the directories are readable,
1275          * there is actually a small window that the user could use to make
1276          * filename point to an accessible directory.  So there is a faint
1277          * chance that someone could execute a setuid script down in a
1278          * non-accessible directory.  I don't know what to do about that.
1279          * But I don't think it's too important.  The manual lies when
1280          * it says access() is useful in setuid programs.
1281          */
1282         if (access(SvPVX(GvSV(curcop->cop_filegv)),1))  /*double check*/
1283             croak("Permission denied");
1284 #else
1285         /* If we can swap euid and uid, then we can determine access rights
1286          * with a simple stat of the file, and then compare device and
1287          * inode to make sure we did stat() on the same file we opened.
1288          * Then we just have to make sure he or she can execute it.
1289          */
1290         {
1291             struct stat tmpstatbuf;
1292
1293             if (
1294 #ifdef HAS_SETREUID
1295                 setreuid(euid,uid) < 0
1296 #else
1297 # if HAS_SETRESUID
1298                 setresuid(euid,uid,(Uid_t)-1) < 0
1299 # endif
1300 #endif
1301                 || getuid() != euid || geteuid() != uid)
1302                 croak("Can't swap uid and euid");       /* really paranoid */
1303             if (Stat(SvPVX(GvSV(curcop->cop_filegv)),&tmpstatbuf) < 0)
1304                 croak("Permission denied");     /* testing full pathname here */
1305             if (tmpstatbuf.st_dev != statbuf.st_dev ||
1306                 tmpstatbuf.st_ino != statbuf.st_ino) {
1307                 (void)fclose(rsfp);
1308                 if (rsfp = my_popen("/bin/mail root","w")) {    /* heh, heh */
1309                     fprintf(rsfp,
1310 "User %d tried to run dev %d ino %d in place of dev %d ino %d!\n\
1311 (Filename of set-id script was %s, uid %d gid %d.)\n\nSincerely,\nperl\n",
1312                         uid,tmpstatbuf.st_dev, tmpstatbuf.st_ino,
1313                         statbuf.st_dev, statbuf.st_ino,
1314                         SvPVX(GvSV(curcop->cop_filegv)),
1315                         statbuf.st_uid, statbuf.st_gid);
1316                     (void)my_pclose(rsfp);
1317                 }
1318                 croak("Permission denied\n");
1319             }
1320             if (
1321 #ifdef HAS_SETREUID
1322               setreuid(uid,euid) < 0
1323 #else
1324 # if defined(HAS_SETRESUID)
1325               setresuid(uid,euid,(Uid_t)-1) < 0
1326 # endif
1327 #endif
1328               || getuid() != uid || geteuid() != euid)
1329                 croak("Can't reswap uid and euid");
1330             if (!cando(S_IXUSR,FALSE,&statbuf))         /* can real uid exec? */
1331                 croak("Permission denied\n");
1332         }
1333 #endif /* HAS_SETREUID */
1334 #endif /* IAMSUID */
1335
1336         if (!S_ISREG(statbuf.st_mode))
1337             croak("Permission denied");
1338         if (statbuf.st_mode & S_IWOTH)
1339             croak("Setuid/gid script is writable by world");
1340         doswitches = FALSE;             /* -s is insecure in suid */
1341         curcop->cop_line++;
1342         if (fgets(tokenbuf,sizeof tokenbuf, rsfp) == Nullch ||
1343           strnNE(tokenbuf,"#!",2) )     /* required even on Sys V */
1344             croak("No #! line");
1345         s = tokenbuf+2;
1346         if (*s == ' ') s++;
1347         while (!isSPACE(*s)) s++;
1348         if (strnNE(s-4,"perl",4) && strnNE(s-9,"perl",4))  /* sanity check */
1349             croak("Not a perl script");
1350         while (*s == ' ' || *s == '\t') s++;
1351         /*
1352          * #! arg must be what we saw above.  They can invoke it by
1353          * mentioning suidperl explicitly, but they may not add any strange
1354          * arguments beyond what #! says if they do invoke suidperl that way.
1355          */
1356         len = strlen(validarg);
1357         if (strEQ(validarg," PHOOEY ") ||
1358             strnNE(s,validarg,len) || !isSPACE(s[len]))
1359             croak("Args must match #! line");
1360
1361 #ifndef IAMSUID
1362         if (euid != uid && (statbuf.st_mode & S_ISUID) &&
1363             euid == statbuf.st_uid)
1364             if (!do_undump)
1365                 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
1366 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
1367 #endif /* IAMSUID */
1368
1369         if (euid) {     /* oops, we're not the setuid root perl */
1370             (void)fclose(rsfp);
1371 #ifndef IAMSUID
1372             (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel);
1373             execv(buf, origargv);       /* try again */
1374 #endif
1375             croak("Can't do setuid\n");
1376         }
1377
1378         if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid) {
1379 #ifdef HAS_SETEGID
1380             (void)setegid(statbuf.st_gid);
1381 #else
1382 #ifdef HAS_SETREGID
1383            (void)setregid((Gid_t)-1,statbuf.st_gid);
1384 #else
1385 #ifdef HAS_SETRESGID
1386            (void)setresgid((Gid_t)-1,statbuf.st_gid,(Gid_t)-1);
1387 #else
1388             setgid(statbuf.st_gid);
1389 #endif
1390 #endif
1391 #endif
1392             if (getegid() != statbuf.st_gid)
1393                 croak("Can't do setegid!\n");
1394         }
1395         if (statbuf.st_mode & S_ISUID) {
1396             if (statbuf.st_uid != euid)
1397 #ifdef HAS_SETEUID
1398                 (void)seteuid(statbuf.st_uid);  /* all that for this */
1399 #else
1400 #ifdef HAS_SETREUID
1401                 (void)setreuid((Uid_t)-1,statbuf.st_uid);
1402 #else
1403 #ifdef HAS_SETRESUID
1404                 (void)setresuid((Uid_t)-1,statbuf.st_uid,(Uid_t)-1);
1405 #else
1406                 setuid(statbuf.st_uid);
1407 #endif
1408 #endif
1409 #endif
1410             if (geteuid() != statbuf.st_uid)
1411                 croak("Can't do seteuid!\n");
1412         }
1413         else if (uid) {                 /* oops, mustn't run as root */
1414 #ifdef HAS_SETEUID
1415           (void)seteuid((Uid_t)uid);
1416 #else
1417 #ifdef HAS_SETREUID
1418           (void)setreuid((Uid_t)-1,(Uid_t)uid);
1419 #else
1420 #ifdef HAS_SETRESUID
1421           (void)setresuid((Uid_t)-1,(Uid_t)uid,(Uid_t)-1);
1422 #else
1423           setuid((Uid_t)uid);
1424 #endif
1425 #endif
1426 #endif
1427             if (geteuid() != uid)
1428                 croak("Can't do seteuid!\n");
1429         }
1430         init_ids();
1431         if (!cando(S_IXUSR,TRUE,&statbuf))
1432             croak("Permission denied\n");       /* they can't do this */
1433     }
1434 #ifdef IAMSUID
1435     else if (preprocess)
1436         croak("-P not allowed for setuid/setgid script\n");
1437     else
1438         croak("Script is not setuid/setgid in suidperl\n");
1439 #endif /* IAMSUID */
1440 #else /* !DOSUID */
1441     if (euid != uid || egid != gid) {   /* (suidperl doesn't exist, in fact) */
1442 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
1443         Fstat(fileno(rsfp),&statbuf);   /* may be either wrapped or real suid */
1444         if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
1445             ||
1446             (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
1447            )
1448             if (!do_undump)
1449                 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
1450 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
1451 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
1452         /* not set-id, must be wrapped */
1453     }
1454 #endif /* DOSUID */
1455 }
1456
1457 static void
1458 find_beginning()
1459 {
1460     register char *s;
1461
1462     /* skip forward in input to the real script? */
1463
1464     taint_not("-x");
1465     while (doextract) {
1466         if ((s = sv_gets(linestr, rsfp, 0)) == Nullch)
1467             croak("No Perl script found in input\n");
1468         if (*s == '#' && s[1] == '!' && instr(s,"perl")) {
1469             ungetc('\n',rsfp);          /* to keep line count right */
1470             doextract = FALSE;
1471             if (s = instr(s,"perl -")) {
1472                 s += 6;
1473                 /*SUPPRESS 530*/
1474                 while (s = moreswitches(s)) ;
1475             }
1476             if (cddir && chdir(cddir) < 0)
1477                 croak("Can't chdir to %s",cddir);
1478         }
1479     }
1480 }
1481
1482 static void
1483 init_ids()
1484 {
1485     uid = (int)getuid();
1486     euid = (int)geteuid();
1487     gid = (int)getgid();
1488     egid = (int)getegid();
1489 #ifdef VMS
1490     uid |= gid << 16;
1491     euid |= egid << 16;
1492 #endif
1493     tainting |= (euid != uid || egid != gid);
1494 }
1495
1496 static void
1497 init_debugger()
1498 {
1499     curstash = debstash;
1500     dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
1501     AvREAL_off(dbargs);
1502     DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
1503     DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
1504     DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
1505     DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
1506     DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
1507     DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
1508     curstash = defstash;
1509 }
1510
1511 static void
1512 init_stacks()
1513 {
1514     stack = newAV();
1515     mainstack = stack;                  /* remember in case we switch stacks */
1516     AvREAL_off(stack);                  /* not a real array */
1517     av_extend(stack,127);
1518
1519     stack_base = AvARRAY(stack);
1520     stack_sp = stack_base;
1521     stack_max = stack_base + 127;
1522
1523     New(54,markstack,64,I32);
1524     markstack_ptr = markstack;
1525     markstack_max = markstack + 64;
1526
1527     New(54,scopestack,32,I32);
1528     scopestack_ix = 0;
1529     scopestack_max = 32;
1530
1531     New(54,savestack,128,ANY);
1532     savestack_ix = 0;
1533     savestack_max = 128;
1534
1535     New(54,retstack,16,OP*);
1536     retstack_ix = 0;
1537     retstack_max = 16;
1538
1539     New(50,cxstack,128,CONTEXT);
1540     cxstack_ix  = -1;
1541     cxstack_max = 128;
1542
1543     New(50,tmps_stack,128,SV*);
1544     tmps_ix = -1;
1545     tmps_max = 128;
1546
1547     DEBUG( {
1548         New(51,debname,128,char);
1549         New(52,debdelim,128,char);
1550     } )
1551 }
1552
1553 static FILE *tmpfp;  /* moved outside init_lexer() because of UNICOS bug */
1554 static void
1555 init_lexer()
1556 {
1557     tmpfp = rsfp;
1558
1559     lex_start(linestr);
1560     rsfp = tmpfp;
1561     subname = newSVpv("main",4);
1562 }
1563
1564 static void
1565 init_predump_symbols()
1566 {
1567     GV *tmpgv;
1568     GV *othergv;
1569
1570     sv_setpvn(GvSV(gv_fetchpv("\"", TRUE, SVt_PV)), " ", 1);
1571
1572     stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
1573     SvMULTI_on(stdingv);
1574     IoIFP(GvIOp(stdingv)) = stdin;
1575     tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
1576     GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(stdingv));
1577     SvMULTI_on(tmpgv);
1578
1579     tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
1580     SvMULTI_on(tmpgv);
1581     IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = stdout;
1582     defoutgv = tmpgv;
1583     tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
1584     GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(defoutgv));
1585     SvMULTI_on(tmpgv);
1586
1587     othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
1588     SvMULTI_on(othergv);
1589     IoOFP(GvIOp(othergv)) = IoIFP(GvIOp(othergv)) = stderr;
1590     tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
1591     GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(othergv));
1592     SvMULTI_on(tmpgv);
1593
1594     statname = NEWSV(66,0);             /* last filename we did stat on */
1595 }
1596
1597 static void
1598 init_postdump_symbols(argc,argv,env)
1599 register int argc;
1600 register char **argv;
1601 register char **env;
1602 {
1603     char *s;
1604     SV *sv;
1605     GV* tmpgv;
1606
1607     argc--,argv++;      /* skip name of script */
1608     if (doswitches) {
1609         for (; argc > 0 && **argv == '-'; argc--,argv++) {
1610             if (!argv[0][1])
1611                 break;
1612             if (argv[0][1] == '-') {
1613                 argc--,argv++;
1614                 break;
1615             }
1616             if (s = strchr(argv[0], '=')) {
1617                 *s++ = '\0';
1618                 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
1619             }
1620             else
1621                 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
1622         }
1623     }
1624     toptarget = NEWSV(0,0);
1625     sv_upgrade(toptarget, SVt_PVFM);
1626     sv_setpvn(toptarget, "", 0);
1627     bodytarget = NEWSV(0,0);
1628     sv_upgrade(bodytarget, SVt_PVFM);
1629     sv_setpvn(bodytarget, "", 0);
1630     formtarget = bodytarget;
1631
1632     tainted = 1;
1633     if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
1634         sv_setpv(GvSV(tmpgv),origfilename);
1635         magicname("0", "0", 1);
1636     }
1637     if (tmpgv = gv_fetchpv("\024",TRUE, SVt_PV))
1638         time(&basetime);
1639     if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
1640         sv_setpv(GvSV(tmpgv),origargv[0]);
1641     if (argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
1642         SvMULTI_on(argvgv);
1643         (void)gv_AVadd(argvgv);
1644         av_clear(GvAVn(argvgv));
1645         for (; argc > 0; argc--,argv++) {
1646             av_push(GvAVn(argvgv),newSVpv(argv[0],0));
1647         }
1648     }
1649     if (envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
1650         HV *hv;
1651         SvMULTI_on(envgv);
1652         hv = GvHVn(envgv);
1653         hv_clear(hv);
1654 #ifndef VMS  /* VMS doesn't have environ array */
1655         if (env != environ) {
1656             environ[0] = Nullch;
1657             hv_magic(hv, envgv, 'E');
1658         }
1659 #endif
1660 #ifdef DYNAMIC_ENV_FETCH
1661         HvNAME(hv) = savepv(ENV_HV_NAME);
1662 #endif
1663         for (; *env; env++) {
1664             if (!(s = strchr(*env,'=')))
1665                 continue;
1666             *s++ = '\0';
1667             sv = newSVpv(s--,0);
1668             sv_magic(sv, sv, 'e', *env, s - *env);
1669             (void)hv_store(hv, *env, s - *env, sv, 0);
1670             *s = '=';
1671         }
1672         hv_magic(hv, envgv, 'E');
1673     }
1674     tainted = 0;
1675     if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
1676         sv_setiv(GvSV(tmpgv),(I32)getpid());
1677
1678 }
1679
1680 static void
1681 init_perllib()
1682 {
1683     char *s;
1684     if (!tainting) {
1685         s = getenv("PERL5LIB");
1686         if (s)
1687             incpush(s);
1688         else
1689             incpush(getenv("PERLLIB"));
1690     }
1691
1692 #ifdef ARCHLIB_EXP
1693     incpush(ARCHLIB_EXP);
1694 #endif
1695 #ifndef PRIVLIB_EXP
1696 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
1697 #endif
1698     incpush(PRIVLIB_EXP);
1699
1700     av_push(GvAVn(incgv),newSVpv(".",1));
1701 }
1702
1703 void
1704 calllist(list)
1705 AV* list;
1706 {
1707     jmp_buf oldtop;
1708     STRLEN len;
1709     line_t oldline = curcop->cop_line;
1710
1711     Copy(top_env, oldtop, 1, jmp_buf);
1712
1713     while (AvFILL(list) >= 0) {
1714         CV *cv = (CV*)av_shift(list);
1715
1716         SAVEFREESV(cv);
1717
1718         switch (setjmp(top_env)) {
1719         case 0: {
1720                 SV* atsv = GvSV(gv_fetchpv("@",TRUE, SVt_PV));
1721                 PUSHMARK(stack_sp);
1722                 perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
1723                 (void)SvPV(atsv, len);
1724                 if (len) {
1725                     Copy(oldtop, top_env, 1, jmp_buf);
1726                     curcop = &compiling;
1727                     curcop->cop_line = oldline;
1728                     if (list == beginav)
1729                         sv_catpv(atsv, "BEGIN failed--compilation aborted");
1730                     else
1731                         sv_catpv(atsv, "END failed--cleanup aborted");
1732                     croak("%s", SvPVX(atsv));
1733                 }
1734             }
1735             break;
1736         case 1:
1737 #ifdef VMS
1738             statusvalue = 255;  /* XXX I don't think we use 1 anymore. */
1739 #else
1740         statusvalue = 1;
1741 #endif
1742             /* FALL THROUGH */
1743         case 2:
1744             /* my_exit() was called */
1745             curstash = defstash;
1746             if (endav)
1747                 calllist(endav);
1748             FREETMPS;
1749             Copy(oldtop, top_env, 1, jmp_buf);
1750             curcop = &compiling;
1751             curcop->cop_line = oldline;
1752             if (statusvalue) {
1753                 if (list == beginav)
1754                     croak("BEGIN failed--compilation aborted");
1755                 else
1756                     croak("END failed--cleanup aborted");
1757             }
1758             my_exit(statusvalue);
1759             /* NOTREACHED */
1760             return;
1761         case 3:
1762             if (!restartop) {
1763                 fprintf(stderr, "panic: restartop\n");
1764                 FREETMPS;
1765                 break;
1766             }
1767             Copy(oldtop, top_env, 1, jmp_buf);
1768             curcop = &compiling;
1769             curcop->cop_line = oldline;
1770             longjmp(top_env, 3);
1771         }
1772     }
1773
1774     Copy(oldtop, top_env, 1, jmp_buf);
1775 }
1776