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