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