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