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