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