perl.c

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