perl.c

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