perl.c

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