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