perl.c

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