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