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