perl.c

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