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