perl.c

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