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 #ifndef STANDARD_C
 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             op = (OP*)&myop;
 711             pp_leavetry();
 712         }
 713         Copy(oldtop, top_env, 1, jmp_buf);
 714     }
 715     if (flags & G_DISCARD) {
 716         stack_sp = stack_base + oldmark;
 717         retval = 0;
 718         FREETMPS;
 719         LEAVE;
 720     }
 721     return retval;
 722 }
 723
 724 /* Older forms, here grandfathered. */
 725
 726 #ifdef DEPRECATED
 727 I32
 728 perl_callargv(subname, spix, gimme, argv)
 729 char *subname;
 730 register I32 spix;      /* current stack pointer index */
 731 I32 gimme;              /* See G_* flags in cop.h */
 732 register char **argv;   /* null terminated arg list, NULL for no arglist */
 733 {
 734     stack_sp = stack_base + spix;
 735     return spix + perl_call_argv(subname, gimme, argv);
 736 }
 737
 738 I32
 739 perl_callpv(subname, spix, gimme, hasargs, numargs)
 740 char *subname;
 741 I32 spix;               /* stack pointer index after args are pushed */
 742 I32 gimme;              /* See G_* flags in cop.h */
 743 I32 hasargs;            /* whether to create a @_ array for routine */
 744 I32 numargs;            /* how many args are pushed on the stack */
 745 {
 746     stack_sp = stack_base + spix;
 747     PUSHMARK(stack_sp - numargs);
 748     return spix - numargs + perl_call_sv((SV*)perl_get_cv(subname, TRUE),
 749                                 gimme, hasargs, numargs);
 750 }
 751
 752 I32
 753 perl_callsv(sv, spix, gimme, hasargs, numargs)
 754 SV* sv;
 755 I32 spix;               /* stack pointer index after args are pushed */
 756 I32 gimme;              /* See G_* flags in cop.h */
 757 I32 hasargs;            /* whether to create a @_ array for routine */
 758 I32 numargs;            /* how many args are pushed on the stack */
 759 {
 760     stack_sp = stack_base + spix;
 761     PUSHMARK(stack_sp - numargs);
 762     return spix - numargs + perl_call_sv(sv, gimme, hasargs, numargs);
 763 }
 764 #endif
 765
 766 /* Require a module. */
 767
 768 void
 769 perl_requirepv(pv)
 770 char* pv;
 771 {
 772     UNOP myop;          /* fake syntax tree node */
 773     SV* sv;
 774     dSP;
 775
 776     ENTER;
 777     SAVETMPS;
 778     SAVESPTR(op);
 779     sv = sv_newmortal();
 780     sv_setpv(sv, pv);
 781     op = (OP*)&myop;
 782     Zero(op, 1, UNOP);
 783     XPUSHs(sv);
 784
 785     myop.op_type = OP_REQUIRE;
 786     myop.op_next = Nullop;
 787     myop.op_private = 1;
 788     myop.op_flags = OPf_KNOW;
 789
 790     PUTBACK;
 791     if (op = pp_require())
 792         run();
 793     stack_sp--;
 794     FREETMPS;
 795     LEAVE;
 796 }
 797
 798 void
 799 magicname(sym,name,namlen)
 800 char *sym;
 801 char *name;
 802 I32 namlen;
 803 {
 804     register GV *gv;
 805
 806     if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
 807         sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
 808 }
 809
 810 #ifdef DOSISH
 811 #define PERLLIB_SEP ';'
 812 #else
 813 #define PERLLIB_SEP ':'
 814 #endif
 815
 816 static void
 817 incpush(p)
 818 char *p;
 819 {
 820     char *s;
 821
 822     if (!p)
 823         return;
 824
 825     /* Break at all separators */
 826     while (*p) {
 827         /* First, skip any consecutive separators */
 828         while ( *p == PERLLIB_SEP ) {
 829             /* Uncomment the next line for PATH semantics */
 830             /* av_push(GvAVn(incgv), newSVpv(".", 1)); */
 831             p++;
 832         }
 833         if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
 834             av_push(GvAVn(incgv), newSVpv(p, (STRLEN)(s - p)));
 835             p = s + 1;
 836         } else {
 837             av_push(GvAVn(incgv), newSVpv(p, 0));
 838             break;
 839         }
 840     }
 841 }
 842
 843 /* This routine handles any switches that can be given during run */
 844
 845 char *
 846 moreswitches(s)
 847 char *s;
 848 {
 849     I32 numlen;
 850
 851     switch (*s) {
 852     case '0':
 853         nrschar = scan_oct(s, 4, &numlen);
 854         nrs = savepvn("\n",1);
 855         *nrs = nrschar;
 856         if (nrschar > 0377) {
 857             nrslen = 0;
 858             nrs = "";
 859         }
 860         else if (!nrschar && numlen >= 2) {
 861             nrslen = 2;
 862             nrs = "\n\n";
 863             nrschar = '\n';
 864         }
 865         return s + numlen;
 866     case 'F':
 867         minus_F = TRUE;
 868         splitstr = savepv(s + 1);
 869         s += strlen(s);
 870         return s;
 871     case 'a':
 872         minus_a = TRUE;
 873         s++;
 874         return s;
 875     case 'c':
 876         minus_c = TRUE;
 877         s++;
 878         return s;
 879     case 'd':
 880         taint_not("-d");
 881         if (!perldb) {
 882             perldb = TRUE;
 883             init_debugger();
 884         }
 885         s++;
 886         return s;
 887     case 'D':
 888 #ifdef DEBUGGING
 889         taint_not("-D");
 890         if (isALPHA(s[1])) {
 891             static char debopts[] = "psltocPmfrxuLHXD";
 892             char *d;
 893
 894             for (s++; *s && (d = strchr(debopts,*s)); s++)
 895                 debug |= 1 << (d - debopts);
 896         }
 897         else {
 898             debug = atoi(s+1);
 899             for (s++; isDIGIT(*s); s++) ;
 900         }
 901         debug |= 0x80000000;
 902 #else
 903         warn("Recompile perl with -DDEBUGGING to use -D switch\n");
 904         for (s++; isALNUM(*s); s++) ;
 905 #endif
 906         /*SUPPRESS 530*/
 907         return s;
 908     case 'i':
 909         if (inplace)
 910             Safefree(inplace);
 911         inplace = savepv(s+1);
 912         /*SUPPRESS 530*/
 913         for (s = inplace; *s && !isSPACE(*s); s++) ;
 914         *s = '\0';
 915         break;
 916     case 'I':
 917         taint_not("-I");
 918         if (*++s) {
 919             av_push(GvAVn(incgv),newSVpv(s,0));
 920         }
 921         else
 922             croak("No space allowed after -I");
 923         break;
 924     case 'l':
 925         minus_l = TRUE;
 926         s++;
 927         if (ors)
 928             Safefree(ors);
 929         if (isDIGIT(*s)) {
 930             ors = savepv("\n");
 931             orslen = 1;
 932             *ors = scan_oct(s, 3 + (*s == '0'), &numlen);
 933             s += numlen;
 934         }
 935         else {
 936             ors = savepvn(nrs,nrslen);
 937             orslen = nrslen;
 938         }
 939         return s;
 940     case 'n':
 941         minus_n = TRUE;
 942         s++;
 943         return s;
 944     case 'p':
 945         minus_p = TRUE;
 946         s++;
 947         return s;
 948     case 's':
 949         taint_not("-s");
 950         doswitches = TRUE;
 951         s++;
 952         return s;
 953     case 'T':
 954         tainting = TRUE;
 955         s++;
 956         return s;
 957     case 'u':
 958         do_undump = TRUE;
 959         s++;
 960         return s;
 961     case 'U':
 962         unsafe = TRUE;
 963         s++;
 964         return s;
 965     case 'v':
 966         printf("\nThis is perl, version %s\n\n",patchlevel);
 967         fputs("\nCopyright 1987-1994, Larry Wall\n",stdout);
 968 #ifdef MSDOS
 969         fputs("MS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n",
 970         stdout);
 971 #ifdef OS2
 972         fputs("OS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n",
 973         stdout);
 974 #endif
 975 #endif
 976 #ifdef atarist
 977         fputs("atariST series port, ++jrb  bammi@cadence.com\n", stdout);
 978 #endif
 979         fputs("\n\
 980 Perl may be copied only under the terms of either the Artistic License or the\n\
 981 GNU General Public License, which may be found in the Perl 5.0 source kit.\n",stdout);
 982 #ifdef MSDOS
 983         usage(origargv[0]);
 984 #endif
 985         exit(0);
 986     case 'w':
 987         dowarn = TRUE;
 988         s++;
 989         return s;
 990     case '*':
 991     case ' ':
 992         if (s[1] == '-')        /* Additional switches on #! line. */
 993             return s+2;
 994         break;
 995     case '-':
 996     case 0:
 997     case '\n':
 998     case '\t':
 999         break;
1000     case 'P':
1001         if (preprocess)
1002             return s+1;
1003         /* FALL THROUGH */
1004     default:
1005         croak("Can't emulate -%.1s on #! line",s);
1006     }
1007     return Nullch;
1008 }
1009
1010 /* compliments of Tom Christiansen */
1011
1012 /* unexec() can be found in the Gnu emacs distribution */
1013
1014 void
1015 my_unexec()
1016 {
1017 #ifdef UNEXEC
1018     int    status;
1019     extern int etext;
1020
1021     sprintf (buf, "%s.perldump", origfilename);
1022     sprintf (tokenbuf, "%s/perl", BIN);
1023
1024     status = unexec(buf, tokenbuf, &etext, sbrk(0), 0);
1025     if (status)
1026         fprintf(stderr, "unexec of %s into %s failed!\n", tokenbuf, buf);
1027     exit(status);
1028 #else
1029     ABORT();            /* for use with undump */
1030 #endif
1031 }
1032
1033 static void
1034 init_main_stash()
1035 {
1036     GV *gv;
1037     curstash = defstash = newHV();
1038     curstname = newSVpv("main",4);
1039     GvHV(gv = gv_fetchpv("main::",TRUE, SVt_PVHV)) =
1040         (HV*)SvREFCNT_inc(defstash);
1041     SvREADONLY_on(gv);
1042     HvNAME(defstash) = savepv("main");
1043     incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
1044     SvMULTI_on(incgv);
1045     defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
1046     curstash = defstash;
1047     compiling.cop_stash = defstash;
1048     debstash = newHV();
1049     GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV)) = debstash;
1050 }
1051
1052 #ifdef CAN_PROTOTYPE
1053 static void
1054 open_script(char *scriptname, bool dosearch, SV *sv)
1055 #else
1056 static void
1057 open_script(scriptname,dosearch,sv)
1058 char *scriptname;
1059 bool dosearch;
1060 SV *sv;
1061 #endif
1062 {
1063     char *xfound = Nullch;
1064     char *xfailed = Nullch;
1065     register char *s;
1066     I32 len;
1067
1068     if (dosearch && !strchr(scriptname, '/') && (s = getenv("PATH"))) {
1069
1070         bufend = s + strlen(s);
1071         while (*s) {
1072 #ifndef DOSISH
1073             s = cpytill(tokenbuf,s,bufend,':',&len);
1074 #else
1075 #ifdef atarist
1076             for (len = 0; *s && *s != ',' && *s != ';'; tokenbuf[len++] = *s++);
1077             tokenbuf[len] = '\0';
1078 #else
1079             for (len = 0; *s && *s != ';'; tokenbuf[len++] = *s++);
1080             tokenbuf[len] = '\0';
1081 #endif
1082 #endif
1083             if (*s)
1084                 s++;
1085 #ifndef DOSISH
1086             if (len && tokenbuf[len-1] != '/')
1087 #else
1088 #ifdef atarist
1089             if (len && ((tokenbuf[len-1] != '\\') && (tokenbuf[len-1] != '/')))
1090 #else
1091             if (len && tokenbuf[len-1] != '\\')
1092 #endif
1093 #endif
1094                 (void)strcat(tokenbuf+len,"/");
1095             (void)strcat(tokenbuf+len,scriptname);
1096             DEBUG_p(fprintf(stderr,"Looking for %s\n",tokenbuf));
1097             if (Stat(tokenbuf,&statbuf) < 0)            /* not there? */
1098                 continue;
1099             if (S_ISREG(statbuf.st_mode)
1100              && cando(S_IRUSR,TRUE,&statbuf) && cando(S_IXUSR,TRUE,&statbuf)) {
1101                 xfound = tokenbuf;              /* bingo! */
1102                 break;
1103             }
1104             if (!xfailed)
1105                 xfailed = savepv(tokenbuf);
1106         }
1107         if (!xfound)
1108             croak("Can't execute %s", xfailed ? xfailed : scriptname );
1109         if (xfailed)
1110             Safefree(xfailed);
1111         scriptname = xfound;
1112     }
1113
1114     origfilename = savepv(e_fp ? "-e" : scriptname);
1115     curcop->cop_filegv = gv_fetchfile(origfilename);
1116     if (strEQ(origfilename,"-"))
1117         scriptname = "";
1118     if (preprocess) {
1119         char *cpp = CPPSTDIN;
1120
1121         if (strEQ(cpp,"cppstdin"))
1122             sprintf(tokenbuf, "%s/%s", SCRIPTDIR, cpp);
1123         else
1124             sprintf(tokenbuf, "%s", cpp);
1125         sv_catpv(sv,"-I");
1126         sv_catpv(sv,PRIVLIB);
1127 #ifdef MSDOS
1128         (void)sprintf(buf, "\
1129 sed %s -e \"/^[^#]/b\" \
1130  -e \"/^#[      ]*include[      ]/b\" \
1131  -e \"/^#[      ]*define[       ]/b\" \
1132  -e \"/^#[      ]*if[   ]/b\" \
1133  -e \"/^#[      ]*ifdef[        ]/b\" \
1134  -e \"/^#[      ]*ifndef[       ]/b\" \
1135  -e \"/^#[      ]*else/b\" \
1136  -e \"/^#[      ]*elif[         ]/b\" \
1137  -e \"/^#[      ]*undef[        ]/b\" \
1138  -e \"/^#[      ]*endif/b\" \
1139  -e \"s/^#.*//\" \
1140  %s | %s -C %s %s",
1141           (doextract ? "-e \"1,/^#/d\n\"" : ""),
1142 #else
1143         (void)sprintf(buf, "\
1144 %s %s -e '/^[^#]/b' \
1145  -e '/^#[       ]*include[      ]/b' \
1146  -e '/^#[       ]*define[       ]/b' \
1147  -e '/^#[       ]*if[   ]/b' \
1148  -e '/^#[       ]*ifdef[        ]/b' \
1149  -e '/^#[       ]*ifndef[       ]/b' \
1150  -e '/^#[       ]*else/b' \
1151  -e '/^#[       ]*elif[         ]/b' \
1152  -e '/^#[       ]*undef[        ]/b' \
1153  -e '/^#[       ]*endif/b' \
1154  -e 's/^[       ]*#.*//' \
1155  %s | %s -C %s %s",
1156 #ifdef LOC_SED
1157           LOC_SED,
1158 #else
1159           "sed",
1160 #endif
1161           (doextract ? "-e '1,/^#/d\n'" : ""),
1162 #endif
1163           scriptname, tokenbuf, SvPV(sv, na), CPPMINUS);
1164         doextract = FALSE;
1165 #ifdef IAMSUID                          /* actually, this is caught earlier */
1166         if (euid != uid && !euid) {     /* if running suidperl */
1167 #ifdef HAS_SETEUID
1168             (void)seteuid(uid);         /* musn't stay setuid root */
1169 #else
1170 #ifdef HAS_SETREUID
1171             (void)setreuid((Uid_t)-1, uid);
1172 #else
1173 #ifdef HAS_SETRESUID
1174             (void)setresuid((Uid_t)-1, uid, (Uid_t)-1);
1175 #else
1176             setuid(uid);
1177 #endif
1178 #endif
1179 #endif
1180             if (geteuid() != uid)
1181                 croak("Can't do seteuid!\n");
1182         }
1183 #endif /* IAMSUID */
1184         rsfp = my_popen(buf,"r");
1185     }
1186     else if (!*scriptname) {
1187         taint_not("program input from stdin");
1188         rsfp = stdin;
1189     }
1190     else
1191         rsfp = fopen(scriptname,"r");
1192     if ((FILE*)rsfp == Nullfp) {
1193 #ifdef DOSUID
1194 #ifndef IAMSUID         /* in case script is not readable before setuid */
1195         if (euid && Stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 &&
1196           statbuf.st_mode & (S_ISUID|S_ISGID)) {
1197             (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel);
1198             execv(buf, origargv);       /* try again */
1199             croak("Can't do setuid\n");
1200         }
1201 #endif
1202 #endif
1203         croak("Can't open perl script \"%s\": %s\n",
1204           SvPVX(GvSV(curcop->cop_filegv)), Strerror(errno));
1205     }
1206 }
1207
1208 static void
1209 validate_suid(validarg)
1210 char *validarg;
1211 {
1212     /* do we need to emulate setuid on scripts? */
1213
1214     /* This code is for those BSD systems that have setuid #! scripts disabled
1215      * in the kernel because of a security problem.  Merely defining DOSUID
1216      * in perl will not fix that problem, but if you have disabled setuid
1217      * scripts in the kernel, this will attempt to emulate setuid and setgid
1218      * on scripts that have those now-otherwise-useless bits set.  The setuid
1219      * root version must be called suidperl or sperlN.NNN.  If regular perl
1220      * discovers that it has opened a setuid script, it calls suidperl with
1221      * the same argv that it had.  If suidperl finds that the script it has
1222      * just opened is NOT setuid root, it sets the effective uid back to the
1223      * uid.  We don't just make perl setuid root because that loses the
1224      * effective uid we had before invoking perl, if it was different from the
1225      * uid.
1226      *
1227      * DOSUID must be defined in both perl and suidperl, and IAMSUID must
1228      * be defined in suidperl only.  suidperl must be setuid root.  The
1229      * Configure script will set this up for you if you want it.
1230      */
1231
1232 #ifdef DOSUID
1233     char *s;
1234
1235     if (Fstat(fileno(rsfp),&statbuf) < 0)       /* normal stat is insecure */
1236         croak("Can't stat script \"%s\"",origfilename);
1237     if (statbuf.st_mode & (S_ISUID|S_ISGID)) {
1238         I32 len;
1239
1240 #ifdef IAMSUID
1241 #ifndef HAS_SETREUID
1242         /* On this access check to make sure the directories are readable,
1243          * there is actually a small window that the user could use to make
1244          * filename point to an accessible directory.  So there is a faint
1245          * chance that someone could execute a setuid script down in a
1246          * non-accessible directory.  I don't know what to do about that.
1247          * But I don't think it's too important.  The manual lies when
1248          * it says access() is useful in setuid programs.
1249          */
1250         if (access(SvPVX(GvSV(curcop->cop_filegv)),1))  /*double check*/
1251             croak("Permission denied");
1252 #else
1253         /* If we can swap euid and uid, then we can determine access rights
1254          * with a simple stat of the file, and then compare device and
1255          * inode to make sure we did stat() on the same file we opened.
1256          * Then we just have to make sure he or she can execute it.
1257          */
1258         {
1259             struct stat tmpstatbuf;
1260
1261             if (
1262 #ifdef HAS_SETREUID
1263                 setreuid(euid,uid) < 0
1264 #else
1265 # if HAS_SETRESUID
1266                 setresuid(euid,uid,(Uid_t)-1) < 0
1267 # endif
1268 #endif
1269                 || getuid() != euid || geteuid() != uid)
1270                 croak("Can't swap uid and euid");       /* really paranoid */
1271             if (Stat(SvPVX(GvSV(curcop->cop_filegv)),&tmpstatbuf) < 0)
1272                 croak("Permission denied");     /* testing full pathname here */
1273             if (tmpstatbuf.st_dev != statbuf.st_dev ||
1274                 tmpstatbuf.st_ino != statbuf.st_ino) {
1275                 (void)fclose(rsfp);
1276                 if (rsfp = my_popen("/bin/mail root","w")) {    /* heh, heh */
1277                     fprintf(rsfp,
1278 "User %d tried to run dev %d ino %d in place of dev %d ino %d!\n\
1279 (Filename of set-id script was %s, uid %d gid %d.)\n\nSincerely,\nperl\n",
1280                         uid,tmpstatbuf.st_dev, tmpstatbuf.st_ino,
1281                         statbuf.st_dev, statbuf.st_ino,
1282                         SvPVX(GvSV(curcop->cop_filegv)),
1283                         statbuf.st_uid, statbuf.st_gid);
1284                     (void)my_pclose(rsfp);
1285                 }
1286                 croak("Permission denied\n");
1287             }
1288             if (
1289 #ifdef HAS_SETREUID
1290               setreuid(uid,euid) < 0
1291 #else
1292 # if defined(HAS_SETRESUID)
1293               setresuid(uid,euid,(Uid_t)-1) < 0
1294 # endif
1295 #endif
1296               || getuid() != uid || geteuid() != euid)
1297                 croak("Can't reswap uid and euid");
1298             if (!cando(S_IXUSR,FALSE,&statbuf))         /* can real uid exec? */
1299                 croak("Permission denied\n");
1300         }
1301 #endif /* HAS_SETREUID */
1302 #endif /* IAMSUID */
1303
1304         if (!S_ISREG(statbuf.st_mode))
1305             croak("Permission denied");
1306         if (statbuf.st_mode & S_IWOTH)
1307             croak("Setuid/gid script is writable by world");
1308         doswitches = FALSE;             /* -s is insecure in suid */
1309         curcop->cop_line++;
1310         if (fgets(tokenbuf,sizeof tokenbuf, rsfp) == Nullch ||
1311           strnNE(tokenbuf,"#!",2) )     /* required even on Sys V */
1312             croak("No #! line");
1313         s = tokenbuf+2;
1314         if (*s == ' ') s++;
1315         while (!isSPACE(*s)) s++;
1316         if (strnNE(s-4,"perl",4) && strnNE(s-9,"perl",4))  /* sanity check */
1317             croak("Not a perl script");
1318         while (*s == ' ' || *s == '\t') s++;
1319         /*
1320          * #! arg must be what we saw above.  They can invoke it by
1321          * mentioning suidperl explicitly, but they may not add any strange
1322          * arguments beyond what #! says if they do invoke suidperl that way.
1323          */
1324         len = strlen(validarg);
1325         if (strEQ(validarg," PHOOEY ") ||
1326             strnNE(s,validarg,len) || !isSPACE(s[len]))
1327             croak("Args must match #! line");
1328
1329 #ifndef IAMSUID
1330         if (euid != uid && (statbuf.st_mode & S_ISUID) &&
1331             euid == statbuf.st_uid)
1332             if (!do_undump)
1333                 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
1334 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
1335 #endif /* IAMSUID */
1336
1337         if (euid) {     /* oops, we're not the setuid root perl */
1338             (void)fclose(rsfp);
1339 #ifndef IAMSUID
1340             (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel);
1341             execv(buf, origargv);       /* try again */
1342 #endif
1343             croak("Can't do setuid\n");
1344         }
1345
1346         if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid) {
1347 #ifdef HAS_SETEGID
1348             (void)setegid(statbuf.st_gid);
1349 #else
1350 #ifdef HAS_SETREGID
1351            (void)setregid((Gid_t)-1,statbuf.st_gid);
1352 #else
1353 #ifdef HAS_SETRESGID
1354            (void)setresgid((Gid_t)-1,statbuf.st_gid,(Gid_t)-1);
1355 #else
1356             setgid(statbuf.st_gid);
1357 #endif
1358 #endif
1359 #endif
1360             if (getegid() != statbuf.st_gid)
1361                 croak("Can't do setegid!\n");
1362         }
1363         if (statbuf.st_mode & S_ISUID) {
1364             if (statbuf.st_uid != euid)
1365 #ifdef HAS_SETEUID
1366                 (void)seteuid(statbuf.st_uid);  /* all that for this */
1367 #else
1368 #ifdef HAS_SETREUID
1369                 (void)setreuid((Uid_t)-1,statbuf.st_uid);
1370 #else
1371 #ifdef HAS_SETRESUID
1372                 (void)setresuid((Uid_t)-1,statbuf.st_uid,(Uid_t)-1);
1373 #else
1374                 setuid(statbuf.st_uid);
1375 #endif
1376 #endif
1377 #endif
1378             if (geteuid() != statbuf.st_uid)
1379                 croak("Can't do seteuid!\n");
1380         }
1381         else if (uid) {                 /* oops, mustn't run as root */
1382 #ifdef HAS_SETEUID
1383           (void)seteuid((Uid_t)uid);
1384 #else
1385 #ifdef HAS_SETREUID
1386           (void)setreuid((Uid_t)-1,(Uid_t)uid);
1387 #else
1388 #ifdef HAS_SETRESUID
1389           (void)setresuid((Uid_t)-1,(Uid_t)uid,(Uid_t)-1);
1390 #else
1391           setuid((Uid_t)uid);
1392 #endif
1393 #endif
1394 #endif
1395             if (geteuid() != uid)
1396                 croak("Can't do seteuid!\n");
1397         }
1398         uid = (int)getuid();
1399         euid = (int)geteuid();
1400         gid = (int)getgid();
1401         egid = (int)getegid();
1402         tainting |= (euid != uid || egid != gid);
1403         if (!cando(S_IXUSR,TRUE,&statbuf))
1404             croak("Permission denied\n");       /* they can't do this */
1405     }
1406 #ifdef IAMSUID
1407     else if (preprocess)
1408         croak("-P not allowed for setuid/setgid script\n");
1409     else
1410         croak("Script is not setuid/setgid in suidperl\n");
1411 #endif /* IAMSUID */
1412 #else /* !DOSUID */
1413     if (euid != uid || egid != gid) {   /* (suidperl doesn't exist, in fact) */
1414 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
1415         Fstat(fileno(rsfp),&statbuf);   /* may be either wrapped or real suid */
1416         if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
1417             ||
1418             (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
1419            )
1420             if (!do_undump)
1421                 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
1422 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
1423 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
1424         /* not set-id, must be wrapped */
1425     }
1426 #endif /* DOSUID */
1427 }
1428
1429 static void
1430 find_beginning()
1431 {
1432     register char *s;
1433
1434     /* skip forward in input to the real script? */
1435
1436     taint_not("-x");
1437     while (doextract) {
1438         if ((s = sv_gets(linestr, rsfp, 0)) == Nullch)
1439             croak("No Perl script found in input\n");
1440         if (*s == '#' && s[1] == '!' && instr(s,"perl")) {
1441             ungetc('\n',rsfp);          /* to keep line count right */
1442             doextract = FALSE;
1443             if (s = instr(s,"perl -")) {
1444                 s += 6;
1445                 /*SUPPRESS 530*/
1446                 while (s = moreswitches(s)) ;
1447             }
1448             if (cddir && chdir(cddir) < 0)
1449                 croak("Can't chdir to %s",cddir);
1450         }
1451     }
1452 }
1453
1454 static void
1455 init_debugger()
1456 {
1457     GV* tmpgv;
1458
1459     curstash = debstash;
1460     dbargs = GvAV(gv_AVadd((tmpgv = gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
1461     AvREAL_off(dbargs);
1462     DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
1463     DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
1464     DBsub = gv_HVadd(tmpgv = gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
1465     DBsingle = GvSV((tmpgv = gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
1466     DBtrace = GvSV((tmpgv = gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
1467     DBsignal = GvSV((tmpgv = gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
1468     curstash = defstash;
1469 }
1470
1471 static void
1472 init_stacks()
1473 {
1474     stack = newAV();
1475     mainstack = stack;                  /* remember in case we switch stacks */
1476     AvREAL_off(stack);                  /* not a real array */
1477     av_extend(stack,127);
1478
1479     stack_base = AvARRAY(stack);
1480     stack_sp = stack_base;
1481     stack_max = stack_base + 127;
1482
1483     New(54,markstack,64,I32);
1484     markstack_ptr = markstack;
1485     markstack_max = markstack + 64;
1486
1487     New(54,scopestack,32,I32);
1488     scopestack_ix = 0;
1489     scopestack_max = 32;
1490
1491     New(54,savestack,128,ANY);
1492     savestack_ix = 0;
1493     savestack_max = 128;
1494
1495     New(54,retstack,16,OP*);
1496     retstack_ix = 0;
1497     retstack_max = 16;
1498
1499     New(50,cxstack,128,CONTEXT);
1500     cxstack_ix  = -1;
1501     cxstack_max = 128;
1502
1503     New(50,tmps_stack,128,SV*);
1504     tmps_ix = -1;
1505     tmps_max = 128;
1506
1507     DEBUG( {
1508         New(51,debname,128,char);
1509         New(52,debdelim,128,char);
1510     } )
1511 }
1512
1513 static FILE *tmpfp;  /* moved outside init_lexer() because of UNICOS bug */
1514 static void
1515 init_lexer()
1516 {
1517     tmpfp = rsfp;
1518
1519     lex_start(linestr);
1520     rsfp = tmpfp;
1521     subname = newSVpv("main",4);
1522 }
1523
1524 static void
1525 init_predump_symbols()
1526 {
1527     GV *tmpgv;
1528     GV *othergv;
1529
1530     sv_setpvn(GvSV(gv_fetchpv("\"", TRUE, SVt_PV)), " ", 1);
1531
1532     stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
1533     SvMULTI_on(stdingv);
1534     IoIFP(GvIOp(stdingv)) = stdin;
1535     tmpgv = gv_fetchpv("stdin",TRUE, SVt_PVIO);
1536     GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(stdingv));
1537     SvMULTI_on(tmpgv);
1538
1539     tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
1540     SvMULTI_on(tmpgv);
1541     IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = stdout;
1542     defoutgv = tmpgv;
1543     tmpgv = gv_fetchpv("stdout",TRUE, SVt_PVIO);
1544     GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(defoutgv));
1545     SvMULTI_on(tmpgv);
1546
1547     othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
1548     SvMULTI_on(othergv);
1549     IoOFP(GvIOp(othergv)) = IoIFP(GvIOp(othergv)) = stderr;
1550     tmpgv = gv_fetchpv("stderr",TRUE, SVt_PVIO);
1551     GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(othergv));
1552     SvMULTI_on(tmpgv);
1553
1554     statname = NEWSV(66,0);             /* last filename we did stat on */
1555 }
1556
1557 static void
1558 init_postdump_symbols(argc,argv,env)
1559 register int argc;
1560 register char **argv;
1561 register char **env;
1562 {
1563     char *s;
1564     SV *sv;
1565     GV* tmpgv;
1566
1567     argc--,argv++;      /* skip name of script */
1568     if (doswitches) {
1569         for (; argc > 0 && **argv == '-'; argc--,argv++) {
1570             if (!argv[0][1])
1571                 break;
1572             if (argv[0][1] == '-') {
1573                 argc--,argv++;
1574                 break;
1575             }
1576             if (s = strchr(argv[0], '=')) {
1577                 *s++ = '\0';
1578                 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
1579             }
1580             else
1581                 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
1582         }
1583     }
1584     toptarget = NEWSV(0,0);
1585     sv_upgrade(toptarget, SVt_PVFM);
1586     sv_setpvn(toptarget, "", 0);
1587     tmpgv = gv_fetchpv("\001",TRUE, SVt_PV);
1588     bodytarget = GvSV(tmpgv);
1589     sv_upgrade(bodytarget, SVt_PVFM);
1590     sv_setpvn(bodytarget, "", 0);
1591     formtarget = bodytarget;
1592
1593     tainted = 1;
1594     if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
1595         sv_setpv(GvSV(tmpgv),origfilename);
1596         magicname("0", "0", 1);
1597     }
1598     if (tmpgv = gv_fetchpv("\024",TRUE, SVt_PV))
1599         time(&basetime);
1600     if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
1601         sv_setpv(GvSV(tmpgv),origargv[0]);
1602     if (argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
1603         SvMULTI_on(argvgv);
1604         (void)gv_AVadd(argvgv);
1605         av_clear(GvAVn(argvgv));
1606         for (; argc > 0; argc--,argv++) {
1607             av_push(GvAVn(argvgv),newSVpv(argv[0],0));
1608         }
1609     }
1610     if (envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
1611         HV *hv;
1612         SvMULTI_on(envgv);
1613         hv = GvHVn(envgv);
1614         hv_clear(hv);
1615 #ifndef VMS  /* VMS doesn't have environ array */
1616         if (env != environ) {
1617             environ[0] = Nullch;
1618             hv_magic(hv, envgv, 'E');
1619         }
1620 #endif
1621 #ifdef DYNAMIC_ENV_FETCH
1622         HvNAME(hv) = savepv(ENV_HV_NAME);
1623 #endif
1624         for (; *env; env++) {
1625             if (!(s = strchr(*env,'=')))
1626                 continue;
1627             *s++ = '\0';
1628             sv = newSVpv(s--,0);
1629             sv_magic(sv, sv, 'e', *env, s - *env);
1630             (void)hv_store(hv, *env, s - *env, sv, 0);
1631             *s = '=';
1632         }
1633         hv_magic(hv, envgv, 'E');
1634     }
1635     tainted = 0;
1636     if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
1637         sv_setiv(GvSV(tmpgv),(I32)getpid());
1638
1639 }
1640
1641 static void
1642 init_perllib()
1643 {
1644     char *s;
1645     if (!tainting) {
1646         s = getenv("PERL5LIB");
1647         if (s)
1648             incpush(s);
1649         else
1650             incpush(getenv("PERLLIB"));
1651     }
1652
1653 #ifdef ARCHLIB
1654     incpush(ARCHLIB);
1655 #endif
1656 #ifndef PRIVLIB
1657 #define PRIVLIB "/usr/local/lib/perl5:/usr/local/lib/perl"
1658 #endif
1659     incpush(PRIVLIB);
1660
1661     av_push(GvAVn(incgv),newSVpv(".",1));
1662 }
1663
1664 void
1665 calllist(list)
1666 AV* list;
1667 {
1668     jmp_buf oldtop;
1669     char *mess;
1670     STRLEN len;
1671     line_t oldline = curcop->cop_line;
1672
1673     Copy(top_env, oldtop, 1, jmp_buf);
1674
1675     while (AvFILL(list) >= 0) {
1676         CV *cv = (CV*)av_shift(list);
1677
1678         SAVEFREESV(cv);
1679
1680         switch (setjmp(top_env)) {
1681         case 0:
1682             PUSHMARK(stack_sp);
1683             perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
1684             mess = SvPVx(GvSV(gv_fetchpv("@",TRUE, SVt_PV)), len);
1685             if (len) {
1686                 Copy(oldtop, top_env, 1, jmp_buf);
1687                 curcop = &compiling;
1688                 curcop->cop_line = oldline;
1689                 if (list == beginav)
1690                     croak("%sBEGIN failed--compilation aborted", mess);
1691                 else
1692                     croak("%sEND failed--cleanup aborted", mess);
1693             }
1694             break;
1695         case 1:
1696             statusvalue = 255;  /* XXX I don't think we use 1 anymore. */
1697             /* FALL THROUGH */
1698         case 2:
1699             /* my_exit() was called */
1700             curstash = defstash;
1701             if (endav)
1702                 calllist(endav);
1703             FREETMPS;
1704             Copy(oldtop, top_env, 1, jmp_buf);
1705             curcop = &compiling;
1706             curcop->cop_line = oldline;
1707             if (statusvalue) {
1708                 if (list == beginav)
1709                     croak("BEGIN failed--compilation aborted");
1710                 else
1711                     croak("END failed--cleanup aborted");
1712             }
1713             my_exit(statusvalue);
1714             /* NOTREACHED */
1715             return;
1716         case 3:
1717             if (!restartop) {
1718                 fprintf(stderr, "panic: restartop\n");
1719                 FREETMPS;
1720                 break;
1721             }
1722             Copy(oldtop, top_env, 1, jmp_buf);
1723             curcop = &compiling;
1724             curcop->cop_line = oldline;
1725             longjmp(top_env, 3);
1726         }
1727     }
1728
1729     Copy(oldtop, top_env, 1, jmp_buf);
1730 }
1731