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     dSP;
1136     LOGOP myop;         /* fake syntax tree node */
1137     I32 oldmark;
1138     I32 retval;
1139     I32 oldscope;
1140     static CV *DBcv;
1141     bool oldcatch = CATCH_GET;
1142     dJMPENV;
1143     int ret;
1144     OP* oldop = op;
1145
1146     if (flags & G_DISCARD) {
1147         ENTER;
1148         SAVETMPS;
1149     }
1150
1151     Zero(&myop, 1, LOGOP);
1152     myop.op_next = Nullop;
1153     if (!(flags & G_NOARGS))
1154         myop.op_flags |= OPf_STACKED;
1155     myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1156                       (flags & G_ARRAY) ? OPf_WANT_LIST :
1157                       OPf_WANT_SCALAR);
1158     SAVEOP();
1159     op = (OP*)&myop;
1160
1161     EXTEND(stack_sp, 1);
1162     *++stack_sp = sv;
1163     oldmark = TOPMARK;
1164     oldscope = scopestack_ix;
1165
1166     if (PERLDB_SUB && curstash != debstash
1167            /* Handle first BEGIN of -d. */
1168           && (DBcv || (DBcv = GvCV(DBsub)))
1169            /* Try harder, since this may have been a sighandler, thus
1170             * curstash may be meaningless. */
1171           && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != debstash))
1172         op->op_private |= OPpENTERSUB_DB;
1173
1174     if (flags & G_EVAL) {
1175         cLOGOP->op_other = op;
1176         markstack_ptr--;
1177         /* we're trying to emulate pp_entertry() here */
1178         {
1179             register PERL_CONTEXT *cx;
1180             I32 gimme = GIMME_V;
1181
1182             ENTER;
1183             SAVETMPS;
1184
1185             push_return(op->op_next);
1186             PUSHBLOCK(cx, CXt_EVAL, stack_sp);
1187             PUSHEVAL(cx, 0, 0);
1188             eval_root = op;             /* Only needed so that goto works right. */
1189
1190             in_eval = 1;
1191             if (flags & G_KEEPERR)
1192                 in_eval |= 4;
1193             else
1194                 sv_setpv(ERRSV,"");
1195         }
1196         markstack_ptr++;
1197
1198         JMPENV_PUSH(ret);
1199         switch (ret) {
1200         case 0:
1201             break;
1202         case 1:
1203             STATUS_ALL_FAILURE;
1204             /* FALL THROUGH */
1205         case 2:
1206             /* my_exit() was called */
1207             curstash = defstash;
1208             FREETMPS;
1209             JMPENV_POP;
1210             if (statusvalue)
1211                 croak("Callback called exit");
1212             my_exit_jump();
1213             /* NOTREACHED */
1214         case 3:
1215             if (restartop) {
1216                 op = restartop;
1217                 restartop = 0;
1218                 break;
1219             }
1220             stack_sp = stack_base + oldmark;
1221             if (flags & G_ARRAY)
1222                 retval = 0;
1223             else {
1224                 retval = 1;
1225                 *++stack_sp = &sv_undef;
1226             }
1227             goto cleanup;
1228         }
1229     }
1230     else
1231         CATCH_SET(TRUE);
1232
1233     if (op == (OP*)&myop)
1234         op = pp_entersub(ARGS);
1235     if (op)
1236         runops();
1237     retval = stack_sp - (stack_base + oldmark);
1238     if ((flags & G_EVAL) && !(flags & G_KEEPERR))
1239         sv_setpv(ERRSV,"");
1240
1241   cleanup:
1242     if (flags & G_EVAL) {
1243         if (scopestack_ix > oldscope) {
1244             SV **newsp;
1245             PMOP *newpm;
1246             I32 gimme;
1247             register PERL_CONTEXT *cx;
1248             I32 optype;
1249
1250             POPBLOCK(cx,newpm);
1251             POPEVAL(cx);
1252             pop_return();
1253             curpm = newpm;
1254             LEAVE;
1255         }
1256         JMPENV_POP;
1257     }
1258     else
1259         CATCH_SET(oldcatch);
1260
1261     if (flags & G_DISCARD) {
1262         stack_sp = stack_base + oldmark;
1263         retval = 0;
1264         FREETMPS;
1265         LEAVE;
1266     }
1267     op = oldop;
1268     return retval;
1269 }
1270
1271 /* Eval a string. The G_EVAL flag is always assumed. */
1272
1273 I32
1274 perl_eval_sv(SV *sv, I32 flags)
1275
1276                         /* See G_* flags in cop.h */
1277 {
1278     dSP;
1279     UNOP myop;          /* fake syntax tree node */
1280     I32 oldmark = SP - stack_base;
1281     I32 retval;
1282     I32 oldscope;
1283     dJMPENV;
1284     int ret;
1285     OP* oldop = op;
1286
1287     if (flags & G_DISCARD) {
1288         ENTER;
1289         SAVETMPS;
1290     }
1291
1292     SAVEOP();
1293     op = (OP*)&myop;
1294     Zero(op, 1, UNOP);
1295     EXTEND(stack_sp, 1);
1296     *++stack_sp = sv;
1297     oldscope = scopestack_ix;
1298
1299     if (!(flags & G_NOARGS))
1300         myop.op_flags = OPf_STACKED;
1301     myop.op_next = Nullop;
1302     myop.op_type = OP_ENTEREVAL;
1303     myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1304                       (flags & G_ARRAY) ? OPf_WANT_LIST :
1305                       OPf_WANT_SCALAR);
1306     if (flags & G_KEEPERR)
1307         myop.op_flags |= OPf_SPECIAL;
1308
1309     JMPENV_PUSH(ret);
1310     switch (ret) {
1311     case 0:
1312         break;
1313     case 1:
1314         STATUS_ALL_FAILURE;
1315         /* FALL THROUGH */
1316     case 2:
1317         /* my_exit() was called */
1318         curstash = defstash;
1319         FREETMPS;
1320         JMPENV_POP;
1321         if (statusvalue)
1322             croak("Callback called exit");
1323         my_exit_jump();
1324         /* NOTREACHED */
1325     case 3:
1326         if (restartop) {
1327             op = restartop;
1328             restartop = 0;
1329             break;
1330         }
1331         stack_sp = stack_base + oldmark;
1332         if (flags & G_ARRAY)
1333             retval = 0;
1334         else {
1335             retval = 1;
1336             *++stack_sp = &sv_undef;
1337         }
1338         goto cleanup;
1339     }
1340
1341     if (op == (OP*)&myop)
1342         op = pp_entereval(ARGS);
1343     if (op)
1344         runops();
1345     retval = stack_sp - (stack_base + oldmark);
1346     if (!(flags & G_KEEPERR))
1347         sv_setpv(ERRSV,"");
1348
1349   cleanup:
1350     JMPENV_POP;
1351     if (flags & G_DISCARD) {
1352         stack_sp = stack_base + oldmark;
1353         retval = 0;
1354         FREETMPS;
1355         LEAVE;
1356     }
1357     op = oldop;
1358     return retval;
1359 }
1360
1361 SV*
1362 perl_eval_pv(char *p, I32 croak_on_error)
1363 {
1364     dSP;
1365     SV* sv = newSVpv(p, 0);
1366
1367     PUSHMARK(SP);
1368     perl_eval_sv(sv, G_SCALAR);
1369     SvREFCNT_dec(sv);
1370
1371     SPAGAIN;
1372     sv = POPs;
1373     PUTBACK;
1374
1375     if (croak_on_error && SvTRUE(ERRSV))
1376         croak(SvPVx(ERRSV, na));
1377
1378     return sv;
1379 }
1380
1381 /* Require a module. */
1382
1383 void
1384 perl_require_pv(char *pv)
1385 {
1386     SV* sv = sv_newmortal();
1387     sv_setpv(sv, "require '");
1388     sv_catpv(sv, pv);
1389     sv_catpv(sv, "'");
1390     perl_eval_sv(sv, G_DISCARD);
1391 }
1392
1393 void
1394 magicname(char *sym, char *name, I32 namlen)
1395 {
1396     register GV *gv;
1397
1398     if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
1399         sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
1400 }
1401
1402 static void
1403 usage(char *name)               /* XXX move this out into a module ? */
1404
1405 {
1406     /* This message really ought to be max 23 lines.
1407      * Removed -h because the user already knows that opton. Others? */
1408
1409     static char *usage[] = {
1410 "-0[octal]       specify record separator (\\0, if no argument)",
1411 "-a              autosplit mode with -n or -p (splits $_ into @F)",
1412 "-c              check syntax only (runs BEGIN and END blocks)",
1413 "-d[:debugger]   run scripts under debugger",
1414 "-D[number/list] set debugging flags (argument is a bit mask or flags)",
1415 "-e 'command'    one line of script. Several -e's allowed. Omit [programfile].",
1416 "-F/pattern/     split() pattern for autosplit (-a). The //'s are optional.",
1417 "-i[extension]   edit <> files in place (make backup if extension supplied)",
1418 "-Idirectory     specify @INC/#include directory (may be used more than once)",
1419 "-l[octal]       enable line ending processing, specifies line terminator",
1420 "-[mM][-]module.. executes `use/no module...' before executing your script.",
1421 "-n              assume 'while (<>) { ... }' loop around your script",
1422 "-p              assume loop like -n but print line also like sed",
1423 "-P              run script through C preprocessor before compilation",
1424 "-s              enable some switch parsing for switches after script name",
1425 "-S              look for the script using PATH environment variable",
1426 "-T              turn on tainting checks",
1427 "-u              dump core after parsing script",
1428 "-U              allow unsafe operations",
1429 "-v              print version number and patchlevel of perl",
1430 "-V[:variable]   print perl configuration information",
1431 "-w              TURN WARNINGS ON FOR COMPILATION OF YOUR SCRIPT. Recommended.",
1432 "-x[directory]   strip off text before #!perl line and perhaps cd to directory",
1433 "\n",
1434 NULL
1435 };
1436     char **p = usage;
1437
1438     printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
1439     while (*p)
1440         printf("\n  %s", *p++);
1441 }
1442
1443 /* This routine handles any switches that can be given during run */
1444
1445 char *
1446 moreswitches(char *s)
1447 {
1448     I32 numlen;
1449     U32 rschar;
1450
1451     switch (*s) {
1452     case '0':
1453     {
1454         dTHR;
1455         rschar = scan_oct(s, 4, &numlen);
1456         SvREFCNT_dec(nrs);
1457         if (rschar & ~((U8)~0))
1458             nrs = &sv_undef;
1459         else if (!rschar && numlen >= 2)
1460             nrs = newSVpv("", 0);
1461         else {
1462             char ch = rschar;
1463             nrs = newSVpv(&ch, 1);
1464         }
1465         return s + numlen;
1466     }
1467     case 'F':
1468         minus_F = TRUE;
1469         splitstr = savepv(s + 1);
1470         s += strlen(s);
1471         return s;
1472     case 'a':
1473         minus_a = TRUE;
1474         s++;
1475         return s;
1476     case 'c':
1477         minus_c = TRUE;
1478         s++;
1479         return s;
1480     case 'd':
1481         forbid_setid("-d");
1482         s++;
1483         if (*s == ':' || *s == '=')  {
1484             my_setenv("PERL5DB", form("use Devel::%s;", ++s));
1485             s += strlen(s);
1486         }
1487         if (!perldb) {
1488             perldb = PERLDB_ALL;
1489             init_debugger();
1490         }
1491         return s;
1492     case 'D':
1493 #ifdef DEBUGGING
1494         forbid_setid("-D");
1495         if (isALPHA(s[1])) {
1496             static char debopts[] = "psltocPmfrxuLHXD";
1497             char *d;
1498
1499             for (s++; *s && (d = strchr(debopts,*s)); s++)
1500                 debug |= 1 << (d - debopts);
1501         }
1502         else {
1503             debug = atoi(s+1);
1504             for (s++; isDIGIT(*s); s++) ;
1505         }
1506         debug |= 0x80000000;
1507 #else
1508         warn("Recompile perl with -DDEBUGGING to use -D switch\n");
1509         for (s++; isALNUM(*s); s++) ;
1510 #endif
1511         /*SUPPRESS 530*/
1512         return s;
1513     case 'h':
1514         usage(origargv[0]);
1515         PerlProc_exit(0);
1516     case 'i':
1517         if (inplace)
1518             Safefree(inplace);
1519         inplace = savepv(s+1);
1520         /*SUPPRESS 530*/
1521         for (s = inplace; *s && !isSPACE(*s); s++) ;
1522         if (*s)
1523             *s++ = '\0';
1524         return s;
1525     case 'I':   /* -I handled both here and in parse_perl() */
1526         forbid_setid("-I");
1527         ++s;
1528         while (*s && isSPACE(*s))
1529             ++s;
1530         if (*s) {
1531             char *e, *p;
1532             for (e = s; *e && !isSPACE(*e); e++) ;
1533             p = savepvn(s, e-s);
1534             incpush(p, TRUE);
1535             Safefree(p);
1536             s = e;
1537         }
1538         else
1539             croak("No space allowed after -I");
1540         return s;
1541     case 'l':
1542         minus_l = TRUE;
1543         s++;
1544         if (ors)
1545             Safefree(ors);
1546         if (isDIGIT(*s)) {
1547             ors = savepv("\n");
1548             orslen = 1;
1549             *ors = scan_oct(s, 3 + (*s == '0'), &numlen);
1550             s += numlen;
1551         }
1552         else {
1553             dTHR;
1554             if (RsPARA(nrs)) {
1555                 ors = "\n\n";
1556                 orslen = 2;
1557             }
1558             else
1559                 ors = SvPV(nrs, orslen);
1560             ors = savepvn(ors, orslen);
1561         }
1562         return s;
1563     case 'M':
1564         forbid_setid("-M");     /* XXX ? */
1565         /* FALL THROUGH */
1566     case 'm':
1567         forbid_setid("-m");     /* XXX ? */
1568         if (*++s) {
1569             char *start;
1570             SV *sv;
1571             char *use = "use ";
1572             /* -M-foo == 'no foo'       */
1573             if (*s == '-') { use = "no "; ++s; }
1574             sv = newSVpv(use,0);
1575             start = s;
1576             /* We allow -M'Module qw(Foo Bar)'  */
1577             while(isALNUM(*s) || *s==':') ++s;
1578             if (*s != '=') {
1579                 sv_catpv(sv, start);
1580                 if (*(start-1) == 'm') {
1581                     if (*s != '\0')
1582                         croak("Can't use '%c' after -mname", *s);
1583                     sv_catpv( sv, " ()");
1584                 }
1585             } else {
1586                 sv_catpvn(sv, start, s-start);
1587                 sv_catpv(sv, " split(/,/,q{");
1588                 sv_catpv(sv, ++s);
1589                 sv_catpv(sv,    "})");
1590             }
1591             s += strlen(s);
1592             if (preambleav == NULL)
1593                 preambleav = newAV();
1594             av_push(preambleav, sv);
1595         }
1596         else
1597             croak("No space allowed after -%c", *(s-1));
1598         return s;
1599     case 'n':
1600         minus_n = TRUE;
1601         s++;
1602         return s;
1603     case 'p':
1604         minus_p = TRUE;
1605         s++;
1606         return s;
1607     case 's':
1608         forbid_setid("-s");
1609         doswitches = TRUE;
1610         s++;
1611         return s;
1612     case 'T':
1613         if (!tainting)
1614             croak("Too late for \"-T\" option");
1615         s++;
1616         return s;
1617     case 'u':
1618         do_undump = TRUE;
1619         s++;
1620         return s;
1621     case 'U':
1622         unsafe = TRUE;
1623         s++;
1624         return s;
1625     case 'v':
1626 #if defined(SUBVERSION) && SUBVERSION > 0
1627         printf("\nThis is perl, version 5.%03d_%02d built for %s",
1628             PATCHLEVEL, SUBVERSION, ARCHNAME);
1629 #else
1630         printf("\nThis is perl, version %s built for %s",
1631                 patchlevel, ARCHNAME);
1632 #endif
1633 #if defined(LOCAL_PATCH_COUNT)
1634         if (LOCAL_PATCH_COUNT > 0)
1635             printf("\n(with %d registered patch%s, see perl -V for more detail)",
1636                 LOCAL_PATCH_COUNT, (LOCAL_PATCH_COUNT!=1) ? "es" : "");
1637 #endif
1638
1639         printf("\n\nCopyright 1987-1998, Larry Wall\n");
1640 #ifdef MSDOS
1641         printf("\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
1642 #endif
1643 #ifdef DJGPP
1644         printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
1645         printf("djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1998\n");
1646 #endif
1647 #ifdef OS2
1648         printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
1649             "Version 5 port Copyright (c) 1994-1998, Andreas Kaiser, Ilya Zakharevich\n");
1650 #endif
1651 #ifdef atarist
1652         printf("atariST series port, ++jrb  bammi@cadence.com\n");
1653 #endif
1654         printf("\n\
1655 Perl may be copied only under the terms of either the Artistic License or the\n\
1656 GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n");
1657         PerlProc_exit(0);
1658     case 'w':
1659         dowarn = TRUE;
1660         s++;
1661         return s;
1662     case '*':
1663     case ' ':
1664         if (s[1] == '-')        /* Additional switches on #! line. */
1665             return s+2;
1666         break;
1667     case '-':
1668     case 0:
1669 #ifdef WIN32
1670     case '\r':
1671 #endif
1672     case '\n':
1673     case '\t':
1674         break;
1675 #ifdef ALTERNATE_SHEBANG
1676     case 'S':                   /* OS/2 needs -S on "extproc" line. */
1677         break;
1678 #endif
1679     case 'P':
1680         if (preprocess)
1681             return s+1;
1682         /* FALL THROUGH */
1683     default:
1684         croak("Can't emulate -%.1s on #! line",s);
1685     }
1686     return Nullch;
1687 }
1688
1689 /* compliments of Tom Christiansen */
1690
1691 /* unexec() can be found in the Gnu emacs distribution */
1692
1693 void
1694 my_unexec(void)
1695 {
1696 #ifdef UNEXEC
1697     SV*    prog;
1698     SV*    file;
1699     int    status;
1700     extern int etext;
1701
1702     prog = newSVpv(BIN_EXP);
1703     sv_catpv(prog, "/perl");
1704     file = newSVpv(origfilename);
1705     sv_catpv(file, ".perldump");
1706
1707     status = unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
1708     if (status)
1709         PerlIO_printf(PerlIO_stderr(), "unexec of %s into %s failed!\n",
1710                       SvPVX(prog), SvPVX(file));
1711     PerlProc_exit(status);
1712 #else
1713 #  ifdef VMS
1714 #    include <lib$routines.h>
1715      lib$signal(SS$_DEBUG);  /* ssdef.h #included from vmsish.h */
1716 #  else
1717     ABORT();            /* for use with undump */
1718 #  endif
1719 #endif
1720 }
1721
1722 static void
1723 init_main_stash(void)
1724 {
1725     dTHR;
1726     GV *gv;
1727
1728     /* Note that strtab is a rather special HV.  Assumptions are made
1729        about not iterating on it, and not adding tie magic to it.
1730        It is properly deallocated in perl_destruct() */
1731     strtab = newHV();
1732     HvSHAREKEYS_off(strtab);                    /* mandatory */
1733     Newz(506,((XPVHV*)SvANY(strtab))->xhv_array,
1734          sizeof(HE*) * (((XPVHV*)SvANY(strtab))->xhv_max + 1), char);
1735
1736     curstash = defstash = newHV();
1737     curstname = newSVpv("main",4);
1738     gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
1739     SvREFCNT_dec(GvHV(gv));
1740     GvHV(gv) = (HV*)SvREFCNT_inc(defstash);
1741     SvREADONLY_on(gv);
1742     HvNAME(defstash) = savepv("main");
1743     incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
1744     GvMULTI_on(incgv);
1745     defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
1746     errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
1747     GvMULTI_on(errgv);
1748     (void)form("%240s","");     /* Preallocate temp - for immediate signals. */
1749     sv_grow(ERRSV, 240);        /* Preallocate - for immediate signals. */
1750     sv_setpvn(ERRSV, "", 0);
1751     curstash = defstash;
1752     compiling.cop_stash = defstash;
1753     debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
1754     globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
1755     /* We must init $/ before switches are processed. */
1756     sv_setpvn(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), "\n", 1);
1757 }
1758
1759 static void
1760 open_script(char *scriptname, bool dosearch, SV *sv)
1761 {
1762     dTHR;
1763     char *xfound = Nullch;
1764     char *xfailed = Nullch;
1765     register char *s;
1766     I32 len;
1767     int retval;
1768 #if defined(DOSISH) && !defined(OS2) && !defined(atarist)
1769 #  define SEARCH_EXTS ".bat", ".cmd", NULL
1770 #  define MAX_EXT_LEN 4
1771 #endif
1772 #ifdef OS2
1773 #  define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL
1774 #  define MAX_EXT_LEN 4
1775 #endif
1776 #ifdef VMS
1777 #  define SEARCH_EXTS ".pl", ".com", NULL
1778 #  define MAX_EXT_LEN 4
1779 #endif
1780     /* additional extensions to try in each dir if scriptname not found */
1781 #ifdef SEARCH_EXTS
1782     char *ext[] = { SEARCH_EXTS };
1783     int extidx = 0, i = 0;
1784     char *curext = Nullch;
1785 #else
1786 #  define MAX_EXT_LEN 0
1787 #endif
1788
1789     /*
1790      * If dosearch is true and if scriptname does not contain path
1791      * delimiters, search the PATH for scriptname.
1792      *
1793      * If SEARCH_EXTS is also defined, will look for each
1794      * scriptname{SEARCH_EXTS} whenever scriptname is not found
1795      * while searching the PATH.
1796      *
1797      * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
1798      * proceeds as follows:
1799      *   If DOSISH or VMSISH:
1800      *     + look for ./scriptname{,.foo,.bar}
1801      *     + search the PATH for scriptname{,.foo,.bar}
1802      *
1803      *   If !DOSISH:
1804      *     + look *only* in the PATH for scriptname{,.foo,.bar} (note
1805      *       this will not look in '.' if it's not in the PATH)
1806      */
1807
1808 #ifdef VMS
1809 #  ifdef ALWAYS_DEFTYPES
1810     len = strlen(scriptname);
1811     if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') {
1812         int hasdir, idx = 0, deftypes = 1;
1813         bool seen_dot = 1;
1814
1815         hasdir = !dosearch || (strpbrk(scriptname,":[</") != Nullch) ;
1816 #  else
1817     if (dosearch) {
1818         int hasdir, idx = 0, deftypes = 1;
1819         bool seen_dot = 1;
1820
1821         hasdir = (strpbrk(scriptname,":[</") != Nullch) ;
1822 #  endif
1823         /* The first time through, just add SEARCH_EXTS to whatever we
1824          * already have, so we can check for default file types. */
1825         while (deftypes ||
1826                (!hasdir && my_trnlnm("DCL$PATH",tokenbuf,idx++)) )
1827         {
1828             if (deftypes) {
1829                 deftypes = 0;
1830                 *tokenbuf = '\0';
1831             }
1832             if ((strlen(tokenbuf) + strlen(scriptname)
1833                  + MAX_EXT_LEN) >= sizeof tokenbuf)
1834                 continue;       /* don't search dir with too-long name */
1835             strcat(tokenbuf, scriptname);
1836 #else  /* !VMS */
1837
1838 #ifdef DOSISH
1839     if (strEQ(scriptname, "-"))
1840         dosearch = 0;
1841     if (dosearch) {             /* Look in '.' first. */
1842         char *cur = scriptname;
1843 #ifdef SEARCH_EXTS
1844         if ((curext = strrchr(scriptname,'.'))) /* possible current ext */
1845             while (ext[i])
1846                 if (strEQ(ext[i++],curext)) {
1847                     extidx = -1;                /* already has an ext */
1848                     break;
1849                 }
1850         do {
1851 #endif
1852             DEBUG_p(PerlIO_printf(Perl_debug_log,
1853                                   "Looking for %s\n",cur));
1854             if (Stat(cur,&statbuf) >= 0) {
1855                 dosearch = 0;
1856                 scriptname = cur;
1857 #ifdef SEARCH_EXTS
1858                 break;
1859 #endif
1860             }
1861 #ifdef SEARCH_EXTS
1862             if (cur == scriptname) {
1863                 len = strlen(scriptname);
1864                 if (len+MAX_EXT_LEN+1 >= sizeof(tokenbuf))
1865                     break;
1866                 cur = strcpy(tokenbuf, scriptname);
1867             }
1868         } while (extidx >= 0 && ext[extidx]     /* try an extension? */
1869                  && strcpy(tokenbuf+len, ext[extidx++]));
1870 #endif
1871     }
1872 #endif
1873
1874     if (dosearch && !strchr(scriptname, '/')
1875 #ifdef DOSISH
1876                  && !strchr(scriptname, '\\')
1877 #endif
1878                  && (s = PerlEnv_getenv("PATH"))) {
1879         bool seen_dot = 0;
1880
1881         bufend = s + strlen(s);
1882         while (s < bufend) {
1883 #if defined(atarist) || defined(DOSISH)
1884             for (len = 0; *s
1885 #  ifdef atarist
1886                     && *s != ','
1887 #  endif
1888                     && *s != ';'; len++, s++) {
1889                 if (len < sizeof tokenbuf)
1890                     tokenbuf[len] = *s;
1891             }
1892             if (len < sizeof tokenbuf)
1893                 tokenbuf[len] = '\0';
1894 #else  /* ! (atarist || DOSISH) */
1895             s = delimcpy(tokenbuf, tokenbuf + sizeof tokenbuf, s, bufend,
1896                         ':',
1897                         &len);
1898 #endif /* ! (atarist || DOSISH) */
1899             if (s < bufend)
1900                 s++;
1901             if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tokenbuf)
1902                 continue;       /* don't search dir with too-long name */
1903             if (len
1904 #if defined(atarist) || defined(DOSISH)
1905                 && tokenbuf[len - 1] != '/'
1906                 && tokenbuf[len - 1] != '\\'
1907 #endif
1908                )
1909                 tokenbuf[len++] = '/';
1910             if (len == 2 && tokenbuf[0] == '.')
1911                 seen_dot = 1;
1912             (void)strcpy(tokenbuf + len, scriptname);
1913 #endif  /* !VMS */
1914
1915 #ifdef SEARCH_EXTS
1916             len = strlen(tokenbuf);
1917             if (extidx > 0)     /* reset after previous loop */
1918                 extidx = 0;
1919             do {
1920 #endif
1921                 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tokenbuf));
1922                 retval = Stat(tokenbuf,&statbuf);
1923 #ifdef SEARCH_EXTS
1924             } while (  retval < 0               /* not there */
1925                     && extidx>=0 && ext[extidx] /* try an extension? */
1926                     && strcpy(tokenbuf+len, ext[extidx++])
1927                 );
1928 #endif
1929             if (retval < 0)
1930                 continue;
1931             if (S_ISREG(statbuf.st_mode)
1932                 && cando(S_IRUSR,TRUE,&statbuf)
1933 #ifndef DOSISH
1934                 && cando(S_IXUSR,TRUE,&statbuf)
1935 #endif
1936                 )
1937             {
1938                 xfound = tokenbuf;              /* bingo! */
1939                 break;
1940             }
1941             if (!xfailed)
1942                 xfailed = savepv(tokenbuf);
1943         }
1944 #ifndef DOSISH
1945         if (!xfound && !seen_dot && !xfailed && (Stat(scriptname,&statbuf) < 0))
1946 #endif
1947             seen_dot = 1;                       /* Disable message. */
1948         if (!xfound)
1949             croak("Can't %s %s%s%s",
1950                   (xfailed ? "execute" : "find"),
1951                   (xfailed ? xfailed : scriptname),
1952                   (xfailed ? "" : " on PATH"),
1953                   (xfailed || seen_dot) ? "" : ", '.' not in PATH");
1954         if (xfailed)
1955             Safefree(xfailed);
1956         scriptname = xfound;
1957     }
1958
1959     if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
1960         char *s = scriptname + 8;
1961         fdscript = atoi(s);
1962         while (isDIGIT(*s))
1963             s++;
1964         if (*s)
1965             scriptname = s + 1;
1966     }
1967     else
1968         fdscript = -1;
1969     origfilename = savepv(e_tmpname ? "-e" : scriptname);
1970     curcop->cop_filegv = gv_fetchfile(origfilename);
1971     if (strEQ(origfilename,"-"))
1972         scriptname = "";
1973     if (fdscript >= 0) {
1974         rsfp = PerlIO_fdopen(fdscript,PERL_SCRIPT_MODE);
1975 #if defined(HAS_FCNTL) && defined(F_SETFD)
1976         if (rsfp)
1977             fcntl(PerlIO_fileno(rsfp),F_SETFD,1);  /* ensure close-on-exec */
1978 #endif
1979     }
1980     else if (preprocess) {
1981         char *cpp_cfg = CPPSTDIN;
1982         SV *cpp = NEWSV(0,0);
1983         SV *cmd = NEWSV(0,0);
1984
1985         if (strEQ(cpp_cfg, "cppstdin"))
1986             sv_catpvf(cpp, "%s/", BIN_EXP);
1987         sv_catpv(cpp, cpp_cfg);
1988
1989         sv_catpv(sv,"-I");
1990         sv_catpv(sv,PRIVLIB_EXP);
1991
1992 #ifdef MSDOS
1993         sv_setpvf(cmd, "\
1994 sed %s -e \"/^[^#]/b\" \
1995  -e \"/^#[      ]*include[      ]/b\" \
1996  -e \"/^#[      ]*define[       ]/b\" \
1997  -e \"/^#[      ]*if[   ]/b\" \
1998  -e \"/^#[      ]*ifdef[        ]/b\" \
1999  -e \"/^#[      ]*ifndef[       ]/b\" \
2000  -e \"/^#[      ]*else/b\" \
2001  -e \"/^#[      ]*elif[         ]/b\" \
2002  -e \"/^#[      ]*undef[        ]/b\" \
2003  -e \"/^#[      ]*endif/b\" \
2004  -e \"s/^#.*//\" \
2005  %s | %_ -C %_ %s",
2006           (doextract ? "-e \"1,/^#/d\n\"" : ""),
2007 #else
2008         sv_setpvf(cmd, "\
2009 %s %s -e '/^[^#]/b' \
2010  -e '/^#[       ]*include[      ]/b' \
2011  -e '/^#[       ]*define[       ]/b' \
2012  -e '/^#[       ]*if[   ]/b' \
2013  -e '/^#[       ]*ifdef[        ]/b' \
2014  -e '/^#[       ]*ifndef[       ]/b' \
2015  -e '/^#[       ]*else/b' \
2016  -e '/^#[       ]*elif[         ]/b' \
2017  -e '/^#[       ]*undef[        ]/b' \
2018  -e '/^#[       ]*endif/b' \
2019  -e 's/^[       ]*#.*//' \
2020  %s | %_ -C %_ %s",
2021 #ifdef LOC_SED
2022           LOC_SED,
2023 #else
2024           "sed",
2025 #endif
2026           (doextract ? "-e '1,/^#/d\n'" : ""),
2027 #endif
2028           scriptname, cpp, sv, CPPMINUS);
2029         doextract = FALSE;
2030 #ifdef IAMSUID                          /* actually, this is caught earlier */
2031         if (euid != uid && !euid) {     /* if running suidperl */
2032 #ifdef HAS_SETEUID
2033             (void)seteuid(uid);         /* musn't stay setuid root */
2034 #else
2035 #ifdef HAS_SETREUID
2036             (void)setreuid((Uid_t)-1, uid);
2037 #else
2038 #ifdef HAS_SETRESUID
2039             (void)setresuid((Uid_t)-1, uid, (Uid_t)-1);
2040 #else
2041             setuid(uid);
2042 #endif
2043 #endif
2044 #endif
2045             if (geteuid() != uid)
2046                 croak("Can't do seteuid!\n");
2047         }
2048 #endif /* IAMSUID */
2049         rsfp = PerlProc_popen(SvPVX(cmd), "r");
2050         SvREFCNT_dec(cmd);
2051         SvREFCNT_dec(cpp);
2052     }
2053     else if (!*scriptname) {
2054         forbid_setid("program input from stdin");
2055         rsfp = PerlIO_stdin();
2056     }
2057     else {
2058         rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
2059 #if defined(HAS_FCNTL) && defined(F_SETFD)
2060         if (rsfp)
2061             fcntl(PerlIO_fileno(rsfp),F_SETFD,1);  /* ensure close-on-exec */
2062 #endif
2063     }
2064     if (e_tmpname) {
2065         e_fp = rsfp;
2066     }
2067     if (!rsfp) {
2068 #ifdef DOSUID
2069 #ifndef IAMSUID         /* in case script is not readable before setuid */
2070         if (euid && Stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 &&
2071           statbuf.st_mode & (S_ISUID|S_ISGID)) {
2072             /* try again */
2073             PerlProc_execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
2074             croak("Can't do setuid\n");
2075         }
2076 #endif
2077 #endif
2078         croak("Can't open perl script \"%s\": %s\n",
2079           SvPVX(GvSV(curcop->cop_filegv)), Strerror(errno));
2080     }
2081 }
2082
2083 static void
2084 validate_suid(char *validarg, char *scriptname)
2085 {
2086     int which;
2087
2088     /* do we need to emulate setuid on scripts? */
2089
2090     /* This code is for those BSD systems that have setuid #! scripts disabled
2091      * in the kernel because of a security problem.  Merely defining DOSUID
2092      * in perl will not fix that problem, but if you have disabled setuid
2093      * scripts in the kernel, this will attempt to emulate setuid and setgid
2094      * on scripts that have those now-otherwise-useless bits set.  The setuid
2095      * root version must be called suidperl or sperlN.NNN.  If regular perl
2096      * discovers that it has opened a setuid script, it calls suidperl with
2097      * the same argv that it had.  If suidperl finds that the script it has
2098      * just opened is NOT setuid root, it sets the effective uid back to the
2099      * uid.  We don't just make perl setuid root because that loses the
2100      * effective uid we had before invoking perl, if it was different from the
2101      * uid.
2102      *
2103      * DOSUID must be defined in both perl and suidperl, and IAMSUID must
2104      * be defined in suidperl only.  suidperl must be setuid root.  The
2105      * Configure script will set this up for you if you want it.
2106      */
2107
2108 #ifdef DOSUID
2109     dTHR;
2110     char *s, *s2;
2111
2112     if (PerlLIO_fstat(PerlIO_fileno(rsfp),&statbuf) < 0)        /* normal stat is insecure */
2113         croak("Can't stat script \"%s\"",origfilename);
2114     if (fdscript < 0 && statbuf.st_mode & (S_ISUID|S_ISGID)) {
2115         I32 len;
2116
2117 #ifdef IAMSUID
2118 #ifndef HAS_SETREUID
2119         /* On this access check to make sure the directories are readable,
2120          * there is actually a small window that the user could use to make
2121          * filename point to an accessible directory.  So there is a faint
2122          * chance that someone could execute a setuid script down in a
2123          * non-accessible directory.  I don't know what to do about that.
2124          * But I don't think it's too important.  The manual lies when
2125          * it says access() is useful in setuid programs.
2126          */
2127         if (PerlLIO_access(SvPVX(GvSV(curcop->cop_filegv)),1))  /*double check*/
2128             croak("Permission denied");
2129 #else
2130         /* If we can swap euid and uid, then we can determine access rights
2131          * with a simple stat of the file, and then compare device and
2132          * inode to make sure we did stat() on the same file we opened.
2133          * Then we just have to make sure he or she can execute it.
2134          */
2135         {
2136             struct stat tmpstatbuf;
2137
2138             if (
2139 #ifdef HAS_SETREUID
2140                 setreuid(euid,uid) < 0
2141 #else
2142 # if HAS_SETRESUID
2143                 setresuid(euid,uid,(Uid_t)-1) < 0
2144 # endif
2145 #endif
2146                 || getuid() != euid || geteuid() != uid)
2147                 croak("Can't swap uid and euid");       /* really paranoid */
2148             if (Stat(SvPVX(GvSV(curcop->cop_filegv)),&tmpstatbuf) < 0)
2149                 croak("Permission denied");     /* testing full pathname here */
2150             if (tmpstatbuf.st_dev != statbuf.st_dev ||
2151                 tmpstatbuf.st_ino != statbuf.st_ino) {
2152                 (void)PerlIO_close(rsfp);
2153                 if (rsfp = PerlProc_popen("/bin/mail root","w")) {      /* heh, heh */
2154                     PerlIO_printf(rsfp,
2155 "User %ld tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
2156 (Filename of set-id script was %s, uid %ld gid %ld.)\n\nSincerely,\nperl\n",
2157                         (long)uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
2158                         (long)statbuf.st_dev, (long)statbuf.st_ino,
2159                         SvPVX(GvSV(curcop->cop_filegv)),
2160                         (long)statbuf.st_uid, (long)statbuf.st_gid);
2161                     (void)PerlProc_pclose(rsfp);
2162                 }
2163                 croak("Permission denied\n");
2164             }
2165             if (
2166 #ifdef HAS_SETREUID
2167               setreuid(uid,euid) < 0
2168 #else
2169 # if defined(HAS_SETRESUID)
2170               setresuid(uid,euid,(Uid_t)-1) < 0
2171 # endif
2172 #endif
2173               || getuid() != uid || geteuid() != euid)
2174                 croak("Can't reswap uid and euid");
2175             if (!cando(S_IXUSR,FALSE,&statbuf))         /* can real uid exec? */
2176                 croak("Permission denied\n");
2177         }
2178 #endif /* HAS_SETREUID */
2179 #endif /* IAMSUID */
2180
2181         if (!S_ISREG(statbuf.st_mode))
2182             croak("Permission denied");
2183         if (statbuf.st_mode & S_IWOTH)
2184             croak("Setuid/gid script is writable by world");
2185         doswitches = FALSE;             /* -s is insecure in suid */
2186         curcop->cop_line++;
2187         if (sv_gets(linestr, rsfp, 0) == Nullch ||
2188           strnNE(SvPV(linestr,na),"#!",2) )     /* required even on Sys V */
2189             croak("No #! line");
2190         s = SvPV(linestr,na)+2;
2191         if (*s == ' ') s++;
2192         while (!isSPACE(*s)) s++;
2193         for (s2 = s;  (s2 > SvPV(linestr,na)+2 &&
2194                        (isDIGIT(s2[-1]) || strchr("._-", s2[-1])));  s2--) ;
2195         if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4))  /* sanity check */
2196             croak("Not a perl script");
2197         while (*s == ' ' || *s == '\t') s++;
2198         /*
2199          * #! arg must be what we saw above.  They can invoke it by
2200          * mentioning suidperl explicitly, but they may not add any strange
2201          * arguments beyond what #! says if they do invoke suidperl that way.
2202          */
2203         len = strlen(validarg);
2204         if (strEQ(validarg," PHOOEY ") ||
2205             strnNE(s,validarg,len) || !isSPACE(s[len]))
2206             croak("Args must match #! line");
2207
2208 #ifndef IAMSUID
2209         if (euid != uid && (statbuf.st_mode & S_ISUID) &&
2210             euid == statbuf.st_uid)
2211             if (!do_undump)
2212                 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2213 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2214 #endif /* IAMSUID */
2215
2216         if (euid) {     /* oops, we're not the setuid root perl */
2217             (void)PerlIO_close(rsfp);
2218 #ifndef IAMSUID
2219             /* try again */
2220             PerlProc_execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
2221 #endif
2222             croak("Can't do setuid\n");
2223         }
2224
2225         if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid) {
2226 #ifdef HAS_SETEGID
2227             (void)setegid(statbuf.st_gid);
2228 #else
2229 #ifdef HAS_SETREGID
2230            (void)setregid((Gid_t)-1,statbuf.st_gid);
2231 #else
2232 #ifdef HAS_SETRESGID
2233            (void)setresgid((Gid_t)-1,statbuf.st_gid,(Gid_t)-1);
2234 #else
2235             setgid(statbuf.st_gid);
2236 #endif
2237 #endif
2238 #endif
2239             if (getegid() != statbuf.st_gid)
2240                 croak("Can't do setegid!\n");
2241         }
2242         if (statbuf.st_mode & S_ISUID) {
2243             if (statbuf.st_uid != euid)
2244 #ifdef HAS_SETEUID
2245                 (void)seteuid(statbuf.st_uid);  /* all that for this */
2246 #else
2247 #ifdef HAS_SETREUID
2248                 (void)setreuid((Uid_t)-1,statbuf.st_uid);
2249 #else
2250 #ifdef HAS_SETRESUID
2251                 (void)setresuid((Uid_t)-1,statbuf.st_uid,(Uid_t)-1);
2252 #else
2253                 setuid(statbuf.st_uid);
2254 #endif
2255 #endif
2256 #endif
2257             if (geteuid() != statbuf.st_uid)
2258                 croak("Can't do seteuid!\n");
2259         }
2260         else if (uid) {                 /* oops, mustn't run as root */
2261 #ifdef HAS_SETEUID
2262           (void)seteuid((Uid_t)uid);
2263 #else
2264 #ifdef HAS_SETREUID
2265           (void)setreuid((Uid_t)-1,(Uid_t)uid);
2266 #else
2267 #ifdef HAS_SETRESUID
2268           (void)setresuid((Uid_t)-1,(Uid_t)uid,(Uid_t)-1);
2269 #else
2270           setuid((Uid_t)uid);
2271 #endif
2272 #endif
2273 #endif
2274             if (geteuid() != uid)
2275                 croak("Can't do seteuid!\n");
2276         }
2277         init_ids();
2278         if (!cando(S_IXUSR,TRUE,&statbuf))
2279             croak("Permission denied\n");       /* they can't do this */
2280     }
2281 #ifdef IAMSUID
2282     else if (preprocess)
2283         croak("-P not allowed for setuid/setgid script\n");
2284     else if (fdscript >= 0)
2285         croak("fd script not allowed in suidperl\n");
2286     else
2287         croak("Script is not setuid/setgid in suidperl\n");
2288
2289     /* We absolutely must clear out any saved ids here, so we */
2290     /* exec the real perl, substituting fd script for scriptname. */
2291     /* (We pass script name as "subdir" of fd, which perl will grok.) */
2292     PerlIO_rewind(rsfp);
2293     PerlLIO_lseek(PerlIO_fileno(rsfp),(Off_t)0,0);  /* just in case rewind didn't */
2294     for (which = 1; origargv[which] && origargv[which] != scriptname; which++) ;
2295     if (!origargv[which])
2296         croak("Permission denied");
2297     origargv[which] = savepv(form("/dev/fd/%d/%s",
2298                                   PerlIO_fileno(rsfp), origargv[which]));
2299 #if defined(HAS_FCNTL) && defined(F_SETFD)
2300     fcntl(PerlIO_fileno(rsfp),F_SETFD,0);       /* ensure no close-on-exec */
2301 #endif
2302     PerlProc_execv(form("%s/perl%s", BIN_EXP, patchlevel), origargv);   /* try again */
2303     croak("Can't do setuid\n");
2304 #endif /* IAMSUID */
2305 #else /* !DOSUID */
2306     if (euid != uid || egid != gid) {   /* (suidperl doesn't exist, in fact) */
2307 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
2308         dTHR;
2309         PerlLIO_fstat(PerlIO_fileno(rsfp),&statbuf);    /* may be either wrapped or real suid */
2310         if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
2311             ||
2312             (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
2313            )
2314             if (!do_undump)
2315                 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2316 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2317 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
2318         /* not set-id, must be wrapped */
2319     }
2320 #endif /* DOSUID */
2321 }
2322
2323 static void
2324 find_beginning(void)
2325 {
2326     register char *s, *s2;
2327
2328     /* skip forward in input to the real script? */
2329
2330     forbid_setid("-x");
2331     while (doextract) {
2332         if ((s = sv_gets(linestr, rsfp, 0)) == Nullch)
2333             croak("No Perl script found in input\n");
2334         if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
2335             PerlIO_ungetc(rsfp, '\n');          /* to keep line count right */
2336             doextract = FALSE;
2337             while (*s && !(isSPACE (*s) || *s == '#')) s++;
2338             s2 = s;
2339             while (*s == ' ' || *s == '\t') s++;
2340             if (*s++ == '-') {
2341                 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
2342                 if (strnEQ(s2-4,"perl",4))
2343                     /*SUPPRESS 530*/
2344                     while (s = moreswitches(s)) ;
2345             }
2346             if (cddir && PerlDir_chdir(cddir) < 0)
2347                 croak("Can't chdir to %s",cddir);
2348         }
2349     }
2350 }
2351
2352 static void
2353 init_ids(void)
2354 {
2355     uid = (int)getuid();
2356     euid = (int)geteuid();
2357     gid = (int)getgid();
2358     egid = (int)getegid();
2359 #ifdef VMS
2360     uid |= gid << 16;
2361     euid |= egid << 16;
2362 #endif
2363     tainting |= (uid && (euid != uid || egid != gid));
2364 }
2365
2366 static void
2367 forbid_setid(char *s)
2368 {
2369     if (euid != uid)
2370         croak("No %s allowed while running setuid", s);
2371     if (egid != gid)
2372         croak("No %s allowed while running setgid", s);
2373 }
2374
2375 static void
2376 init_debugger(void)
2377 {
2378     dTHR;
2379     curstash = debstash;
2380     dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
2381     AvREAL_off(dbargs);
2382     DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
2383     DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
2384     DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
2385     DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
2386     sv_setiv(DBsingle, 0);
2387     DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
2388     sv_setiv(DBtrace, 0);
2389     DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
2390     sv_setiv(DBsignal, 0);
2391     curstash = defstash;
2392 }
2393
2394 void
2395 init_stacks(ARGSproto)
2396 {
2397     curstack = newAV();
2398     mainstack = curstack;               /* remember in case we switch stacks */
2399     AvREAL_off(curstack);               /* not a real array */
2400     av_extend(curstack,127);
2401
2402     stack_base = AvARRAY(curstack);
2403     stack_sp = stack_base;
2404     stack_max = stack_base + 127;
2405
2406     cxstack_max = 8192 / sizeof(PERL_CONTEXT) - 2;      /* Use most of 8K. */
2407     New(50,cxstack,cxstack_max + 1,PERL_CONTEXT);
2408     cxstack_ix  = -1;
2409
2410     New(50,tmps_stack,128,SV*);
2411     tmps_floor = -1;
2412     tmps_ix = -1;
2413     tmps_max = 128;
2414
2415     /*
2416      * The following stacks almost certainly should be per-interpreter,
2417      * but for now they're not.  XXX
2418      */
2419
2420     if (markstack) {
2421         markstack_ptr = markstack;
2422     } else {
2423         New(54,markstack,64,I32);
2424         markstack_ptr = markstack;
2425         markstack_max = markstack + 64;
2426     }
2427
2428     if (scopestack) {
2429         scopestack_ix = 0;
2430     } else {
2431         New(54,scopestack,32,I32);
2432         scopestack_ix = 0;
2433         scopestack_max = 32;
2434     }
2435
2436     if (savestack) {
2437         savestack_ix = 0;
2438     } else {
2439         New(54,savestack,128,ANY);
2440         savestack_ix = 0;
2441         savestack_max = 128;
2442     }
2443
2444     if (retstack) {
2445         retstack_ix = 0;
2446     } else {
2447         New(54,retstack,16,OP*);
2448         retstack_ix = 0;
2449         retstack_max = 16;
2450     }
2451 }
2452
2453 static void
2454 nuke_stacks(void)
2455 {
2456     dTHR;
2457     Safefree(cxstack);
2458     Safefree(tmps_stack);
2459     DEBUG( {
2460         Safefree(debname);
2461         Safefree(debdelim);
2462     } )
2463 }
2464
2465 static PerlIO *tmpfp;  /* moved outside init_lexer() because of UNICOS bug */
2466
2467 static void
2468 init_lexer(void)
2469 {
2470     tmpfp = rsfp;
2471     rsfp = Nullfp;
2472     lex_start(linestr);
2473     rsfp = tmpfp;
2474     subname = newSVpv("main",4);
2475 }
2476
2477 static void
2478 init_predump_symbols(void)
2479 {
2480     dTHR;
2481     GV *tmpgv;
2482     GV *othergv;
2483
2484     sv_setpvn(perl_get_sv("\"", TRUE), " ", 1);
2485     stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
2486     GvMULTI_on(stdingv);
2487     IoIFP(GvIOp(stdingv)) = PerlIO_stdin();
2488     tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
2489     GvMULTI_on(tmpgv);
2490     GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(stdingv));
2491
2492     tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
2493     GvMULTI_on(tmpgv);
2494     IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = PerlIO_stdout();
2495     setdefout(tmpgv);
2496     tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
2497     GvMULTI_on(tmpgv);
2498     GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(defoutgv));
2499
2500     othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
2501     GvMULTI_on(othergv);
2502     IoOFP(GvIOp(othergv)) = IoIFP(GvIOp(othergv)) = PerlIO_stderr();
2503     tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
2504     GvMULTI_on(tmpgv);
2505     GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(othergv));
2506
2507     statname = NEWSV(66,0);             /* last filename we did stat on */
2508
2509     if (!osname)
2510         osname = savepv(OSNAME);
2511 }
2512
2513 static void
2514 init_postdump_symbols(register int argc, register char **argv, register char **env)
2515 {
2516     dTHR;
2517     char *s;
2518     SV *sv;
2519     GV* tmpgv;
2520
2521     argc--,argv++;      /* skip name of script */
2522     if (doswitches) {
2523         for (; argc > 0 && **argv == '-'; argc--,argv++) {
2524             if (!argv[0][1])
2525                 break;
2526             if (argv[0][1] == '-') {
2527                 argc--,argv++;
2528                 break;
2529             }
2530             if (s = strchr(argv[0], '=')) {
2531                 *s++ = '\0';
2532                 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
2533             }
2534             else
2535                 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
2536         }
2537     }
2538     toptarget = NEWSV(0,0);
2539     sv_upgrade(toptarget, SVt_PVFM);
2540     sv_setpvn(toptarget, "", 0);
2541     bodytarget = NEWSV(0,0);
2542     sv_upgrade(bodytarget, SVt_PVFM);
2543     sv_setpvn(bodytarget, "", 0);
2544     formtarget = bodytarget;
2545
2546     TAINT;
2547     if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
2548         sv_setpv(GvSV(tmpgv),origfilename);
2549         magicname("0", "0", 1);
2550     }
2551     if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
2552         sv_setpv(GvSV(tmpgv),origargv[0]);
2553     if (argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
2554         GvMULTI_on(argvgv);
2555         (void)gv_AVadd(argvgv);
2556         av_clear(GvAVn(argvgv));
2557         for (; argc > 0; argc--,argv++) {
2558             av_push(GvAVn(argvgv),newSVpv(argv[0],0));
2559         }
2560     }
2561     if (envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
2562         HV *hv;
2563         GvMULTI_on(envgv);
2564         hv = GvHVn(envgv);
2565         hv_magic(hv, envgv, 'E');
2566 #ifndef VMS  /* VMS doesn't have environ array */
2567         /* Note that if the supplied env parameter is actually a copy
2568            of the global environ then it may now point to free'd memory
2569            if the environment has been modified since. To avoid this
2570            problem we treat env==NULL as meaning 'use the default'
2571         */
2572         if (!env)
2573             env = environ;
2574         if (env != environ)
2575             environ[0] = Nullch;
2576         for (; *env; env++) {
2577             if (!(s = strchr(*env,'=')))
2578                 continue;
2579             *s++ = '\0';
2580 #if defined(WIN32) || defined(MSDOS)
2581             (void)strupr(*env);
2582 #endif
2583             sv = newSVpv(s--,0);
2584             (void)hv_store(hv, *env, s - *env, sv, 0);
2585             *s = '=';
2586 #if defined(__BORLANDC__) && defined(USE_WIN32_RTL_ENV)
2587             /* Sins of the RTL. See note in my_setenv(). */
2588             (void)PerlEnv_putenv(savepv(*env));
2589 #endif
2590         }
2591 #endif
2592 #ifdef DYNAMIC_ENV_FETCH
2593         HvNAME(hv) = savepv(ENV_HV_NAME);
2594 #endif
2595     }
2596     TAINT_NOT;
2597     if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
2598         sv_setiv(GvSV(tmpgv), (IV)getpid());
2599 }
2600
2601 static void
2602 init_perllib(void)
2603 {
2604     char *s;
2605     if (!tainting) {
2606 #ifndef VMS
2607         s = PerlEnv_getenv("PERL5LIB");
2608         if (s)
2609             incpush(s, TRUE);
2610         else
2611             incpush(PerlEnv_getenv("PERLLIB"), FALSE);
2612 #else /* VMS */
2613         /* Treat PERL5?LIB as a possible search list logical name -- the
2614          * "natural" VMS idiom for a Unix path string.  We allow each
2615          * element to be a set of |-separated directories for compatibility.
2616          */
2617         char buf[256];
2618         int idx = 0;
2619         if (my_trnlnm("PERL5LIB",buf,0))
2620             do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
2621         else
2622             while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
2623 #endif /* VMS */
2624     }
2625
2626 /* Use the ~-expanded versions of APPLLIB (undocumented),
2627     ARCHLIB PRIVLIB SITEARCH and SITELIB
2628 */
2629 #ifdef APPLLIB_EXP
2630     incpush(APPLLIB_EXP, FALSE);
2631 #endif
2632
2633 #ifdef ARCHLIB_EXP
2634     incpush(ARCHLIB_EXP, FALSE);
2635 #endif
2636 #ifndef PRIVLIB_EXP
2637 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
2638 #endif
2639     incpush(PRIVLIB_EXP, FALSE);
2640
2641 #ifdef SITEARCH_EXP
2642     incpush(SITEARCH_EXP, FALSE);
2643 #endif
2644 #ifdef SITELIB_EXP
2645     incpush(SITELIB_EXP, FALSE);
2646 #endif
2647     if (!tainting)
2648         incpush(".", FALSE);
2649 }
2650
2651 #if defined(DOSISH)
2652 #    define PERLLIB_SEP ';'
2653 #else
2654 #  if defined(VMS)
2655 #    define PERLLIB_SEP '|'
2656 #  else
2657 #    define PERLLIB_SEP ':'
2658 #  endif
2659 #endif
2660 #ifndef PERLLIB_MANGLE
2661 #  define PERLLIB_MANGLE(s,n) (s)
2662 #endif
2663
2664 static void
2665 incpush(char *p, int addsubdirs)
2666 {
2667     SV *subdir = Nullsv;
2668     static char *archpat_auto;
2669
2670     if (!p)
2671         return;
2672
2673     if (addsubdirs) {
2674         subdir = NEWSV(55,0);
2675         if (!archpat_auto) {
2676             STRLEN len = (sizeof(ARCHNAME) + strlen(patchlevel)
2677                           + sizeof("//auto"));
2678             New(55, archpat_auto, len, char);
2679             sprintf(archpat_auto, "/%s/%s/auto", ARCHNAME, patchlevel);
2680 #ifdef VMS
2681         for (len = sizeof(ARCHNAME) + 2;
2682              archpat_auto[len] != '\0' && archpat_auto[len] != '/'; len++)
2683                 if (archpat_auto[len] == '.') archpat_auto[len] = '_';
2684 #endif
2685         }
2686     }
2687
2688     /* Break at all separators */
2689     while (p && *p) {
2690         SV *libdir = NEWSV(55,0);
2691         char *s;
2692
2693         /* skip any consecutive separators */
2694         while ( *p == PERLLIB_SEP ) {
2695             /* Uncomment the next line for PATH semantics */
2696             /* av_push(GvAVn(incgv), newSVpv(".", 1)); */
2697             p++;
2698         }
2699
2700         if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
2701             sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
2702                       (STRLEN)(s - p));
2703             p = s + 1;
2704         }
2705         else {
2706             sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
2707             p = Nullch; /* break out */
2708         }
2709
2710         /*
2711          * BEFORE pushing libdir onto @INC we may first push version- and
2712          * archname-specific sub-directories.
2713          */
2714         if (addsubdirs) {
2715             struct stat tmpstatbuf;
2716 #ifdef VMS
2717             char *unix;
2718             STRLEN len;
2719
2720             if ((unix = tounixspec_ts(SvPV(libdir,na),Nullch)) != Nullch) {
2721                 len = strlen(unix);
2722                 while (unix[len-1] == '/') len--;  /* Cosmetic */
2723                 sv_usepvn(libdir,unix,len);
2724             }
2725             else
2726                 PerlIO_printf(PerlIO_stderr(),
2727                               "Failed to unixify @INC element \"%s\"\n",
2728                               SvPV(libdir,na));
2729 #endif
2730             /* .../archname/version if -d .../archname/version/auto */
2731             sv_setsv(subdir, libdir);
2732             sv_catpv(subdir, archpat_auto);
2733             if (Stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2734                   S_ISDIR(tmpstatbuf.st_mode))
2735                 av_push(GvAVn(incgv),
2736                         newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2737
2738             /* .../archname if -d .../archname/auto */
2739             sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME),
2740                       strlen(patchlevel) + 1, "", 0);
2741             if (Stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2742                   S_ISDIR(tmpstatbuf.st_mode))
2743                 av_push(GvAVn(incgv),
2744                         newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2745         }
2746
2747         /* finally push this lib directory on the end of @INC */
2748         av_push(GvAVn(incgv), libdir);
2749     }
2750
2751     SvREFCNT_dec(subdir);
2752 }
2753
2754 #ifdef USE_THREADS
2755 static struct perl_thread *
2756 init_main_thread()
2757 {
2758     struct perl_thread *thr;
2759     XPV *xpv;
2760
2761     Newz(53, thr, 1, struct perl_thread);
2762     curcop = &compiling;
2763     thr->cvcache = newHV();
2764     thr->threadsv = newAV();
2765     /* thr->threadsvp is set when find_threadsv is called */
2766     thr->specific = newAV();
2767     thr->errhv = newHV();
2768     thr->flags = THRf_R_JOINABLE;
2769     MUTEX_INIT(&thr->mutex);
2770     /* Handcraft thrsv similarly to mess_sv */
2771     New(53, thrsv, 1, SV);
2772     Newz(53, xpv, 1, XPV);
2773     SvFLAGS(thrsv) = SVt_PV;
2774     SvANY(thrsv) = (void*)xpv;
2775     SvREFCNT(thrsv) = 1 << 30;  /* practically infinite */
2776     SvPVX(thrsv) = (char*)thr;
2777     SvCUR_set(thrsv, sizeof(thr));
2778     SvLEN_set(thrsv, sizeof(thr));
2779     *SvEND(thrsv) = '\0';       /* in the trailing_nul field */
2780     thr->oursv = thrsv;
2781     curcop = &compiling;
2782     chopset = " \n-";
2783
2784     MUTEX_LOCK(&threads_mutex);
2785     nthreads++;
2786     thr->tid = 0;
2787     thr->next = thr;
2788     thr->prev = thr;
2789     MUTEX_UNLOCK(&threads_mutex);
2790
2791 #ifdef HAVE_THREAD_INTERN
2792     init_thread_intern(thr);
2793 #endif
2794
2795 #ifdef SET_THREAD_SELF
2796     SET_THREAD_SELF(thr);
2797 #else
2798     thr->self = pthread_self();
2799 #endif /* SET_THREAD_SELF */
2800     SET_THR(thr);
2801
2802     /*
2803      * These must come after the SET_THR because sv_setpvn does
2804      * SvTAINT and the taint fields require dTHR.
2805      */
2806     toptarget = NEWSV(0,0);
2807     sv_upgrade(toptarget, SVt_PVFM);
2808     sv_setpvn(toptarget, "", 0);
2809     bodytarget = NEWSV(0,0);
2810     sv_upgrade(bodytarget, SVt_PVFM);
2811     sv_setpvn(bodytarget, "", 0);
2812     formtarget = bodytarget;
2813     thr->errsv = newSVpv("", 0);
2814     (void) find_threadsv("@");  /* Ensure $@ is initialised early */
2815     return thr;
2816 }
2817 #endif /* USE_THREADS */
2818
2819 void
2820 call_list(I32 oldscope, AV *list)
2821 {
2822     dTHR;
2823     line_t oldline = curcop->cop_line;
2824     STRLEN len;
2825     dJMPENV;
2826     int ret;
2827
2828     while (AvFILL(list) >= 0) {
2829         CV *cv = (CV*)av_shift(list);
2830
2831         SAVEFREESV(cv);
2832
2833         JMPENV_PUSH(ret);
2834         switch (ret) {
2835         case 0: {
2836                 SV* atsv = ERRSV;
2837                 PUSHMARK(stack_sp);
2838                 perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
2839                 (void)SvPV(atsv, len);
2840                 if (len) {
2841                     JMPENV_POP;
2842                     curcop = &compiling;
2843                     curcop->cop_line = oldline;
2844                     if (list == beginav)
2845                         sv_catpv(atsv, "BEGIN failed--compilation aborted");
2846                     else
2847                         sv_catpv(atsv, "END failed--cleanup aborted");
2848                     while (scopestack_ix > oldscope)
2849                         LEAVE;
2850                     croak("%s", SvPVX(atsv));
2851                 }
2852             }
2853             break;
2854         case 1:
2855             STATUS_ALL_FAILURE;
2856             /* FALL THROUGH */
2857         case 2:
2858             /* my_exit() was called */
2859             while (scopestack_ix > oldscope)
2860                 LEAVE;
2861             FREETMPS;
2862             curstash = defstash;
2863             if (endav)
2864                 call_list(oldscope, endav);
2865             JMPENV_POP;
2866             curcop = &compiling;
2867             curcop->cop_line = oldline;
2868             if (statusvalue) {
2869                 if (list == beginav)
2870                     croak("BEGIN failed--compilation aborted");
2871                 else
2872                     croak("END failed--cleanup aborted");
2873             }
2874             my_exit_jump();
2875             /* NOTREACHED */
2876         case 3:
2877             if (!restartop) {
2878                 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
2879                 FREETMPS;
2880                 break;
2881             }
2882             JMPENV_POP;
2883             curcop = &compiling;
2884             curcop->cop_line = oldline;
2885             JMPENV_JUMP(3);
2886         }
2887         JMPENV_POP;
2888     }
2889 }
2890
2891 void
2892 my_exit(U32 status)
2893 {
2894     dTHR;
2895
2896 #ifdef USE_THREADS
2897     DEBUG_L(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
2898                           thr, (unsigned long) status));
2899 #endif /* USE_THREADS */
2900     switch (status) {
2901     case 0:
2902         STATUS_ALL_SUCCESS;
2903         break;
2904     case 1:
2905         STATUS_ALL_FAILURE;
2906         break;
2907     default:
2908         STATUS_NATIVE_SET(status);
2909         break;
2910     }
2911     my_exit_jump();
2912 }
2913
2914 void
2915 my_failure_exit(void)
2916 {
2917 #ifdef VMS
2918     if (vaxc$errno & 1) {
2919         if (STATUS_NATIVE & 1)          /* fortuitiously includes "-1" */
2920             STATUS_NATIVE_SET(44);
2921     }
2922     else {
2923         if (!vaxc$errno && errno)       /* unlikely */
2924             STATUS_NATIVE_SET(44);
2925         else
2926             STATUS_NATIVE_SET(vaxc$errno);
2927     }
2928 #else
2929     if (errno & 255)
2930         STATUS_POSIX_SET(errno);
2931     else if (STATUS_POSIX == 0)
2932         STATUS_POSIX_SET(255);
2933 #endif
2934     my_exit_jump();
2935 }
2936
2937 static void
2938 my_exit_jump(void)
2939 {
2940     dTHR;
2941     register PERL_CONTEXT *cx;
2942     I32 gimme;
2943     SV **newsp;
2944
2945     if (e_tmpname) {
2946         if (e_fp) {
2947             PerlIO_close(e_fp);
2948             e_fp = Nullfp;
2949         }
2950         (void)UNLINK(e_tmpname);
2951         Safefree(e_tmpname);
2952         e_tmpname = Nullch;
2953     }
2954
2955     if (cxstack_ix >= 0) {
2956         if (cxstack_ix > 0)
2957             dounwind(0);
2958         POPBLOCK(cx,curpm);
2959         LEAVE;
2960     }
2961
2962     JMPENV_JUMP(2);
2963 }
2964
2965
2966