perl.c

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