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