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