perl.c

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