perl.c

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