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