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