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