perl.c

   1 /*    perl.c
   2  *
   3  *    Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999,
   4  *    2000, 2001, 2002, 2003, 2004, 2005, by Larry Wall and others
   5  *
   6  *    You may distribute under the terms of either the GNU General Public
   7  *    License or the Artistic License, as specified in the README file.
   8  *
   9  */
  10
  11 /*
  12  * "A ship then new they built for him/of mithril and of elven glass" --Bilbo
  13  */
  14
  15 /* This file contains the top-level functions that are used to create, use
  16  * and destroy a perl interpreter, plus the functions used by XS code to
  17  * call back into perl. Note that it does not contain the actual main()
  18  * function of the interpreter; that can be found in perlmain.c
  19  */
  20
  21 /* PSz 12 Nov 03
  22  *
  23  * Be proud that perl(1) may proclaim:
  24  *   Setuid Perl scripts are safer than C programs ...
  25  * Do not abandon (deprecate) suidperl. Do not advocate C wrappers.
  26  *
  27  * The flow was: perl starts, notices script is suid, execs suidperl with same
  28  * arguments; suidperl opens script, checks many things, sets itself with
  29  * right UID, execs perl with similar arguments but with script pre-opened on
  30  * /dev/fd/xxx; perl checks script is as should be and does work. This was
  31  * insecure: see perlsec(1) for many problems with this approach.
  32  *
  33  * The "correct" flow should be: perl starts, opens script and notices it is
  34  * suid, checks many things, execs suidperl with similar arguments but with
  35  * script on /dev/fd/xxx; suidperl checks script and /dev/fd/xxx object are
  36  * same, checks arguments match #! line, sets itself with right UID, execs
  37  * perl with same arguments; perl checks many things and does work.
  38  *
  39  * (Opening the script in perl instead of suidperl, we "lose" scripts that
  40  * are readable to the target UID but not to the invoker. Where did
  41  * unreadable scripts work anyway?)
  42  *
  43  * For now, suidperl and perl are pretty much the same large and cumbersome
  44  * program, so suidperl can check its argument list (see comments elsewhere).
  45  *
  46  * References:
  47  * Original bug report:
  48  *   http://bugs.perl.org/index.html?req=bug_id&bug_id=20010322.218
  49  *   http://rt.perl.org/rt2/Ticket/Display.html?id=6511
  50  * Comments and discussion with Debian:
  51  *   http://bugs.debian.org/203426
  52  *   http://bugs.debian.org/220486
  53  * Debian Security Advisory DSA 431-1 (does not fully fix problem):
  54  *   http://www.debian.org/security/2004/dsa-431
  55  * CVE candidate:
  56  *   http://cve.mitre.org/cgi-bin/cvename.cgi?name=CAN-2003-0618
  57  * Previous versions of this patch sent to perl5-porters:
  58  *   http://www.mail-archive.com/perl5-porters@perl.org/msg71953.html
  59  *   http://www.mail-archive.com/perl5-porters@perl.org/msg75245.html
  60  *   http://www.mail-archive.com/perl5-porters@perl.org/msg75563.html
  61  *   http://www.mail-archive.com/perl5-porters@perl.org/msg75635.html
  62  *
  63 Paul Szabo - psz@maths.usyd.edu.au  http://www.maths.usyd.edu.au:8000/u/psz/
  64 School of Mathematics and Statistics  University of Sydney   2006  Australia
  65  *
  66  */
  67 /* PSz 13 Nov 03
  68  * Use truthful, neat, specific error messages.
  69  * Cannot always hide the truth; security must not depend on doing so.
  70  */
  71
  72 /* PSz 18 Feb 04
  73  * Use global(?), thread-local fdscript for easier checks.
  74  * (I do not understand how we could possibly get a thread race:
  75  * do not all threads go through the same initialization? Or in
  76  * fact, are not threads started only after we get the script and
  77  * so know what to do? Oh well, make things super-safe...)
  78  */
  79
  80 #include "EXTERN.h"
  81 #define PERL_IN_PERL_C
  82 #include "perl.h"
  83 #include "patchlevel.h"                 /* for local_patches */
  84
  85 #ifdef NETWARE
  86 #include "nwutil.h"
  87 char *nw_get_sitelib(const char *pl);
  88 #endif
  89
  90 /* XXX If this causes problems, set i_unistd=undef in the hint file.  */
  91 #ifdef I_UNISTD
  92 #include <unistd.h>
  93 #endif
  94
  95 #ifdef __BEOS__
  96 #  define HZ 1000000
  97 #endif
  98
  99 #ifndef HZ
 100 #  ifdef CLK_TCK
 101 #    define HZ CLK_TCK
 102 #  else
 103 #    define HZ 60
 104 #  endif
 105 #endif
 106
 107 #if !defined(STANDARD_C) && !defined(HAS_GETENV_PROTOTYPE) && !defined(PERL_MICRO)
 108 char *getenv (char *); /* Usually in <stdlib.h> */
 109 #endif
 110
 111 static I32 read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen);
 112
 113 #ifdef IAMSUID
 114 #ifndef DOSUID
 115 #define DOSUID
 116 #endif
 117 #endif /* IAMSUID */
 118
 119 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
 120 #ifdef DOSUID
 121 #undef DOSUID
 122 #endif
 123 #endif
 124
 125 static void
 126 S_init_tls_and_interp(PerlInterpreter *my_perl)
 127 {
 128     if (!PL_curinterp) {
 129         PERL_SET_INTERP(my_perl);
 130 #if defined(USE_ITHREADS)
 131         INIT_THREADS;
 132         ALLOC_THREAD_KEY;
 133         PERL_SET_THX(my_perl);
 134         OP_REFCNT_INIT;
 135         MUTEX_INIT(&PL_dollarzero_mutex);
 136 #  endif
 137     }
 138     else {
 139         PERL_SET_THX(my_perl);
 140     }
 141 }
 142
 143 #ifdef PERL_IMPLICIT_SYS
 144 PerlInterpreter *
 145 perl_alloc_using(struct IPerlMem* ipM, struct IPerlMem* ipMS,
 146                  struct IPerlMem* ipMP, struct IPerlEnv* ipE,
 147                  struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
 148                  struct IPerlDir* ipD, struct IPerlSock* ipS,
 149                  struct IPerlProc* ipP)
 150 {
 151     PerlInterpreter *my_perl;
 152     /* New() needs interpreter, so call malloc() instead */
 153     my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
 154     S_init_tls_and_interp(my_perl);
 155     Zero(my_perl, 1, PerlInterpreter);
 156     PL_Mem = ipM;
 157     PL_MemShared = ipMS;
 158     PL_MemParse = ipMP;
 159     PL_Env = ipE;
 160     PL_StdIO = ipStd;
 161     PL_LIO = ipLIO;
 162     PL_Dir = ipD;
 163     PL_Sock = ipS;
 164     PL_Proc = ipP;
 165
 166     return my_perl;
 167 }
 168 #else
 169
 170 /*
 171 =head1 Embedding Functions
 172
 173 =for apidoc perl_alloc
 174
 175 Allocates a new Perl interpreter.  See L<perlembed>.
 176
 177 =cut
 178 */
 179
 180 PerlInterpreter *
 181 perl_alloc(void)
 182 {
 183     PerlInterpreter *my_perl;
 184 #ifdef USE_5005THREADS
 185     dTHX;
 186 #endif
 187
 188     /* New() needs interpreter, so call malloc() instead */
 189     my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
 190
 191     S_init_tls_and_interp(my_perl);
 192     return ZeroD(my_perl, 1, PerlInterpreter);
 193 }
 194 #endif /* PERL_IMPLICIT_SYS */
 195
 196 /*
 197 =for apidoc perl_construct
 198
 199 Initializes a new Perl interpreter.  See L<perlembed>.
 200
 201 =cut
 202 */
 203
 204 void
 205 perl_construct(pTHXx)
 206 {
 207 #ifdef MULTIPLICITY
 208     init_interp();
 209     PL_perl_destruct_level = 1;
 210 #else
 211    if (PL_perl_destruct_level > 0)
 212        init_interp();
 213 #endif
 214    /* Init the real globals (and main thread)? */
 215     if (!PL_linestr) {
 216 #ifdef PERL_FLEXIBLE_EXCEPTIONS
 217         PL_protect = MEMBER_TO_FPTR(Perl_default_protect); /* for exceptions */
 218 #endif
 219
 220         PL_curcop = &PL_compiling;      /* needed by ckWARN, right away */
 221
 222         PL_linestr = NEWSV(65,79);
 223         sv_upgrade(PL_linestr,SVt_PVIV);
 224
 225         if (!SvREADONLY(&PL_sv_undef)) {
 226             /* set read-only and try to insure than we wont see REFCNT==0
 227                very often */
 228
 229             SvREADONLY_on(&PL_sv_undef);
 230             SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
 231
 232             sv_setpv(&PL_sv_no,PL_No);
 233             /* value lookup in void context - happens to have the side effect
 234                of caching the numeric forms.  */
 235             SvIV(&PL_sv_no);
 236             SvNV(&PL_sv_no);
 237             SvREADONLY_on(&PL_sv_no);
 238             SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
 239
 240             sv_setpv(&PL_sv_yes,PL_Yes);
 241             SvIV(&PL_sv_yes);
 242             SvNV(&PL_sv_yes);
 243             SvREADONLY_on(&PL_sv_yes);
 244             SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
 245
 246             SvREADONLY_on(&PL_sv_placeholder);
 247             SvREFCNT(&PL_sv_placeholder) = (~(U32)0)/2;
 248         }
 249
 250         PL_sighandlerp = Perl_sighandler;
 251         PL_pidstatus = newHV();
 252     }
 253
 254     PL_rs = newSVpvn("\n", 1);
 255
 256     init_stacks();
 257
 258     init_ids();
 259     PL_lex_state = LEX_NOTPARSING;
 260
 261     JMPENV_BOOTSTRAP;
 262     STATUS_ALL_SUCCESS;
 263
 264     init_i18nl10n(1);
 265     SET_NUMERIC_STANDARD();
 266
 267 #if defined(LOCAL_PATCH_COUNT)
 268     PL_localpatches = local_patches;    /* For possible -v */
 269 #endif
 270
 271 #ifdef HAVE_INTERP_INTERN
 272     sys_intern_init();
 273 #endif
 274
 275     PerlIO_init(aTHX);                  /* Hook to IO system */
 276
 277     PL_fdpid = newAV();                 /* for remembering popen pids by fd */
 278     PL_modglobal = newHV();             /* pointers to per-interpreter module globals */
 279     PL_errors = newSVpvn("",0);
 280     sv_setpvn(PERL_DEBUG_PAD(0), "", 0);        /* For regex debugging. */
 281     sv_setpvn(PERL_DEBUG_PAD(1), "", 0);        /* ext/re needs these */
 282     sv_setpvn(PERL_DEBUG_PAD(2), "", 0);        /* even without DEBUGGING. */
 283 #ifdef USE_ITHREADS
 284     PL_regex_padav = newAV();
 285     av_push(PL_regex_padav,(SV*)newAV());    /* First entry is an array of empty elements */
 286     PL_regex_pad = AvARRAY(PL_regex_padav);
 287 #endif
 288 #ifdef USE_REENTRANT_API
 289     Perl_reentrant_init(aTHX);
 290 #endif
 291
 292     /* Note that strtab is a rather special HV.  Assumptions are made
 293        about not iterating on it, and not adding tie magic to it.
 294        It is properly deallocated in perl_destruct() */
 295     PL_strtab = newHV();
 296
 297     HvSHAREKEYS_off(PL_strtab);                 /* mandatory */
 298     hv_ksplit(PL_strtab, 512);
 299
 300 #if defined(__DYNAMIC__) && (defined(NeXT) || defined(__NeXT__))
 301     _dyld_lookup_and_bind
 302         ("__environ", (unsigned long *) &environ_pointer, NULL);
 303 #endif /* environ */
 304
 305 #ifndef PERL_MICRO
 306 #   ifdef  USE_ENVIRON_ARRAY
 307     PL_origenviron = environ;
 308 #   endif
 309 #endif
 310
 311     /* Use sysconf(_SC_CLK_TCK) if available, if not
 312      * available or if the sysconf() fails, use the HZ.
 313      * BeOS has those, but returns the wrong value. */
 314 #if defined(HAS_SYSCONF) && defined(_SC_CLK_TCK) && !defined(__BEOS__)
 315     PL_clocktick = sysconf(_SC_CLK_TCK);
 316     if (PL_clocktick <= 0)
 317 #endif
 318          PL_clocktick = HZ;
 319
 320     PL_stashcache = newHV();
 321
 322     PL_patchlevel = newSVpv(
 323             Perl_form(aTHX_ "%d.%d.%d",
 324             (int)PERL_REVISION,
 325             (int)PERL_VERSION,
 326             (int)PERL_SUBVERSION ), 0
 327     );
 328
 329     ENTER;
 330 }
 331
 332 /*
 333 =for apidoc nothreadhook
 334
 335 Stub that provides thread hook for perl_destruct when there are
 336 no threads.
 337
 338 =cut
 339 */
 340
 341 int
 342 Perl_nothreadhook(pTHX)
 343 {
 344     return 0;
 345 }
 346
 347 /*
 348 =for apidoc perl_destruct
 349
 350 Shuts down a Perl interpreter.  See L<perlembed>.
 351
 352 =cut
 353 */
 354
 355 int
 356 perl_destruct(pTHXx)
 357 {
 358     volatile int destruct_level;  /* 0=none, 1=full, 2=full with checks */
 359     HV *hv;
 360 #ifdef USE_5005THREADS
 361     dTHX;
 362 #endif /* USE_5005THREADS */
 363
 364     /* wait for all pseudo-forked children to finish */
 365     PERL_WAIT_FOR_CHILDREN;
 366
 367     destruct_level = PL_perl_destruct_level;
 368 #ifdef DEBUGGING
 369     {
 370         char *s;
 371         if ((s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL"))) {
 372             int i = atoi(s);
 373             if (destruct_level < i)
 374                 destruct_level = i;
 375         }
 376     }
 377 #endif
 378
 379
 380     if(PL_exit_flags & PERL_EXIT_DESTRUCT_END) {
 381         dJMPENV;
 382         int x = 0;
 383
 384         JMPENV_PUSH(x);
 385         if (PL_endav && !PL_minus_c)
 386             call_list(PL_scopestack_ix, PL_endav);
 387         JMPENV_POP;
 388     }
 389     LEAVE;
 390     FREETMPS;
 391
 392     /* Need to flush since END blocks can produce output */
 393     my_fflush_all();
 394
 395     if (CALL_FPTR(PL_threadhook)(aTHX)) {
 396         /* Threads hook has vetoed further cleanup */
 397         return STATUS_NATIVE_EXPORT;
 398     }
 399
 400     /* We must account for everything.  */
 401
 402     /* Destroy the main CV and syntax tree */
 403     if (PL_main_root) {
 404         /* ensure comppad/curpad to refer to main's pad */
 405         if (CvPADLIST(PL_main_cv)) {
 406             PAD_SET_CUR_NOSAVE(CvPADLIST(PL_main_cv), 1);
 407         }
 408         op_free(PL_main_root);
 409         PL_main_root = Nullop;
 410     }
 411     PL_curcop = &PL_compiling;
 412     PL_main_start = Nullop;
 413     SvREFCNT_dec(PL_main_cv);
 414     PL_main_cv = Nullcv;
 415     PL_dirty = TRUE;
 416
 417     /* Tell PerlIO we are about to tear things apart in case
 418        we have layers which are using resources that should
 419        be cleaned up now.
 420      */
 421
 422     PerlIO_destruct(aTHX);
 423
 424     if (PL_sv_objcount) {
 425         /*
 426          * Try to destruct global references.  We do this first so that the
 427          * destructors and destructees still exist.  Some sv's might remain.
 428          * Non-referenced objects are on their own.
 429          */
 430         sv_clean_objs();
 431         PL_sv_objcount = 0;
 432     }
 433
 434     /* unhook hooks which will soon be, or use, destroyed data */
 435     SvREFCNT_dec(PL_warnhook);
 436     PL_warnhook = Nullsv;
 437     SvREFCNT_dec(PL_diehook);
 438     PL_diehook = Nullsv;
 439
 440     /* call exit list functions */
 441     while (PL_exitlistlen-- > 0)
 442         PL_exitlist[PL_exitlistlen].fn(aTHX_ PL_exitlist[PL_exitlistlen].ptr);
 443
 444     Safefree(PL_exitlist);
 445
 446     PL_exitlist = NULL;
 447     PL_exitlistlen = 0;
 448
 449     if (destruct_level == 0){
 450
 451         DEBUG_P(debprofdump());
 452
 453 #if defined(PERLIO_LAYERS)
 454         /* No more IO - including error messages ! */
 455         PerlIO_cleanup(aTHX);
 456 #endif
 457
 458         /* The exit() function will do everything that needs doing. */
 459         return STATUS_NATIVE_EXPORT;
 460     }
 461
 462     /* jettison our possibly duplicated environment */
 463     /* if PERL_USE_SAFE_PUTENV is defined environ will not have been copied
 464      * so we certainly shouldn't free it here
 465      */
 466 #ifndef PERL_MICRO
 467 #if defined(USE_ENVIRON_ARRAY) && !defined(PERL_USE_SAFE_PUTENV)
 468     if (environ != PL_origenviron && !PL_use_safe_putenv
 469 #ifdef USE_ITHREADS
 470         /* only main thread can free environ[0] contents */
 471         && PL_curinterp == aTHX
 472 #endif
 473         )
 474     {
 475         I32 i;
 476
 477         for (i = 0; environ[i]; i++)
 478             safesysfree(environ[i]);
 479
 480         /* Must use safesysfree() when working with environ. */
 481         safesysfree(environ);
 482
 483         environ = PL_origenviron;
 484     }
 485 #endif
 486 #endif /* !PERL_MICRO */
 487
 488     /* reset so print() ends up where we expect */
 489     setdefout(Nullgv);
 490
 491 #ifdef USE_ITHREADS
 492     /* the syntax tree is shared between clones
 493      * so op_free(PL_main_root) only ReREFCNT_dec's
 494      * REGEXPs in the parent interpreter
 495      * we need to manually ReREFCNT_dec for the clones
 496      */
 497     {
 498         I32 i = AvFILLp(PL_regex_padav) + 1;
 499         SV **ary = AvARRAY(PL_regex_padav);
 500
 501         while (i) {
 502             SV *resv = ary[--i];
 503             REGEXP *re = INT2PTR(REGEXP *,SvIVX(resv));
 504
 505             if (SvFLAGS(resv) & SVf_BREAK) {
 506                 /* this is PL_reg_curpm, already freed
 507                  * flag is set in regexec.c:S_regtry
 508                  */
 509                 SvFLAGS(resv) &= ~SVf_BREAK;
 510             }
 511             else if(SvREPADTMP(resv)) {
 512               SvREPADTMP_off(resv);
 513             }
 514             else {
 515                 ReREFCNT_dec(re);
 516             }
 517         }
 518     }
 519     SvREFCNT_dec(PL_regex_padav);
 520     PL_regex_padav = Nullav;
 521     PL_regex_pad = NULL;
 522 #endif
 523
 524     SvREFCNT_dec((SV*) PL_stashcache);
 525     PL_stashcache = NULL;
 526
 527     /* loosen bonds of global variables */
 528
 529     if(PL_rsfp) {
 530         (void)PerlIO_close(PL_rsfp);
 531         PL_rsfp = Nullfp;
 532     }
 533
 534     /* Filters for program text */
 535     SvREFCNT_dec(PL_rsfp_filters);
 536     PL_rsfp_filters = Nullav;
 537
 538     /* switches */
 539     PL_preprocess   = FALSE;
 540     PL_minus_n      = FALSE;
 541     PL_minus_p      = FALSE;
 542     PL_minus_l      = FALSE;
 543     PL_minus_a      = FALSE;
 544     PL_minus_F      = FALSE;
 545     PL_doswitches   = FALSE;
 546     PL_dowarn       = G_WARN_OFF;
 547     PL_doextract    = FALSE;
 548     PL_sawampersand = FALSE;    /* must save all match strings */
 549     PL_unsafe       = FALSE;
 550
 551     Safefree(PL_inplace);
 552     PL_inplace = Nullch;
 553     SvREFCNT_dec(PL_patchlevel);
 554
 555     if (PL_e_script) {
 556         SvREFCNT_dec(PL_e_script);
 557         PL_e_script = Nullsv;
 558     }
 559
 560     PL_perldb = 0;
 561
 562     /* magical thingies */
 563
 564     SvREFCNT_dec(PL_ofs_sv);    /* $, */
 565     PL_ofs_sv = Nullsv;
 566
 567     SvREFCNT_dec(PL_ors_sv);    /* $\ */
 568     PL_ors_sv = Nullsv;
 569
 570     SvREFCNT_dec(PL_rs);        /* $/ */
 571     PL_rs = Nullsv;
 572
 573     PL_multiline = 0;           /* $* */
 574     Safefree(PL_osname);        /* $^O */
 575     PL_osname = Nullch;
 576
 577     SvREFCNT_dec(PL_statname);
 578     PL_statname = Nullsv;
 579     PL_statgv = Nullgv;
 580
 581     /* defgv, aka *_ should be taken care of elsewhere */
 582
 583     /* clean up after study() */
 584     SvREFCNT_dec(PL_lastscream);
 585     PL_lastscream = Nullsv;
 586     Safefree(PL_screamfirst);
 587     PL_screamfirst = 0;
 588     Safefree(PL_screamnext);
 589     PL_screamnext  = 0;
 590
 591     /* float buffer */
 592     Safefree(PL_efloatbuf);
 593     PL_efloatbuf = Nullch;
 594     PL_efloatsize = 0;
 595
 596     /* startup and shutdown function lists */
 597     SvREFCNT_dec(PL_beginav);
 598     SvREFCNT_dec(PL_beginav_save);
 599     SvREFCNT_dec(PL_endav);
 600     SvREFCNT_dec(PL_checkav);
 601     SvREFCNT_dec(PL_checkav_save);
 602     SvREFCNT_dec(PL_initav);
 603     PL_beginav = Nullav;
 604     PL_beginav_save = Nullav;
 605     PL_endav = Nullav;
 606     PL_checkav = Nullav;
 607     PL_checkav_save = Nullav;
 608     PL_initav = Nullav;
 609
 610     /* shortcuts just get cleared */
 611     PL_envgv = Nullgv;
 612     PL_incgv = Nullgv;
 613     PL_hintgv = Nullgv;
 614     PL_errgv = Nullgv;
 615     PL_argvgv = Nullgv;
 616     PL_argvoutgv = Nullgv;
 617     PL_stdingv = Nullgv;
 618     PL_stderrgv = Nullgv;
 619     PL_last_in_gv = Nullgv;
 620     PL_replgv = Nullgv;
 621     PL_DBgv = Nullgv;
 622     PL_DBline = Nullgv;
 623     PL_DBsub = Nullgv;
 624     PL_DBsingle = Nullsv;
 625     PL_DBtrace = Nullsv;
 626     PL_DBsignal = Nullsv;
 627     PL_DBassertion = Nullsv;
 628     PL_DBcv = Nullcv;
 629     PL_dbargs = Nullav;
 630     PL_debstash = Nullhv;
 631
 632     SvREFCNT_dec(PL_argvout_stack);
 633     PL_argvout_stack = Nullav;
 634
 635     SvREFCNT_dec(PL_modglobal);
 636     PL_modglobal = Nullhv;
 637     SvREFCNT_dec(PL_preambleav);
 638     PL_preambleav = Nullav;
 639     SvREFCNT_dec(PL_subname);
 640     PL_subname = Nullsv;
 641     SvREFCNT_dec(PL_linestr);
 642     PL_linestr = Nullsv;
 643     SvREFCNT_dec(PL_pidstatus);
 644     PL_pidstatus = Nullhv;
 645     SvREFCNT_dec(PL_toptarget);
 646     PL_toptarget = Nullsv;
 647     SvREFCNT_dec(PL_bodytarget);
 648     PL_bodytarget = Nullsv;
 649     PL_formtarget = Nullsv;
 650
 651     /* free locale stuff */
 652 #ifdef USE_LOCALE_COLLATE
 653     Safefree(PL_collation_name);
 654     PL_collation_name = Nullch;
 655 #endif
 656
 657 #ifdef USE_LOCALE_NUMERIC
 658     Safefree(PL_numeric_name);
 659     PL_numeric_name = Nullch;
 660     SvREFCNT_dec(PL_numeric_radix_sv);
 661     PL_numeric_radix_sv = Nullsv;
 662 #endif
 663
 664     /* clear utf8 character classes */
 665     SvREFCNT_dec(PL_utf8_alnum);
 666     SvREFCNT_dec(PL_utf8_alnumc);
 667     SvREFCNT_dec(PL_utf8_ascii);
 668     SvREFCNT_dec(PL_utf8_alpha);
 669     SvREFCNT_dec(PL_utf8_space);
 670     SvREFCNT_dec(PL_utf8_cntrl);
 671     SvREFCNT_dec(PL_utf8_graph);
 672     SvREFCNT_dec(PL_utf8_digit);
 673     SvREFCNT_dec(PL_utf8_upper);
 674     SvREFCNT_dec(PL_utf8_lower);
 675     SvREFCNT_dec(PL_utf8_print);
 676     SvREFCNT_dec(PL_utf8_punct);
 677     SvREFCNT_dec(PL_utf8_xdigit);
 678     SvREFCNT_dec(PL_utf8_mark);
 679     SvREFCNT_dec(PL_utf8_toupper);
 680     SvREFCNT_dec(PL_utf8_totitle);
 681     SvREFCNT_dec(PL_utf8_tolower);
 682     SvREFCNT_dec(PL_utf8_tofold);
 683     SvREFCNT_dec(PL_utf8_idstart);
 684     SvREFCNT_dec(PL_utf8_idcont);
 685     PL_utf8_alnum       = Nullsv;
 686     PL_utf8_alnumc      = Nullsv;
 687     PL_utf8_ascii       = Nullsv;
 688     PL_utf8_alpha       = Nullsv;
 689     PL_utf8_space       = Nullsv;
 690     PL_utf8_cntrl       = Nullsv;
 691     PL_utf8_graph       = Nullsv;
 692     PL_utf8_digit       = Nullsv;
 693     PL_utf8_upper       = Nullsv;
 694     PL_utf8_lower       = Nullsv;
 695     PL_utf8_print       = Nullsv;
 696     PL_utf8_punct       = Nullsv;
 697     PL_utf8_xdigit      = Nullsv;
 698     PL_utf8_mark        = Nullsv;
 699     PL_utf8_toupper     = Nullsv;
 700     PL_utf8_totitle     = Nullsv;
 701     PL_utf8_tolower     = Nullsv;
 702     PL_utf8_tofold      = Nullsv;
 703     PL_utf8_idstart     = Nullsv;
 704     PL_utf8_idcont      = Nullsv;
 705
 706     if (!specialWARN(PL_compiling.cop_warnings))
 707         SvREFCNT_dec(PL_compiling.cop_warnings);
 708     PL_compiling.cop_warnings = Nullsv;
 709     if (!specialCopIO(PL_compiling.cop_io))
 710         SvREFCNT_dec(PL_compiling.cop_io);
 711     PL_compiling.cop_io = Nullsv;
 712     CopFILE_free(&PL_compiling);
 713     CopSTASH_free(&PL_compiling);
 714
 715     /* Prepare to destruct main symbol table.  */
 716
 717     hv = PL_defstash;
 718     PL_defstash = 0;
 719     SvREFCNT_dec(hv);
 720     SvREFCNT_dec(PL_curstname);
 721     PL_curstname = Nullsv;
 722
 723     /* clear queued errors */
 724     SvREFCNT_dec(PL_errors);
 725     PL_errors = Nullsv;
 726
 727     FREETMPS;
 728     if (destruct_level >= 2 && ckWARN_d(WARN_INTERNAL)) {
 729         if (PL_scopestack_ix != 0)
 730             Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
 731                  "Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
 732                  (long)PL_scopestack_ix);
 733         if (PL_savestack_ix != 0)
 734             Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
 735                  "Unbalanced saves: %ld more saves than restores\n",
 736                  (long)PL_savestack_ix);
 737         if (PL_tmps_floor != -1)
 738             Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Unbalanced tmps: %ld more allocs than frees\n",
 739                  (long)PL_tmps_floor + 1);
 740         if (cxstack_ix != -1)
 741             Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Unbalanced context: %ld more PUSHes than POPs\n",
 742                  (long)cxstack_ix + 1);
 743     }
 744
 745     /* Now absolutely destruct everything, somehow or other, loops or no. */
 746     SvFLAGS(PL_fdpid) |= SVTYPEMASK;            /* don't clean out pid table now */
 747     SvFLAGS(PL_strtab) |= SVTYPEMASK;           /* don't clean out strtab now */
 748
 749     /* the 2 is for PL_fdpid and PL_strtab */
 750     while (PL_sv_count > 2 && sv_clean_all())
 751         ;
 752
 753     SvFLAGS(PL_fdpid) &= ~SVTYPEMASK;
 754     SvFLAGS(PL_fdpid) |= SVt_PVAV;
 755     SvFLAGS(PL_strtab) &= ~SVTYPEMASK;
 756     SvFLAGS(PL_strtab) |= SVt_PVHV;
 757
 758     AvREAL_off(PL_fdpid);               /* no surviving entries */
 759     SvREFCNT_dec(PL_fdpid);             /* needed in io_close() */
 760     PL_fdpid = Nullav;
 761
 762 #ifdef HAVE_INTERP_INTERN
 763     sys_intern_clear();
 764 #endif
 765
 766     /* Destruct the global string table. */
 767     {
 768         /* Yell and reset the HeVAL() slots that are still holding refcounts,
 769          * so that sv_free() won't fail on them.
 770          */
 771         I32 riter;
 772         I32 max;
 773         HE *hent;
 774         HE **array;
 775
 776         riter = 0;
 777         max = HvMAX(PL_strtab);
 778         array = HvARRAY(PL_strtab);
 779         hent = array[0];
 780         for (;;) {
 781             if (hent && ckWARN_d(WARN_INTERNAL)) {
 782                 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
 783                      "Unbalanced string table refcount: (%d) for \"%s\"",
 784                      HeVAL(hent) - Nullsv, HeKEY(hent));
 785                 HeVAL(hent) = Nullsv;
 786                 hent = HeNEXT(hent);
 787             }
 788             if (!hent) {
 789                 if (++riter > max)
 790                     break;
 791                 hent = array[riter];
 792             }
 793         }
 794     }
 795     SvREFCNT_dec(PL_strtab);
 796
 797 #ifdef USE_ITHREADS
 798     /* free the pointer table used for cloning */
 799     ptr_table_free(PL_ptr_table);
 800     PL_ptr_table = (PTR_TBL_t*)NULL;
 801 #endif
 802
 803     /* free special SVs */
 804
 805     SvREFCNT(&PL_sv_yes) = 0;
 806     sv_clear(&PL_sv_yes);
 807     SvANY(&PL_sv_yes) = NULL;
 808     SvFLAGS(&PL_sv_yes) = 0;
 809
 810     SvREFCNT(&PL_sv_no) = 0;
 811     sv_clear(&PL_sv_no);
 812     SvANY(&PL_sv_no) = NULL;
 813     SvFLAGS(&PL_sv_no) = 0;
 814
 815     {
 816         int i;
 817         for (i=0; i<=2; i++) {
 818             SvREFCNT(PERL_DEBUG_PAD(i)) = 0;
 819             sv_clear(PERL_DEBUG_PAD(i));
 820             SvANY(PERL_DEBUG_PAD(i)) = NULL;
 821             SvFLAGS(PERL_DEBUG_PAD(i)) = 0;
 822         }
 823     }
 824
 825     if (PL_sv_count != 0 && ckWARN_d(WARN_INTERNAL))
 826         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Scalars leaked: %ld\n", (long)PL_sv_count);
 827
 828 #ifdef DEBUG_LEAKING_SCALARS
 829     if (PL_sv_count != 0) {
 830         SV* sva;
 831         SV* sv;
 832         register SV* svend;
 833
 834         for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) {
 835             svend = &sva[SvREFCNT(sva)];
 836             for (sv = sva + 1; sv < svend; ++sv) {
 837                 if (SvTYPE(sv) != SVTYPEMASK) {
 838                     PerlIO_printf(Perl_debug_log, "leaked: sv=0x%p"
 839                         " flags=0x08%"UVxf
 840                         " refcnt=%"UVuf pTHX__FORMAT "\n",
 841                         sv, sv->sv_flags, sv->sv_refcnt pTHX__VALUE);
 842                 }
 843             }
 844         }
 845     }
 846 #endif
 847     PL_sv_count = 0;
 848
 849
 850 #if defined(PERLIO_LAYERS)
 851     /* No more IO - including error messages ! */
 852     PerlIO_cleanup(aTHX);
 853 #endif
 854
 855     /* sv_undef needs to stay immortal until after PerlIO_cleanup
 856        as currently layers use it rather than Nullsv as a marker
 857        for no arg - and will try and SvREFCNT_dec it.
 858      */
 859     SvREFCNT(&PL_sv_undef) = 0;
 860     SvREADONLY_off(&PL_sv_undef);
 861
 862     Safefree(PL_origfilename);
 863     PL_origfilename = Nullch;
 864     Safefree(PL_reg_start_tmp);
 865     PL_reg_start_tmp = (char**)NULL;
 866     PL_reg_start_tmpl = 0;
 867     if (PL_reg_curpm)
 868         Safefree(PL_reg_curpm);
 869     Safefree(PL_reg_poscache);
 870     free_tied_hv_pool();
 871     Safefree(PL_op_mask);
 872     Safefree(PL_psig_ptr);
 873     PL_psig_ptr = (SV**)NULL;
 874     Safefree(PL_psig_name);
 875     PL_psig_name = (SV**)NULL;
 876     Safefree(PL_bitcount);
 877     PL_bitcount = Nullch;
 878     Safefree(PL_psig_pend);
 879     PL_psig_pend = (int*)NULL;
 880     PL_formfeed = Nullsv;
 881     Safefree(PL_ofmt);
 882     PL_ofmt = Nullch;
 883     nuke_stacks();
 884     PL_tainting = FALSE;
 885     PL_taint_warn = FALSE;
 886     PL_hints = 0;               /* Reset hints. Should hints be per-interpreter ? */
 887     PL_debug = 0;
 888
 889     DEBUG_P(debprofdump());
 890
 891 #ifdef USE_REENTRANT_API
 892     Perl_reentrant_free(aTHX);
 893 #endif
 894
 895     sv_free_arenas();
 896
 897     /* As the absolutely last thing, free the non-arena SV for mess() */
 898
 899     if (PL_mess_sv) {
 900         /* it could have accumulated taint magic */
 901         if (SvTYPE(PL_mess_sv) >= SVt_PVMG) {
 902             MAGIC* mg;
 903             MAGIC* moremagic;
 904             for (mg = SvMAGIC(PL_mess_sv); mg; mg = moremagic) {
 905                 moremagic = mg->mg_moremagic;
 906                 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global
 907                                                 && mg->mg_len >= 0)
 908                     Safefree(mg->mg_ptr);
 909                 Safefree(mg);
 910             }
 911         }
 912         /* we know that type >= SVt_PV */
 913         SvOOK_off(PL_mess_sv);
 914         Safefree(SvPVX(PL_mess_sv));
 915         Safefree(SvANY(PL_mess_sv));
 916         Safefree(PL_mess_sv);
 917         PL_mess_sv = Nullsv;
 918     }
 919     return STATUS_NATIVE_EXPORT;
 920 }
 921
 922 /*
 923 =for apidoc perl_free
 924
 925 Releases a Perl interpreter.  See L<perlembed>.
 926
 927 =cut
 928 */
 929
 930 void
 931 perl_free(pTHXx)
 932 {
 933 #if defined(WIN32) || defined(NETWARE)
 934 #  if defined(PERL_IMPLICIT_SYS)
 935 #    ifdef NETWARE
 936     void *host = nw_internal_host;
 937 #    else
 938     void *host = w32_internal_host;
 939 #    endif
 940     PerlMem_free(aTHXx);
 941 #    ifdef NETWARE
 942     nw_delete_internal_host(host);
 943 #    else
 944     win32_delete_internal_host(host);
 945 #    endif
 946 #  else
 947     PerlMem_free(aTHXx);
 948 #  endif
 949 #else
 950     PerlMem_free(aTHXx);
 951 #endif
 952 }
 953
 954 void
 955 Perl_call_atexit(pTHX_ ATEXIT_t fn, void *ptr)
 956 {
 957     Renew(PL_exitlist, PL_exitlistlen+1, PerlExitListEntry);
 958     PL_exitlist[PL_exitlistlen].fn = fn;
 959     PL_exitlist[PL_exitlistlen].ptr = ptr;
 960     ++PL_exitlistlen;
 961 }
 962
 963 #ifdef HAS_PROCSELFEXE
 964 /* This is a function so that we don't hold on to MAXPATHLEN
 965    bytes of stack longer than necessary
 966  */
 967 STATIC void
 968 S_procself_val(pTHX_ SV *sv, char *arg0)
 969 {
 970     char buf[MAXPATHLEN];
 971     int len = readlink(PROCSELFEXE_PATH, buf, sizeof(buf) - 1);
 972
 973     /* On Playstation2 Linux V1.0 (kernel 2.2.1) readlink(/proc/self/exe)
 974        includes a spurious NUL which will cause $^X to fail in system
 975        or backticks (this will prevent extensions from being built and
 976        many tests from working). readlink is not meant to add a NUL.
 977        Normal readlink works fine.
 978      */
 979     if (len > 0 && buf[len-1] == '\0') {
 980       len--;
 981     }
 982
 983     /* FreeBSD's implementation is acknowledged to be imperfect, sometimes
 984        returning the text "unknown" from the readlink rather than the path
 985        to the executable (or returning an error from the readlink).  Any valid
 986        path has a '/' in it somewhere, so use that to validate the result.
 987        See http://www.freebsd.org/cgi/query-pr.cgi?pr=35703
 988     */
 989     if (len > 0 && memchr(buf, '/', len)) {
 990         sv_setpvn(sv,buf,len);
 991     }
 992     else {
 993         sv_setpv(sv,arg0);
 994     }
 995 }
 996 #endif /* HAS_PROCSELFEXE */
 997
 998 STATIC void
 999 S_set_caret_X(pTHX) {
1000     GV* tmpgv = gv_fetchpv("\030",TRUE, SVt_PV); /* $^X */
1001     if (tmpgv) {
1002 #ifdef HAS_PROCSELFEXE
1003         S_procself_val(aTHX_ GvSV(tmpgv), PL_origargv[0]);
1004 #else
1005 #ifdef OS2
1006         sv_setpv(GvSV(tmpgv), os2_execname(aTHX));
1007 #else
1008         sv_setpv(GvSV(tmpgv),PL_origargv[0]);
1009 #endif
1010 #endif
1011     }
1012 }
1013
1014 /*
1015 =for apidoc perl_parse
1016
1017 Tells a Perl interpreter to parse a Perl script.  See L<perlembed>.
1018
1019 =cut
1020 */
1021
1022 int
1023 perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env)
1024 {
1025     I32 oldscope;
1026     int ret;
1027     dJMPENV;
1028 #ifdef USE_5005THREADS
1029     dTHX;
1030 #endif
1031
1032 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
1033 #ifdef IAMSUID
1034 #undef IAMSUID
1035     Perl_croak(aTHX_ "suidperl is no longer needed since the kernel can now execute\n\
1036 setuid perl scripts securely.\n");
1037 #endif /* IAMSUID */
1038 #endif
1039
1040 #if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT)
1041     /* [perl #22371] Algorimic Complexity Attack on Perl 5.6.1, 5.8.0
1042      * This MUST be done before any hash stores or fetches take place.
1043      * If you set PL_rehash_seed (and assumedly also PL_rehash_seed_set)
1044      * yourself, it is your responsibility to provide a good random seed!
1045      * You can also define PERL_HASH_SEED in compile time, see hv.h. */
1046     if (!PL_rehash_seed_set)
1047          PL_rehash_seed = get_hash_seed();
1048     {
1049          char *s = PerlEnv_getenv("PERL_HASH_SEED_DEBUG");
1050
1051          if (s) {
1052               int i = atoi(s);
1053
1054               if (i == 1)
1055                    PerlIO_printf(Perl_debug_log, "HASH_SEED = %"UVuf"\n",
1056                                  PL_rehash_seed);
1057          }
1058     }
1059 #endif /* #if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT) */
1060
1061     PL_origargc = argc;
1062     PL_origargv = argv;
1063
1064     {
1065         /* Set PL_origalen be the sum of the contiguous argv[]
1066          * elements plus the size of the env in case that it is
1067          * contiguous with the argv[].  This is used in mg.c:Perl_magic_set()
1068          * as the maximum modifiable length of $0.  In the worst case
1069          * the area we are able to modify is limited to the size of
1070          * the original argv[0].  (See below for 'contiguous', though.)
1071          * --jhi */
1072          char *s = NULL;
1073          int i;
1074          UV mask =
1075            ~(UV)(PTRSIZE == 4 ? 3 : PTRSIZE == 8 ? 7 : PTRSIZE == 16 ? 15 : 0);
1076          /* Do the mask check only if the args seem like aligned. */
1077          UV aligned =
1078            (mask < ~(UV)0) && ((PTR2UV(argv[0]) & mask) == PTR2UV(argv[0]));
1079
1080          /* See if all the arguments are contiguous in memory.  Note
1081           * that 'contiguous' is a loose term because some platforms
1082           * align the argv[] and the envp[].  If the arguments look
1083           * like non-aligned, assume that they are 'strictly' or
1084           * 'traditionally' contiguous.  If the arguments look like
1085           * aligned, we just check that they are within aligned
1086           * PTRSIZE bytes.  As long as no system has something bizarre
1087           * like the argv[] interleaved with some other data, we are
1088           * fine.  (Did I just evoke Murphy's Law?)  --jhi */
1089          if (PL_origargv && PL_origargc >= 1 && (s = PL_origargv[0])) {
1090               while (*s) s++;
1091               for (i = 1; i < PL_origargc; i++) {
1092                    if ((PL_origargv[i] == s + 1
1093 #ifdef OS2
1094                         || PL_origargv[i] == s + 2
1095 #endif
1096                             )
1097                        ||
1098                        (aligned &&
1099                         (PL_origargv[i] >  s &&
1100                          PL_origargv[i] <=
1101                          INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask)))
1102                         )
1103                    {
1104                         s = PL_origargv[i];
1105                         while (*s) s++;
1106                    }
1107                    else
1108                         break;
1109               }
1110          }
1111          /* Can we grab env area too to be used as the area for $0? */
1112          if (PL_origenviron) {
1113               if ((PL_origenviron[0] == s + 1
1114 #ifdef OS2
1115                    || (PL_origenviron[0] == s + 9 && (s += 8))
1116 #endif
1117                   )
1118                   ||
1119                   (aligned &&
1120                    (PL_origenviron[0] >  s &&
1121                     PL_origenviron[0] <=
1122                     INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask)))
1123                  )
1124               {
1125 #ifndef OS2
1126                    s = PL_origenviron[0];
1127                    while (*s) s++;
1128 #endif
1129                    my_setenv("NoNe  SuCh", Nullch);
1130                    /* Force copy of environment. */
1131                    for (i = 1; PL_origenviron[i]; i++) {
1132                         if (PL_origenviron[i] == s + 1
1133                             ||
1134                             (aligned &&
1135                              (PL_origenviron[i] >  s &&
1136                               PL_origenviron[i] <=
1137                               INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask)))
1138                            )
1139                         {
1140                              s = PL_origenviron[i];
1141                              while (*s) s++;
1142                         }
1143                         else
1144                              break;
1145                    }
1146               }
1147          }
1148          PL_origalen = s - PL_origargv[0] + 1;
1149     }
1150
1151     if (PL_do_undump) {
1152
1153         /* Come here if running an undumped a.out. */
1154
1155         PL_origfilename = savepv(argv[0]);
1156         PL_do_undump = FALSE;
1157         cxstack_ix = -1;                /* start label stack again */
1158         init_ids();
1159         assert (!PL_tainted);
1160         TAINT;
1161         S_set_caret_X(aTHX);
1162         TAINT_NOT;
1163         init_postdump_symbols(argc,argv,env);
1164         return 0;
1165     }
1166
1167     if (PL_main_root) {
1168         op_free(PL_main_root);
1169         PL_main_root = Nullop;
1170     }
1171     PL_main_start = Nullop;
1172     SvREFCNT_dec(PL_main_cv);
1173     PL_main_cv = Nullcv;
1174
1175     time(&PL_basetime);
1176     oldscope = PL_scopestack_ix;
1177     PL_dowarn = G_WARN_OFF;
1178
1179 #ifdef PERL_FLEXIBLE_EXCEPTIONS
1180     CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vparse_body), env, xsinit);
1181 #else
1182     JMPENV_PUSH(ret);
1183 #endif
1184     switch (ret) {
1185     case 0:
1186 #ifndef PERL_FLEXIBLE_EXCEPTIONS
1187         parse_body(env,xsinit);
1188 #endif
1189         if (PL_checkav)
1190             call_list(oldscope, PL_checkav);
1191         ret = 0;
1192         break;
1193     case 1:
1194         STATUS_ALL_FAILURE;
1195         /* FALL THROUGH */
1196     case 2:
1197         /* my_exit() was called */
1198         while (PL_scopestack_ix > oldscope)
1199             LEAVE;
1200         FREETMPS;
1201         PL_curstash = PL_defstash;
1202         if (PL_checkav)
1203             call_list(oldscope, PL_checkav);
1204         ret = STATUS_NATIVE_EXPORT;
1205         break;
1206     case 3:
1207         PerlIO_printf(Perl_error_log, "panic: top_env\n");
1208         ret = 1;
1209         break;
1210     }
1211     JMPENV_POP;
1212     return ret;
1213 }
1214
1215 #ifdef PERL_FLEXIBLE_EXCEPTIONS
1216 STATIC void *
1217 S_vparse_body(pTHX_ va_list args)
1218 {
1219     char **env = va_arg(args, char**);
1220     XSINIT_t xsinit = va_arg(args, XSINIT_t);
1221
1222     return parse_body(env, xsinit);
1223 }
1224 #endif
1225
1226 STATIC void *
1227 S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
1228 {
1229     int argc = PL_origargc;
1230     char **argv = PL_origargv;
1231     char *scriptname = NULL;
1232     VOL bool dosearch = FALSE;
1233     char *validarg = "";
1234     register SV *sv;
1235     register char *s;
1236     char *cddir = Nullch;
1237
1238     PL_fdscript = -1;
1239     PL_suidscript = -1;
1240     sv_setpvn(PL_linestr,"",0);
1241     sv = newSVpvn("",0);                /* first used for -I flags */
1242     SAVEFREESV(sv);
1243     init_main_stash();
1244
1245     for (argc--,argv++; argc > 0; argc--,argv++) {
1246         if (argv[0][0] != '-' || !argv[0][1])
1247             break;
1248 #ifdef DOSUID
1249     if (*validarg)
1250         validarg = " PHOOEY ";
1251     else
1252         validarg = argv[0];
1253     /*
1254      * Can we rely on the kernel to start scripts with argv[1] set to
1255      * contain all #! line switches (the whole line)? (argv[0] is set to
1256      * the interpreter name, argv[2] to the script name; argv[3] and
1257      * above may contain other arguments.)
1258      */
1259 #endif
1260         s = argv[0]+1;
1261       reswitch:
1262         switch (*s) {
1263         case 'C':
1264 #ifndef PERL_STRICT_CR
1265         case '\r':
1266 #endif
1267         case ' ':
1268         case '0':
1269         case 'F':
1270         case 'a':
1271         case 'c':
1272         case 'd':
1273         case 'D':
1274         case 'h':
1275         case 'i':
1276         case 'l':
1277         case 'M':
1278         case 'm':
1279         case 'n':
1280         case 'p':
1281         case 's':
1282         case 'u':
1283         case 'U':
1284         case 'v':
1285         case 'W':
1286         case 'X':
1287         case 'w':
1288         case 'A':
1289             if ((s = moreswitches(s)))
1290                 goto reswitch;
1291             break;
1292
1293         case 't':
1294             CHECK_MALLOC_TOO_LATE_FOR('t');
1295             if( !PL_tainting ) {
1296                  PL_taint_warn = TRUE;
1297                  PL_tainting = TRUE;
1298             }
1299             s++;
1300             goto reswitch;
1301         case 'T':
1302             CHECK_MALLOC_TOO_LATE_FOR('T');
1303             PL_tainting = TRUE;
1304             PL_taint_warn = FALSE;
1305             s++;
1306             goto reswitch;
1307
1308         case 'e':
1309 #ifdef MACOS_TRADITIONAL
1310             /* ignore -e for Dev:Pseudo argument */
1311             if (argv[1] && !strcmp(argv[1], "Dev:Pseudo"))
1312                 break;
1313 #endif
1314             forbid_setid("-e");
1315             if (!PL_e_script) {
1316                 PL_e_script = newSVpvn("",0);
1317                 filter_add(read_e_script, NULL);
1318             }
1319             if (*++s)
1320                 sv_catpv(PL_e_script, s);
1321             else if (argv[1]) {
1322                 sv_catpv(PL_e_script, argv[1]);
1323                 argc--,argv++;
1324             }
1325             else
1326                 Perl_croak(aTHX_ "No code specified for -e");
1327             sv_catpv(PL_e_script, "\n");
1328             break;
1329
1330         case 'I':       /* -I handled both here and in moreswitches() */
1331             forbid_setid("-I");
1332             if (!*++s && (s=argv[1]) != Nullch) {
1333                 argc--,argv++;
1334             }
1335             if (s && *s) {
1336                 char *p;
1337                 STRLEN len = strlen(s);
1338                 p = savepvn(s, len);
1339                 incpush(p, TRUE, TRUE, FALSE, FALSE);
1340                 sv_catpvn(sv, "-I", 2);
1341                 sv_catpvn(sv, p, len);
1342                 sv_catpvn(sv, " ", 1);
1343                 Safefree(p);
1344             }
1345             else
1346                 Perl_croak(aTHX_ "No directory specified for -I");
1347             break;
1348         case 'P':
1349             forbid_setid("-P");
1350             PL_preprocess = TRUE;
1351             s++;
1352             goto reswitch;
1353         case 'S':
1354             forbid_setid("-S");
1355             dosearch = TRUE;
1356             s++;
1357             goto reswitch;
1358         case 'V':
1359             if (!PL_preambleav)
1360                 PL_preambleav = newAV();
1361             av_push(PL_preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
1362             if (*++s != ':')  {
1363                 PL_Sv = newSVpv("print myconfig();",0);
1364 #ifdef VMS
1365                 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
1366 #else
1367                 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
1368 #endif
1369                 sv_catpv(PL_Sv,"\"  Compile-time options:");
1370 #  ifdef DEBUGGING
1371                 sv_catpv(PL_Sv," DEBUGGING");
1372 #  endif
1373 #  ifdef MULTIPLICITY
1374                 sv_catpv(PL_Sv," MULTIPLICITY");
1375 #  endif
1376 #  ifdef USE_5005THREADS
1377                 sv_catpv(PL_Sv," USE_5005THREADS");
1378 #  endif
1379 #  ifdef USE_ITHREADS
1380                 sv_catpv(PL_Sv," USE_ITHREADS");
1381 #  endif
1382 #  ifdef USE_64_BIT_INT
1383                 sv_catpv(PL_Sv," USE_64_BIT_INT");
1384 #  endif
1385 #  ifdef USE_64_BIT_ALL
1386                 sv_catpv(PL_Sv," USE_64_BIT_ALL");
1387 #  endif
1388 #  ifdef USE_LONG_DOUBLE
1389                 sv_catpv(PL_Sv," USE_LONG_DOUBLE");
1390 #  endif
1391 #  ifdef USE_LARGE_FILES
1392                 sv_catpv(PL_Sv," USE_LARGE_FILES");
1393 #  endif
1394 #  ifdef USE_SOCKS
1395                 sv_catpv(PL_Sv," USE_SOCKS");
1396 #  endif
1397 #  ifdef PERL_IMPLICIT_CONTEXT
1398                 sv_catpv(PL_Sv," PERL_IMPLICIT_CONTEXT");
1399 #  endif
1400 #  ifdef PERL_IMPLICIT_SYS
1401                 sv_catpv(PL_Sv," PERL_IMPLICIT_SYS");
1402 #  endif
1403                 sv_catpv(PL_Sv,"\\n\",");
1404
1405 #if defined(LOCAL_PATCH_COUNT)
1406                 if (LOCAL_PATCH_COUNT > 0) {
1407                     int i;
1408                     sv_catpv(PL_Sv,"\"  Locally applied patches:\\n\",");
1409                     for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
1410                         if (PL_localpatches[i])
1411                             Perl_sv_catpvf(aTHX_ PL_Sv,"q%c\t%s\n%c,",
1412                                     0, PL_localpatches[i], 0);
1413                     }
1414                 }
1415 #endif
1416                 Perl_sv_catpvf(aTHX_ PL_Sv,"\"  Built under %s\\n\"",OSNAME);
1417 #ifdef __DATE__
1418 #  ifdef __TIME__
1419                 Perl_sv_catpvf(aTHX_ PL_Sv,",\"  Compiled at %s %s\\n\"",__DATE__,__TIME__);
1420 #  else
1421                 Perl_sv_catpvf(aTHX_ PL_Sv,",\"  Compiled on %s\\n\"",__DATE__);
1422 #  endif
1423 #endif
1424                 sv_catpv(PL_Sv, "; \
1425 $\"=\"\\n    \"; \
1426 @env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; ");
1427 #ifdef __CYGWIN__
1428                 sv_catpv(PL_Sv,"\
1429 push @env, \"CYGWIN=\\\"$ENV{CYGWIN}\\\"\";");
1430 #endif
1431                 sv_catpv(PL_Sv, "\
1432 print \"  \\%ENV:\\n    @env\\n\" if @env; \
1433 print \"  \\@INC:\\n    @INC\\n\";");
1434             }
1435             else {
1436                 PL_Sv = newSVpv("config_vars(qw(",0);
1437                 sv_catpv(PL_Sv, ++s);
1438                 sv_catpv(PL_Sv, "))");
1439                 s += strlen(s);
1440             }
1441             av_push(PL_preambleav, PL_Sv);
1442             scriptname = BIT_BUCKET;    /* don't look for script or read stdin */
1443             goto reswitch;
1444         case 'x':
1445             PL_doextract = TRUE;
1446             s++;
1447             if (*s)
1448                 cddir = s;
1449             break;
1450         case 0:
1451             break;
1452         case '-':
1453             if (!*++s || isSPACE(*s)) {
1454                 argc--,argv++;
1455                 goto switch_end;
1456             }
1457             /* catch use of gnu style long options */
1458             if (strEQ(s, "version")) {
1459                 s = "v";
1460                 goto reswitch;
1461             }
1462             if (strEQ(s, "help")) {
1463                 s = "h";
1464                 goto reswitch;
1465             }
1466             s--;
1467             /* FALL THROUGH */
1468         default:
1469             Perl_croak(aTHX_ "Unrecognized switch: -%s  (-h will show valid options)",s);
1470         }
1471     }
1472   switch_end:
1473
1474     if (
1475 #ifndef SECURE_INTERNAL_GETENV
1476         !PL_tainting &&
1477 #endif
1478         (s = PerlEnv_getenv("PERL5OPT")))
1479     {
1480         char *popt = s;
1481         while (isSPACE(*s))
1482             s++;
1483         if (*s == '-' && *(s+1) == 'T') {
1484             CHECK_MALLOC_TOO_LATE_FOR('T');
1485             PL_tainting = TRUE;
1486             PL_taint_warn = FALSE;
1487         }
1488         else {
1489             char *popt_copy = Nullch;
1490             while (s && *s) {
1491                 char *d;
1492                 while (isSPACE(*s))
1493                     s++;
1494                 if (*s == '-') {
1495                     s++;
1496                     if (isSPACE(*s))
1497                         continue;
1498                 }
1499                 d = s;
1500                 if (!*s)
1501                     break;
1502                 if (!strchr("DIMUdmtwA", *s))
1503                     Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s);
1504                 while (++s && *s) {
1505                     if (isSPACE(*s)) {
1506                         if (!popt_copy) {
1507                             popt_copy = SvPVX(sv_2mortal(newSVpv(popt,0)));
1508                             s = popt_copy + (s - popt);
1509                             d = popt_copy + (d - popt);
1510                         }
1511                         *s++ = '\0';
1512                         break;
1513                     }
1514                 }
1515                 if (*d == 't') {
1516                     if( !PL_tainting ) {
1517                         PL_taint_warn = TRUE;
1518                         PL_tainting = TRUE;
1519                     }
1520                 } else {
1521                     moreswitches(d);
1522                 }
1523             }
1524         }
1525     }
1526
1527     if (PL_taint_warn && PL_dowarn != G_WARN_ALL_OFF) {
1528        PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
1529     }
1530
1531     if (!scriptname)
1532         scriptname = argv[0];
1533     if (PL_e_script) {
1534         argc++,argv--;
1535         scriptname = BIT_BUCKET;        /* don't look for script or read stdin */
1536     }
1537     else if (scriptname == Nullch) {
1538 #ifdef MSDOS
1539         if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) )
1540             moreswitches("h");
1541 #endif
1542         scriptname = "-";
1543     }
1544
1545     /* Set $^X early so that it can be used for relocatable paths in @INC  */
1546     assert (!PL_tainted);
1547     TAINT;
1548     S_set_caret_X(aTHX);
1549     TAINT_NOT;
1550     init_perllib();
1551
1552     open_script(scriptname,dosearch,sv);
1553
1554     validate_suid(validarg, scriptname);
1555
1556 #ifndef PERL_MICRO
1557 #if defined(SIGCHLD) || defined(SIGCLD)
1558     {
1559 #ifndef SIGCHLD
1560 #  define SIGCHLD SIGCLD
1561 #endif
1562         Sighandler_t sigstate = rsignal_state(SIGCHLD);
1563         if (sigstate == SIG_IGN) {
1564             if (ckWARN(WARN_SIGNAL))
1565                 Perl_warner(aTHX_ packWARN(WARN_SIGNAL),
1566                             "Can't ignore signal CHLD, forcing to default");
1567             (void)rsignal(SIGCHLD, (Sighandler_t)SIG_DFL);
1568         }
1569     }
1570 #endif
1571 #endif
1572
1573 #ifdef MACOS_TRADITIONAL
1574     if (PL_doextract || gMacPerl_AlwaysExtract) {
1575 #else
1576     if (PL_doextract) {
1577 #endif
1578         find_beginning();
1579         if (cddir && PerlDir_chdir(cddir) < 0)
1580             Perl_croak(aTHX_ "Can't chdir to %s",cddir);
1581
1582     }
1583
1584     PL_main_cv = PL_compcv = (CV*)NEWSV(1104,0);
1585     sv_upgrade((SV *)PL_compcv, SVt_PVCV);
1586     CvUNIQUE_on(PL_compcv);
1587
1588     CvPADLIST(PL_compcv) = pad_new(0);
1589 #ifdef USE_5005THREADS
1590     CvOWNER(PL_compcv) = 0;
1591     New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
1592     MUTEX_INIT(CvMUTEXP(PL_compcv));
1593 #endif /* USE_5005THREADS */
1594
1595     boot_core_PerlIO();
1596     boot_core_UNIVERSAL();
1597     boot_core_xsutils();
1598
1599     if (xsinit)
1600         (*xsinit)(aTHX);        /* in case linked C routines want magical variables */
1601 #ifndef PERL_MICRO
1602 #if defined(VMS) || defined(WIN32) || defined(DJGPP) || defined(__CYGWIN__) || defined(EPOC)
1603     init_os_extras();
1604 #endif
1605 #endif
1606
1607 #ifdef USE_SOCKS
1608 #   ifdef HAS_SOCKS5_INIT
1609     socks5_init(argv[0]);
1610 #   else
1611     SOCKSinit(argv[0]);
1612 #   endif
1613 #endif
1614
1615     init_predump_symbols();
1616     /* init_postdump_symbols not currently designed to be called */
1617     /* more than once (ENV isn't cleared first, for example)     */
1618     /* But running with -u leaves %ENV & @ARGV undefined!    XXX */
1619     if (!PL_do_undump)
1620         init_postdump_symbols(argc,argv,env);
1621
1622     /* PL_unicode is turned on by -C or by $ENV{PERL_UNICODE}.
1623      * PL_utf8locale is conditionally turned on by
1624      * locale.c:Perl_init_i18nl10n() if the environment
1625      * look like the user wants to use UTF-8. */
1626     if (PL_unicode) {
1627          /* Requires init_predump_symbols(). */
1628          if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) {
1629               IO* io;
1630               PerlIO* fp;
1631               SV* sv;
1632
1633               /* Turn on UTF-8-ness on STDIN, STDOUT, STDERR
1634                * and the default open disciplines. */
1635               if ((PL_unicode & PERL_UNICODE_STDIN_FLAG) &&
1636                   PL_stdingv  && (io = GvIO(PL_stdingv)) &&
1637                   (fp = IoIFP(io)))
1638                    PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
1639               if ((PL_unicode & PERL_UNICODE_STDOUT_FLAG) &&
1640                   PL_defoutgv && (io = GvIO(PL_defoutgv)) &&
1641                   (fp = IoOFP(io)))
1642                    PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
1643               if ((PL_unicode & PERL_UNICODE_STDERR_FLAG) &&
1644                   PL_stderrgv && (io = GvIO(PL_stderrgv)) &&
1645                   (fp = IoOFP(io)))
1646                    PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
1647               if ((PL_unicode & PERL_UNICODE_INOUT_FLAG) &&
1648                   (sv = GvSV(gv_fetchpv("\017PEN", TRUE, SVt_PV)))) {
1649                    U32 in  = PL_unicode & PERL_UNICODE_IN_FLAG;
1650                    U32 out = PL_unicode & PERL_UNICODE_OUT_FLAG;
1651                    if (in) {
1652                         if (out)
1653                              sv_setpvn(sv, ":utf8\0:utf8", 11);
1654                         else
1655                              sv_setpvn(sv, ":utf8\0", 6);
1656                    }
1657                    else if (out)
1658                         sv_setpvn(sv, "\0:utf8", 6);
1659                    SvSETMAGIC(sv);
1660               }
1661          }
1662     }
1663
1664     if ((s = PerlEnv_getenv("PERL_SIGNALS"))) {
1665          if (strEQ(s, "unsafe"))
1666               PL_signals |=  PERL_SIGNALS_UNSAFE_FLAG;
1667          else if (strEQ(s, "safe"))
1668               PL_signals &= ~PERL_SIGNALS_UNSAFE_FLAG;
1669          else
1670               Perl_croak(aTHX_ "PERL_SIGNALS illegal: \"%s\"", s);
1671     }
1672
1673     init_lexer();
1674
1675     /* now parse the script */
1676
1677     SETERRNO(0,SS_NORMAL);
1678     PL_error_count = 0;
1679 #ifdef MACOS_TRADITIONAL
1680     if (gMacPerl_SyntaxError = (yyparse() || PL_error_count)) {
1681         if (PL_minus_c)
1682             Perl_croak(aTHX_ "%s had compilation errors.\n", MacPerl_MPWFileName(PL_origfilename));
1683         else {
1684             Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
1685                        MacPerl_MPWFileName(PL_origfilename));
1686         }
1687     }
1688 #else
1689     if (yyparse() || PL_error_count) {
1690         if (PL_minus_c)
1691             Perl_croak(aTHX_ "%s had compilation errors.\n", PL_origfilename);
1692         else {
1693             Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
1694                        PL_origfilename);
1695         }
1696     }
1697 #endif
1698     CopLINE_set(PL_curcop, 0);
1699     PL_curstash = PL_defstash;
1700     PL_preprocess = FALSE;
1701     if (PL_e_script) {
1702         SvREFCNT_dec(PL_e_script);
1703         PL_e_script = Nullsv;
1704     }
1705
1706     if (PL_do_undump)
1707         my_unexec();
1708
1709     if (isWARN_ONCE) {
1710         SAVECOPFILE(PL_curcop);
1711         SAVECOPLINE(PL_curcop);
1712         gv_check(PL_defstash);
1713     }
1714
1715     LEAVE;
1716     FREETMPS;
1717
1718 #ifdef MYMALLOC
1719     if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
1720         dump_mstats("after compilation:");
1721 #endif
1722
1723     ENTER;
1724     PL_restartop = 0;
1725     return NULL;
1726 }
1727
1728 /*
1729 =for apidoc perl_run
1730
1731 Tells a Perl interpreter to run.  See L<perlembed>.
1732
1733 =cut
1734 */
1735
1736 int
1737 perl_run(pTHXx)
1738 {
1739     I32 oldscope;
1740     int ret = 0;
1741     dJMPENV;
1742 #ifdef USE_5005THREADS
1743     dTHX;
1744 #endif
1745
1746     oldscope = PL_scopestack_ix;
1747 #ifdef VMS
1748     VMSISH_HUSHED = 0;
1749 #endif
1750
1751 #ifdef PERL_FLEXIBLE_EXCEPTIONS
1752  redo_body:
1753     CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vrun_body), oldscope);
1754 #else
1755     JMPENV_PUSH(ret);
1756 #endif
1757     switch (ret) {
1758     case 1:
1759         cxstack_ix = -1;                /* start context stack again */
1760         goto redo_body;
1761     case 0:                             /* normal completion */
1762 #ifndef PERL_FLEXIBLE_EXCEPTIONS
1763  redo_body:
1764         run_body(oldscope);
1765 #endif
1766         /* FALL THROUGH */
1767     case 2:                             /* my_exit() */
1768         while (PL_scopestack_ix > oldscope)
1769             LEAVE;
1770         FREETMPS;
1771         PL_curstash = PL_defstash;
1772         if (!(PL_exit_flags & PERL_EXIT_DESTRUCT_END) &&
1773             PL_endav && !PL_minus_c)
1774             call_list(oldscope, PL_endav);
1775 #ifdef MYMALLOC
1776         if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
1777             dump_mstats("after execution:  ");
1778 #endif
1779         ret = STATUS_NATIVE_EXPORT;
1780         break;
1781     case 3:
1782         if (PL_restartop) {
1783             POPSTACK_TO(PL_mainstack);
1784             goto redo_body;
1785         }
1786         PerlIO_printf(Perl_error_log, "panic: restartop\n");
1787         FREETMPS;
1788         ret = 1;
1789         break;
1790     }
1791
1792     JMPENV_POP;
1793     return ret;
1794 }
1795
1796 #ifdef PERL_FLEXIBLE_EXCEPTIONS
1797 STATIC void *
1798 S_vrun_body(pTHX_ va_list args)
1799 {
1800     I32 oldscope = va_arg(args, I32);
1801
1802     return run_body(oldscope);
1803 }
1804 #endif
1805
1806
1807 STATIC void *
1808 S_run_body(pTHX_ I32 oldscope)
1809 {
1810     DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
1811                     PL_sawampersand ? "Enabling" : "Omitting"));
1812
1813     if (!PL_restartop) {
1814         DEBUG_x(dump_all());
1815         if (!DEBUG_q_TEST)
1816           PERL_DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
1817         DEBUG_S(PerlIO_printf(Perl_debug_log, "main thread is 0x%"UVxf"\n",
1818                               PTR2UV(thr)));
1819
1820         if (PL_minus_c) {
1821 #ifdef MACOS_TRADITIONAL
1822             PerlIO_printf(Perl_error_log, "%s%s syntax OK\n",
1823                 (gMacPerl_ErrorFormat ? "# " : ""),
1824                 MacPerl_MPWFileName(PL_origfilename));
1825 #else
1826             PerlIO_printf(Perl_error_log, "%s syntax OK\n", PL_origfilename);
1827 #endif
1828             my_exit(0);
1829         }
1830         if (PERLDB_SINGLE && PL_DBsingle)
1831             sv_setiv(PL_DBsingle, 1);
1832         if (PL_initav)
1833             call_list(oldscope, PL_initav);
1834     }
1835
1836     /* do it */
1837
1838     if (PL_restartop) {
1839         PL_op = PL_restartop;
1840         PL_restartop = 0;
1841         CALLRUNOPS(aTHX);
1842     }
1843     else if (PL_main_start) {
1844         CvDEPTH(PL_main_cv) = 1;
1845         PL_op = PL_main_start;
1846         CALLRUNOPS(aTHX);
1847     }
1848
1849     my_exit(0);
1850     /* NOTREACHED */
1851     return NULL;
1852 }
1853
1854 /*
1855 =head1 SV Manipulation Functions
1856
1857 =for apidoc p||get_sv
1858
1859 Returns the SV of the specified Perl scalar.  If C<create> is set and the
1860 Perl variable does not exist then it will be created.  If C<create> is not
1861 set and the variable does not exist then NULL is returned.
1862
1863 =cut
1864 */
1865
1866 SV*
1867 Perl_get_sv(pTHX_ const char *name, I32 create)
1868 {
1869     GV *gv;
1870 #ifdef USE_5005THREADS
1871     if (name[1] == '\0' && !isALPHA(name[0])) {
1872         PADOFFSET tmp = find_threadsv(name);
1873         if (tmp != NOT_IN_PAD)
1874             return THREADSV(tmp);
1875     }
1876 #endif /* USE_5005THREADS */
1877     gv = gv_fetchpv(name, create, SVt_PV);
1878     if (gv)
1879         return GvSV(gv);
1880     return Nullsv;
1881 }
1882
1883 /*
1884 =head1 Array Manipulation Functions
1885
1886 =for apidoc p||get_av
1887
1888 Returns the AV of the specified Perl array.  If C<create> is set and the
1889 Perl variable does not exist then it will be created.  If C<create> is not
1890 set and the variable does not exist then NULL is returned.
1891
1892 =cut
1893 */
1894
1895 AV*
1896 Perl_get_av(pTHX_ const char *name, I32 create)
1897 {
1898     GV* gv = gv_fetchpv(name, create, SVt_PVAV);
1899     if (create)
1900         return GvAVn(gv);
1901     if (gv)
1902         return GvAV(gv);
1903     return Nullav;
1904 }
1905
1906 /*
1907 =head1 Hash Manipulation Functions
1908
1909 =for apidoc p||get_hv
1910
1911 Returns the HV of the specified Perl hash.  If C<create> is set and the
1912 Perl variable does not exist then it will be created.  If C<create> is not
1913 set and the variable does not exist then NULL is returned.
1914
1915 =cut
1916 */
1917
1918 HV*
1919 Perl_get_hv(pTHX_ const char *name, I32 create)
1920 {
1921     GV* gv = gv_fetchpv(name, create, SVt_PVHV);
1922     if (create)
1923         return GvHVn(gv);
1924     if (gv)
1925         return GvHV(gv);
1926     return Nullhv;
1927 }
1928
1929 /*
1930 =head1 CV Manipulation Functions
1931
1932 =for apidoc p||get_cv
1933
1934 Returns the CV of the specified Perl subroutine.  If C<create> is set and
1935 the Perl subroutine does not exist then it will be declared (which has the
1936 same effect as saying C<sub name;>).  If C<create> is not set and the
1937 subroutine does not exist then NULL is returned.
1938
1939 =cut
1940 */
1941
1942 CV*
1943 Perl_get_cv(pTHX_ const char *name, I32 create)
1944 {
1945     GV* gv = gv_fetchpv(name, create, SVt_PVCV);
1946     /* XXX unsafe for threads if eval_owner isn't held */
1947     /* XXX this is probably not what they think they're getting.
1948      * It has the same effect as "sub name;", i.e. just a forward
1949      * declaration! */
1950     if (create && !GvCVu(gv))
1951         return newSUB(start_subparse(FALSE, 0),
1952                       newSVOP(OP_CONST, 0, newSVpv(name,0)),
1953                       Nullop,
1954                       Nullop);
1955     if (gv)
1956         return GvCVu(gv);
1957     return Nullcv;
1958 }
1959
1960 /* Be sure to refetch the stack pointer after calling these routines. */
1961
1962 /*
1963
1964 =head1 Callback Functions
1965
1966 =for apidoc p||call_argv
1967
1968 Performs a callback to the specified Perl sub.  See L<perlcall>.
1969
1970 =cut
1971 */
1972
1973 I32
1974 Perl_call_argv(pTHX_ const char *sub_name, I32 flags, register char **argv)
1975
1976                         /* See G_* flags in cop.h */
1977                         /* null terminated arg list */
1978 {
1979     dSP;
1980
1981     PUSHMARK(SP);
1982     if (argv) {
1983         while (*argv) {
1984             XPUSHs(sv_2mortal(newSVpv(*argv,0)));
1985             argv++;
1986         }
1987         PUTBACK;
1988     }
1989     return call_pv(sub_name, flags);
1990 }
1991
1992 /*
1993 =for apidoc p||call_pv
1994
1995 Performs a callback to the specified Perl sub.  See L<perlcall>.
1996
1997 =cut
1998 */
1999
2000 I32
2001 Perl_call_pv(pTHX_ const char *sub_name, I32 flags)
2002                         /* name of the subroutine */
2003                         /* See G_* flags in cop.h */
2004 {
2005     return call_sv((SV*)get_cv(sub_name, TRUE), flags);
2006 }
2007
2008 /*
2009 =for apidoc p||call_method
2010
2011 Performs a callback to the specified Perl method.  The blessed object must
2012 be on the stack.  See L<perlcall>.
2013
2014 =cut
2015 */
2016
2017 I32
2018 Perl_call_method(pTHX_ const char *methname, I32 flags)
2019                         /* name of the subroutine */
2020                         /* See G_* flags in cop.h */
2021 {
2022     return call_sv(sv_2mortal(newSVpv(methname,0)), flags | G_METHOD);
2023 }
2024
2025 /* May be called with any of a CV, a GV, or an SV containing the name. */
2026 /*
2027 =for apidoc p||call_sv
2028
2029 Performs a callback to the Perl sub whose name is in the SV.  See
2030 L<perlcall>.
2031
2032 =cut
2033 */
2034
2035 I32
2036 Perl_call_sv(pTHX_ SV *sv, I32 flags)
2037                         /* See G_* flags in cop.h */
2038 {
2039     dSP;
2040     LOGOP myop;         /* fake syntax tree node */
2041     UNOP method_op;
2042     I32 oldmark;
2043     volatile I32 retval = 0;
2044     I32 oldscope;
2045     bool oldcatch = CATCH_GET;
2046     int ret;
2047     OP* oldop = PL_op;
2048     dJMPENV;
2049
2050     if (flags & G_DISCARD) {
2051         ENTER;
2052         SAVETMPS;
2053     }
2054
2055     Zero(&myop, 1, LOGOP);
2056     myop.op_next = Nullop;
2057     if (!(flags & G_NOARGS))
2058         myop.op_flags |= OPf_STACKED;
2059     myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
2060                       (flags & G_ARRAY) ? OPf_WANT_LIST :
2061                       OPf_WANT_SCALAR);
2062     SAVEOP();
2063     PL_op = (OP*)&myop;
2064
2065     EXTEND(PL_stack_sp, 1);
2066     *++PL_stack_sp = sv;
2067     oldmark = TOPMARK;
2068     oldscope = PL_scopestack_ix;
2069
2070     if (PERLDB_SUB && PL_curstash != PL_debstash
2071            /* Handle first BEGIN of -d. */
2072           && (PL_DBcv || (PL_DBcv = GvCV(PL_DBsub)))
2073            /* Try harder, since this may have been a sighandler, thus
2074             * curstash may be meaningless. */
2075           && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != PL_debstash)
2076           && !(flags & G_NODEBUG))
2077         PL_op->op_private |= OPpENTERSUB_DB;
2078
2079     if (flags & G_METHOD) {
2080         Zero(&method_op, 1, UNOP);
2081         method_op.op_next = PL_op;
2082         method_op.op_ppaddr = PL_ppaddr[OP_METHOD];
2083         myop.op_ppaddr = PL_ppaddr[OP_ENTERSUB];
2084         PL_op = (OP*)&method_op;
2085     }
2086
2087     if (!(flags & G_EVAL)) {
2088         CATCH_SET(TRUE);
2089         call_body((OP*)&myop, FALSE);
2090         retval = PL_stack_sp - (PL_stack_base + oldmark);
2091         CATCH_SET(oldcatch);
2092     }
2093     else {
2094         myop.op_other = (OP*)&myop;
2095         PL_markstack_ptr--;
2096         /* we're trying to emulate pp_entertry() here */
2097         {
2098             register PERL_CONTEXT *cx;
2099             I32 gimme = GIMME_V;
2100
2101             ENTER;
2102             SAVETMPS;
2103
2104             PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
2105             PUSHEVAL(cx, 0, 0);
2106             PL_eval_root = PL_op;             /* Only needed so that goto works right. */
2107
2108             PL_in_eval = EVAL_INEVAL;
2109             if (flags & G_KEEPERR)
2110                 PL_in_eval |= EVAL_KEEPERR;
2111             else
2112                 sv_setpv(ERRSV,"");
2113         }
2114         PL_markstack_ptr++;
2115
2116 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2117  redo_body:
2118         CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_body),
2119                     (OP*)&myop, FALSE);
2120 #else
2121         JMPENV_PUSH(ret);
2122 #endif
2123         switch (ret) {
2124         case 0:
2125 #ifndef PERL_FLEXIBLE_EXCEPTIONS
2126  redo_body:
2127             call_body((OP*)&myop, FALSE);
2128 #endif
2129             retval = PL_stack_sp - (PL_stack_base + oldmark);
2130             if (!(flags & G_KEEPERR))
2131                 sv_setpv(ERRSV,"");
2132             break;
2133         case 1:
2134             STATUS_ALL_FAILURE;
2135             /* FALL THROUGH */
2136         case 2:
2137             /* my_exit() was called */
2138             PL_curstash = PL_defstash;
2139             FREETMPS;
2140             JMPENV_POP;
2141             if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
2142                 Perl_croak(aTHX_ "Callback called exit");
2143             my_exit_jump();
2144             /* NOTREACHED */
2145         case 3:
2146             if (PL_restartop) {
2147                 PL_op = PL_restartop;
2148                 PL_restartop = 0;
2149                 goto redo_body;
2150             }
2151             PL_stack_sp = PL_stack_base + oldmark;
2152             if (flags & G_ARRAY)
2153                 retval = 0;
2154             else {
2155                 retval = 1;
2156                 *++PL_stack_sp = &PL_sv_undef;
2157             }
2158             break;
2159         }
2160
2161         if (PL_scopestack_ix > oldscope) {
2162             SV **newsp;
2163             PMOP *newpm;
2164             I32 gimme;
2165             register PERL_CONTEXT *cx;
2166             I32 optype;
2167
2168             POPBLOCK(cx,newpm);
2169             POPEVAL(cx);
2170             PL_curpm = newpm;
2171             LEAVE;
2172         }
2173         JMPENV_POP;
2174     }
2175
2176     if (flags & G_DISCARD) {
2177         PL_stack_sp = PL_stack_base + oldmark;
2178         retval = 0;
2179         FREETMPS;
2180         LEAVE;
2181     }
2182     PL_op = oldop;
2183     return retval;
2184 }
2185
2186 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2187 STATIC void *
2188 S_vcall_body(pTHX_ va_list args)
2189 {
2190     OP *myop = va_arg(args, OP*);
2191     int is_eval = va_arg(args, int);
2192
2193     call_body(myop, is_eval);
2194     return NULL;
2195 }
2196 #endif
2197
2198 STATIC void
2199 S_call_body(pTHX_ OP *myop, int is_eval)
2200 {
2201     if (PL_op == myop) {
2202         if (is_eval)
2203             PL_op = Perl_pp_entereval(aTHX);    /* this doesn't do a POPMARK */
2204         else
2205             PL_op = Perl_pp_entersub(aTHX);     /* this does */
2206     }
2207     if (PL_op)
2208         CALLRUNOPS(aTHX);
2209 }
2210
2211 /* Eval a string. The G_EVAL flag is always assumed. */
2212
2213 /*
2214 =for apidoc p||eval_sv
2215
2216 Tells Perl to C<eval> the string in the SV.
2217
2218 =cut
2219 */
2220
2221 I32
2222 Perl_eval_sv(pTHX_ SV *sv, I32 flags)
2223
2224                         /* See G_* flags in cop.h */
2225 {
2226     dSP;
2227     UNOP myop;          /* fake syntax tree node */
2228     volatile I32 oldmark = SP - PL_stack_base;
2229     volatile I32 retval = 0;
2230     I32 oldscope;
2231     int ret;
2232     OP* oldop = PL_op;
2233     dJMPENV;
2234
2235     if (flags & G_DISCARD) {
2236         ENTER;
2237         SAVETMPS;
2238     }
2239
2240     SAVEOP();
2241     PL_op = (OP*)&myop;
2242     Zero(PL_op, 1, UNOP);
2243     EXTEND(PL_stack_sp, 1);
2244     *++PL_stack_sp = sv;
2245     oldscope = PL_scopestack_ix;
2246
2247     if (!(flags & G_NOARGS))
2248         myop.op_flags = OPf_STACKED;
2249     myop.op_next = Nullop;
2250     myop.op_type = OP_ENTEREVAL;
2251     myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
2252                       (flags & G_ARRAY) ? OPf_WANT_LIST :
2253                       OPf_WANT_SCALAR);
2254     if (flags & G_KEEPERR)
2255         myop.op_flags |= OPf_SPECIAL;
2256
2257 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2258  redo_body:
2259     CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_body),
2260                 (OP*)&myop, TRUE);
2261 #else
2262     /* fail now; otherwise we could fail after the JMPENV_PUSH but
2263      * before a PUSHEVAL, which corrupts the stack after a croak */
2264     TAINT_PROPER("eval_sv()");
2265
2266     JMPENV_PUSH(ret);
2267 #endif
2268     switch (ret) {
2269     case 0:
2270 #ifndef PERL_FLEXIBLE_EXCEPTIONS
2271  redo_body:
2272         call_body((OP*)&myop,TRUE);
2273 #endif
2274         retval = PL_stack_sp - (PL_stack_base + oldmark);
2275         if (!(flags & G_KEEPERR))
2276             sv_setpv(ERRSV,"");
2277         break;
2278     case 1:
2279         STATUS_ALL_FAILURE;
2280         /* FALL THROUGH */
2281     case 2:
2282         /* my_exit() was called */
2283         PL_curstash = PL_defstash;
2284         FREETMPS;
2285         JMPENV_POP;
2286         if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
2287             Perl_croak(aTHX_ "Callback called exit");
2288         my_exit_jump();
2289         /* NOTREACHED */
2290     case 3:
2291         if (PL_restartop) {
2292             PL_op = PL_restartop;
2293             PL_restartop = 0;
2294             goto redo_body;
2295         }
2296         PL_stack_sp = PL_stack_base + oldmark;
2297         if (flags & G_ARRAY)
2298             retval = 0;
2299         else {
2300             retval = 1;
2301             *++PL_stack_sp = &PL_sv_undef;
2302         }
2303         break;
2304     }
2305
2306     JMPENV_POP;
2307     if (flags & G_DISCARD) {
2308         PL_stack_sp = PL_stack_base + oldmark;
2309         retval = 0;
2310         FREETMPS;
2311         LEAVE;
2312     }
2313     PL_op = oldop;
2314     return retval;
2315 }
2316
2317 /*
2318 =for apidoc p||eval_pv
2319
2320 Tells Perl to C<eval> the given string and return an SV* result.
2321
2322 =cut
2323 */
2324
2325 SV*
2326 Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error)
2327 {
2328     dSP;
2329     SV* sv = newSVpv(p, 0);
2330
2331     eval_sv(sv, G_SCALAR);
2332     SvREFCNT_dec(sv);
2333
2334     SPAGAIN;
2335     sv = POPs;
2336     PUTBACK;
2337
2338     if (croak_on_error && SvTRUE(ERRSV)) {
2339         STRLEN n_a;
2340         Perl_croak(aTHX_ SvPVx(ERRSV, n_a));
2341     }
2342
2343     return sv;
2344 }
2345
2346 /* Require a module. */
2347
2348 /*
2349 =head1 Embedding Functions
2350
2351 =for apidoc p||require_pv
2352
2353 Tells Perl to C<require> the file named by the string argument.  It is
2354 analogous to the Perl code C<eval "require '$file'">.  It's even
2355 implemented that way; consider using load_module instead.
2356
2357 =cut */
2358
2359 void
2360 Perl_require_pv(pTHX_ const char *pv)
2361 {
2362     SV* sv;
2363     dSP;
2364     PUSHSTACKi(PERLSI_REQUIRE);
2365     PUTBACK;
2366     sv = sv_newmortal();
2367     sv_setpv(sv, "require '");
2368     sv_catpv(sv, pv);
2369     sv_catpv(sv, "'");
2370     eval_sv(sv, G_DISCARD);
2371     SPAGAIN;
2372     POPSTACK;
2373 }
2374
2375 void
2376 Perl_magicname(pTHX_ char *sym, char *name, I32 namlen)
2377 {
2378     register GV *gv;
2379
2380     if ((gv = gv_fetchpv(sym,TRUE, SVt_PV)))
2381         sv_magic(GvSV(gv), (SV*)gv, PERL_MAGIC_sv, name, namlen);
2382 }
2383
2384 STATIC void
2385 S_usage(pTHX_ char *name)               /* XXX move this out into a module ? */
2386 {
2387     /* This message really ought to be max 23 lines.
2388      * Removed -h because the user already knows that option. Others? */
2389
2390     static char *usage_msg[] = {
2391 "-0[octal]       specify record separator (\\0, if no argument)",
2392 "-a              autosplit mode with -n or -p (splits $_ into @F)",
2393 "-C[number/list] enables the listed Unicode features",
2394 "-c              check syntax only (runs BEGIN and CHECK blocks)",
2395 "-d[:debugger]   run program under debugger",
2396 "-D[number/list] set debugging flags (argument is a bit mask or alphabets)",
2397 "-e program      one line of program (several -e's allowed, omit programfile)",
2398 "-F/pattern/     split() pattern for -a switch (//'s are optional)",
2399 "-i[extension]   edit <> files in place (makes backup if extension supplied)",
2400 "-Idirectory     specify @INC/#include directory (several -I's allowed)",
2401 "-l[octal]       enable line ending processing, specifies line terminator",
2402 "-[mM][-]module  execute `use/no module...' before executing program",
2403 "-n              assume 'while (<>) { ... }' loop around program",
2404 "-p              assume loop like -n but print line also, like sed",
2405 "-P              run program through C preprocessor before compilation",
2406 "-s              enable rudimentary parsing for switches after programfile",
2407 "-S              look for programfile using PATH environment variable",
2408 "-t              enable tainting warnings",
2409 "-T              enable tainting checks",
2410 "-u              dump core after parsing program",
2411 "-U              allow unsafe operations",
2412 "-v              print version, subversion (includes VERY IMPORTANT perl info)",
2413 "-V[:variable]   print configuration summary (or a single Config.pm variable)",
2414 "-w              enable many useful warnings (RECOMMENDED)",
2415 "-W              enable all warnings",
2416 "-x[directory]   strip off text before #!perl line and perhaps cd to directory",
2417 "-X              disable all warnings",
2418 "\n",
2419 NULL
2420 };
2421     char **p = usage_msg;
2422
2423     PerlIO_printf(PerlIO_stdout(),
2424                   "\nUsage: %s [switches] [--] [programfile] [arguments]",
2425                   name);
2426     while (*p)
2427         PerlIO_printf(PerlIO_stdout(), "\n  %s", *p++);
2428 }
2429
2430 /* convert a string of -D options (or digits) into an int.
2431  * sets *s to point to the char after the options */
2432
2433 #ifdef DEBUGGING
2434 int
2435 Perl_get_debug_opts(pTHX_ char **s, bool givehelp)
2436 {
2437     static char *usage_msgd[] = {
2438       " Debugging flag values: (see also -d)",
2439       "  p  Tokenizing and parsing (with v, displays parse stack)",
2440       "  s  Stack snapshots (with v, displays all stacks)",
2441       "  l  Context (loop) stack processing",
2442       "  t  Trace execution",
2443       "  o  Method and overloading resolution",
2444       "  c  String/numeric conversions",
2445       "  P  Print profiling info, preprocessor command for -P, source file input state",
2446       "  m  Memory allocation",
2447       "  f  Format processing",
2448       "  r  Regular expression parsing and execution",
2449       "  x  Syntax tree dump",
2450       "  u  Tainting checks",
2451       "  H  Hash dump -- usurps values()",
2452       "  X  Scratchpad allocation",
2453       "  D  Cleaning up",
2454       "  S  Thread synchronization",
2455       "  T  Tokenising",
2456       "  R  Include reference counts of dumped variables (eg when using -Ds)",
2457       "  J  Do not s,t,P-debug (Jump over) opcodes within package DB",
2458       "  v  Verbose: use in conjunction with other flags",
2459       "  C  Copy On Write",
2460       "  A  Consistency checks on internal structures",
2461       "  q  quiet - currently only suppresses the 'EXECUTING' message",
2462       NULL
2463     };
2464     int i = 0;
2465     if (isALPHA(**s)) {
2466         /* if adding extra options, remember to update DEBUG_MASK */
2467         static char debopts[] = "psltocPmfrxu HXDSTRJvCAq";
2468
2469         for (; isALNUM(**s); (*s)++) {
2470             char *d = strchr(debopts,**s);
2471             if (d)
2472                 i |= 1 << (d - debopts);
2473             else if (ckWARN_d(WARN_DEBUGGING))
2474                 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
2475                     "invalid option -D%c, use -D'' to see choices\n", **s);
2476         }
2477     }
2478     else if (isDIGIT(**s)) {
2479         i = atoi(*s);
2480         for (; isALNUM(**s); (*s)++) ;
2481     }
2482     else if (givehelp) {
2483       char **p = usage_msgd;
2484       while (*p) PerlIO_printf(PerlIO_stdout(), "%s\n", *p++);
2485     }
2486 #  ifdef EBCDIC
2487     if ((i & DEBUG_p_FLAG) && ckWARN_d(WARN_DEBUGGING))
2488         Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
2489                 "-Dp not implemented on this platform\n");
2490 #  endif
2491     return i;
2492 }
2493 #endif
2494
2495 /* This routine handles any switches that can be given during run */
2496
2497 char *
2498 Perl_moreswitches(pTHX_ char *s)
2499 {
2500     STRLEN numlen;
2501     UV rschar;
2502
2503     switch (*s) {
2504     case '0':
2505     {
2506          I32 flags = 0;
2507
2508          SvREFCNT_dec(PL_rs);
2509          if (s[1] == 'x' && s[2]) {
2510               char *e;
2511               U8 *tmps;
2512
2513               for (s += 2, e = s; *e; e++);
2514               numlen = e - s;
2515               flags = PERL_SCAN_SILENT_ILLDIGIT;
2516               rschar = (U32)grok_hex(s, &numlen, &flags, NULL);
2517               if (s + numlen < e) {
2518                    rschar = 0; /* Grandfather -0xFOO as -0 -xFOO. */
2519                    numlen = 0;
2520                    s--;
2521               }
2522               PL_rs = newSVpvn("", 0);
2523               SvGROW(PL_rs, (STRLEN)(UNISKIP(rschar) + 1));
2524               tmps = (U8*)SvPVX(PL_rs);
2525               uvchr_to_utf8(tmps, rschar);
2526               SvCUR_set(PL_rs, UNISKIP(rschar));
2527               SvUTF8_on(PL_rs);
2528          }
2529          else {
2530               numlen = 4;
2531               rschar = (U32)grok_oct(s, &numlen, &flags, NULL);
2532               if (rschar & ~((U8)~0))
2533                    PL_rs = &PL_sv_undef;
2534               else if (!rschar && numlen >= 2)
2535                    PL_rs = newSVpvn("", 0);
2536               else {
2537                    char ch = (char)rschar;
2538                    PL_rs = newSVpvn(&ch, 1);
2539               }
2540          }
2541          sv_setsv(get_sv("/", TRUE), PL_rs);
2542          return s + numlen;
2543     }
2544     case 'C':
2545         s++;
2546         PL_unicode = parse_unicode_opts(&s);
2547         return s;
2548     case 'F':
2549         PL_minus_F = TRUE;
2550         PL_splitstr = ++s;
2551         while (*s && !isSPACE(*s)) ++s;
2552         *s = '\0';
2553         PL_splitstr = savepv(PL_splitstr);
2554         return s;
2555     case 'a':
2556         PL_minus_a = TRUE;
2557         s++;
2558         return s;
2559     case 'c':
2560         PL_minus_c = TRUE;
2561         s++;
2562         return s;
2563     case 'd':
2564         forbid_setid("-d");
2565         s++;
2566
2567         /* -dt indicates to the debugger that threads will be used */
2568         if (*s == 't' && !isALNUM(s[1])) {
2569             ++s;
2570             my_setenv("PERL5DB_THREADED", "1");
2571         }
2572
2573         /* The following permits -d:Mod to accepts arguments following an =
2574            in the fashion that -MSome::Mod does. */
2575         if (*s == ':' || *s == '=') {
2576             char *start;
2577             SV *sv;
2578             sv = newSVpv("use Devel::", 0);
2579             start = ++s;
2580             /* We now allow -d:Module=Foo,Bar */
2581             while(isALNUM(*s) || *s==':') ++s;
2582             if (*s != '=')
2583                 sv_catpv(sv, start);
2584             else {
2585                 sv_catpvn(sv, start, s-start);
2586                 sv_catpv(sv, " split(/,/,q{");
2587                 sv_catpv(sv, ++s);
2588                 sv_catpv(sv, "})");
2589             }
2590             s += strlen(s);
2591             my_setenv("PERL5DB", SvPV(sv, PL_na));
2592         }
2593         if (!PL_perldb) {
2594             PL_perldb = PERLDB_ALL;
2595             init_debugger();
2596         }
2597         return s;
2598     case 'D':
2599     {
2600 #ifdef DEBUGGING
2601         forbid_setid("-D");
2602         s++;
2603         PL_debug = get_debug_opts(&s, 1) | DEBUG_TOP_FLAG;
2604 #else /* !DEBUGGING */
2605         if (ckWARN_d(WARN_DEBUGGING))
2606             Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
2607                    "Recompile perl with -DDEBUGGING to use -D switch (did you mean -d ?)\n");
2608         for (s++; isALNUM(*s); s++) ;
2609 #endif
2610         /*SUPPRESS 530*/
2611         return s;
2612     }
2613     case 'h':
2614         usage(PL_origargv[0]);
2615         my_exit(0);
2616     case 'i':
2617         if (PL_inplace)
2618             Safefree(PL_inplace);
2619 #if defined(__CYGWIN__) /* do backup extension automagically */
2620         if (*(s+1) == '\0') {
2621         PL_inplace = savepv(".bak");
2622         return s+1;
2623         }
2624 #endif /* __CYGWIN__ */
2625         PL_inplace = savepv(s+1);
2626         /*SUPPRESS 530*/
2627         for (s = PL_inplace; *s && !isSPACE(*s); s++) ;
2628         if (*s) {
2629             *s++ = '\0';
2630             if (*s == '-')      /* Additional switches on #! line. */
2631                 s++;
2632         }
2633         return s;
2634     case 'I':   /* -I handled both here and in parse_body() */
2635         forbid_setid("-I");
2636         ++s;
2637         while (*s && isSPACE(*s))
2638             ++s;
2639         if (*s) {
2640             char *e, *p;
2641             p = s;
2642             /* ignore trailing spaces (possibly followed by other switches) */
2643             do {
2644                 for (e = p; *e && !isSPACE(*e); e++) ;
2645                 p = e;
2646                 while (isSPACE(*p))
2647                     p++;
2648             } while (*p && *p != '-');
2649             e = savepvn(s, e-s);
2650             incpush(e, TRUE, TRUE, FALSE, FALSE);
2651             Safefree(e);
2652             s = p;
2653             if (*s == '-')
2654                 s++;
2655         }
2656         else
2657             Perl_croak(aTHX_ "No directory specified for -I");
2658         return s;
2659     case 'l':
2660         PL_minus_l = TRUE;
2661         s++;
2662         if (PL_ors_sv) {
2663             SvREFCNT_dec(PL_ors_sv);
2664             PL_ors_sv = Nullsv;
2665         }
2666         if (isDIGIT(*s)) {
2667             I32 flags = 0;
2668             PL_ors_sv = newSVpvn("\n",1);
2669             numlen = 3 + (*s == '0');
2670             *SvPVX(PL_ors_sv) = (char)grok_oct(s, &numlen, &flags, NULL);
2671             s += numlen;
2672         }
2673         else {
2674             if (RsPARA(PL_rs)) {
2675                 PL_ors_sv = newSVpvn("\n\n",2);
2676             }
2677             else {
2678                 PL_ors_sv = newSVsv(PL_rs);
2679             }
2680         }
2681         return s;
2682     case 'A':
2683         forbid_setid("-A");
2684         if (!PL_preambleav)
2685             PL_preambleav = newAV();
2686         if (*++s) {
2687             SV *sv = newSVpv("use assertions::activate split(/,/,q", 0);
2688             sv_catpvn(sv, "\0", 1);     /* Use NUL as q//-delimiter. */
2689             sv_catpv(sv,s);
2690             sv_catpvn(sv, "\0)", 2);
2691             s+=strlen(s);
2692             av_push(PL_preambleav, sv);
2693         }
2694         else
2695             av_push(PL_preambleav, newSVpvn("use assertions::activate",24));
2696         return s;
2697     case 'M':
2698         forbid_setid("-M");     /* XXX ? */
2699         /* FALL THROUGH */
2700     case 'm':
2701         forbid_setid("-m");     /* XXX ? */
2702         if (*++s) {
2703             char *start;
2704             SV *sv;
2705             char *use = "use ";
2706             /* -M-foo == 'no foo'       */
2707             if (*s == '-') { use = "no "; ++s; }
2708             sv = newSVpv(use,0);
2709             start = s;
2710             /* We allow -M'Module qw(Foo Bar)'  */
2711             while(isALNUM(*s) || *s==':') ++s;
2712             if (*s != '=') {
2713                 sv_catpv(sv, start);
2714                 if (*(start-1) == 'm') {
2715                     if (*s != '\0')
2716                         Perl_croak(aTHX_ "Can't use '%c' after -mname", *s);
2717                     sv_catpv( sv, " ()");
2718                 }
2719             } else {
2720                 if (s == start)
2721                     Perl_croak(aTHX_ "Module name required with -%c option",
2722                                s[-1]);
2723                 sv_catpvn(sv, start, s-start);
2724                 sv_catpv(sv, " split(/,/,q");
2725                 sv_catpvn(sv, "\0)", 1);        /* Use NUL as q//-delimiter. */
2726                 sv_catpv(sv, ++s);
2727                 sv_catpvn(sv,  "\0)", 2);
2728             }
2729             s += strlen(s);
2730             if (!PL_preambleav)
2731                 PL_preambleav = newAV();
2732             av_push(PL_preambleav, sv);
2733         }
2734         else
2735             Perl_croak(aTHX_ "Missing argument to -%c", *(s-1));
2736         return s;
2737     case 'n':
2738         PL_minus_n = TRUE;
2739         s++;
2740         return s;
2741     case 'p':
2742         PL_minus_p = TRUE;
2743         s++;
2744         return s;
2745     case 's':
2746         forbid_setid("-s");
2747         PL_doswitches = TRUE;
2748         s++;
2749         return s;
2750     case 't':
2751         if (!PL_tainting)
2752             TOO_LATE_FOR('t');
2753         s++;
2754         return s;
2755     case 'T':
2756         if (!PL_tainting)
2757             TOO_LATE_FOR('T');
2758         s++;
2759         return s;
2760     case 'u':
2761 #ifdef MACOS_TRADITIONAL
2762         Perl_croak(aTHX_ "Believe me, you don't want to use \"-u\" on a Macintosh");
2763 #endif
2764         PL_do_undump = TRUE;
2765         s++;
2766         return s;
2767     case 'U':
2768         PL_unsafe = TRUE;
2769         s++;
2770         return s;
2771     case 'v':
2772         if (!sv_derived_from(PL_patchlevel, "version"))
2773                 (void *)upg_version(PL_patchlevel);
2774 #if !defined(DGUX)
2775         PerlIO_printf(PerlIO_stdout(),
2776                 Perl_form(aTHX_ "\nThis is perl, v%_ built for %s",
2777                     vstringify(PL_patchlevel),
2778                     ARCHNAME));
2779 #else /* DGUX */
2780 /* Adjust verbose output as in the perl that ships with the DG/UX OS from EMC */
2781         PerlIO_printf(PerlIO_stdout(),
2782                 Perl_form(aTHX_ "\nThis is perl, v%_\n",
2783                     vstringify(PL_patchlevel)));
2784         PerlIO_printf(PerlIO_stdout(),
2785                         Perl_form(aTHX_ "        built under %s at %s %s\n",
2786                                         OSNAME, __DATE__, __TIME__));
2787         PerlIO_printf(PerlIO_stdout(),
2788                         Perl_form(aTHX_ "        OS Specific Release: %s\n",
2789                                         OSVERS));
2790 #endif /* !DGUX */
2791
2792 #if defined(LOCAL_PATCH_COUNT)
2793         if (LOCAL_PATCH_COUNT > 0)
2794             PerlIO_printf(PerlIO_stdout(),
2795                           "\n(with %d registered patch%s, "
2796                           "see perl -V for more detail)",
2797                           (int)LOCAL_PATCH_COUNT,
2798                           (LOCAL_PATCH_COUNT!=1) ? "es" : "");
2799 #endif
2800
2801         PerlIO_printf(PerlIO_stdout(),
2802                       "\n\nCopyright 1987-2004, Larry Wall\n");
2803 #ifdef MACOS_TRADITIONAL
2804         PerlIO_printf(PerlIO_stdout(),
2805                       "\nMac OS port Copyright 1991-2002, Matthias Neeracher;\n"
2806                       "maintained by Chris Nandor\n");
2807 #endif
2808 #ifdef MSDOS
2809         PerlIO_printf(PerlIO_stdout(),
2810                       "\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
2811 #endif
2812 #ifdef DJGPP
2813         PerlIO_printf(PerlIO_stdout(),
2814                       "djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n"
2815                       "djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n");
2816 #endif
2817 #ifdef OS2
2818         PerlIO_printf(PerlIO_stdout(),
2819                       "\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
2820                       "Version 5 port Copyright (c) 1994-2002, Andreas Kaiser, Ilya Zakharevich\n");
2821 #endif
2822 #ifdef atarist
2823         PerlIO_printf(PerlIO_stdout(),
2824                       "atariST series port, ++jrb  bammi@cadence.com\n");
2825 #endif
2826 #ifdef __BEOS__
2827         PerlIO_printf(PerlIO_stdout(),
2828                       "BeOS port Copyright Tom Spindler, 1997-1999\n");
2829 #endif
2830 #ifdef MPE
2831         PerlIO_printf(PerlIO_stdout(),
2832                       "MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-2003\n");
2833 #endif
2834 #ifdef OEMVS
2835         PerlIO_printf(PerlIO_stdout(),
2836                       "MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
2837 #endif
2838 #ifdef __VOS__
2839         PerlIO_printf(PerlIO_stdout(),
2840                       "Stratus VOS port by Paul.Green@stratus.com, 1997-2002\n");
2841 #endif
2842 #ifdef __OPEN_VM
2843         PerlIO_printf(PerlIO_stdout(),
2844                       "VM/ESA port by Neale Ferguson, 1998-1999\n");
2845 #endif
2846 #ifdef POSIX_BC
2847         PerlIO_printf(PerlIO_stdout(),
2848                       "BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
2849 #endif
2850 #ifdef __MINT__
2851         PerlIO_printf(PerlIO_stdout(),
2852                       "MiNT port by Guido Flohr, 1997-1999\n");
2853 #endif
2854 #ifdef EPOC
2855         PerlIO_printf(PerlIO_stdout(),
2856                       "EPOC port by Olaf Flebbe, 1999-2002\n");
2857 #endif
2858 #ifdef UNDER_CE
2859         PerlIO_printf(PerlIO_stdout(),"WINCE port by Rainer Keuchel, 2001-2002\n");
2860         PerlIO_printf(PerlIO_stdout(),"Built on " __DATE__ " " __TIME__ "\n\n");
2861         wce_hitreturn();
2862 #endif
2863 #ifdef BINARY_BUILD_NOTICE
2864         BINARY_BUILD_NOTICE;
2865 #endif
2866         PerlIO_printf(PerlIO_stdout(),
2867                       "\n\
2868 Perl may be copied only under the terms of either the Artistic License or the\n\
2869 GNU General Public License, which may be found in the Perl 5 source kit.\n\n\
2870 Complete documentation for Perl, including FAQ lists, should be found on\n\
2871 this system using `man perl' or `perldoc perl'.  If you have access to the\n\
2872 Internet, point your browser at http://www.perl.org/, the Perl Home Page.\n\n");
2873         my_exit(0);
2874     case 'w':
2875         if (! (PL_dowarn & G_WARN_ALL_MASK))
2876             PL_dowarn |= G_WARN_ON;
2877         s++;
2878         return s;
2879     case 'W':
2880         PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
2881         if (!specialWARN(PL_compiling.cop_warnings))
2882             SvREFCNT_dec(PL_compiling.cop_warnings);
2883         PL_compiling.cop_warnings = pWARN_ALL ;
2884         s++;
2885         return s;
2886     case 'X':
2887         PL_dowarn = G_WARN_ALL_OFF;
2888         if (!specialWARN(PL_compiling.cop_warnings))
2889             SvREFCNT_dec(PL_compiling.cop_warnings);
2890         PL_compiling.cop_warnings = pWARN_NONE ;
2891         s++;
2892         return s;
2893     case '*':
2894     case ' ':
2895         if (s[1] == '-')        /* Additional switches on #! line. */
2896             return s+2;
2897         break;
2898     case '-':
2899     case 0:
2900 #if defined(WIN32) || !defined(PERL_STRICT_CR)
2901     case '\r':
2902 #endif
2903     case '\n':
2904     case '\t':
2905         break;
2906 #ifdef ALTERNATE_SHEBANG
2907     case 'S':                   /* OS/2 needs -S on "extproc" line. */
2908         break;
2909 #endif
2910     case 'P':
2911         if (PL_preprocess)
2912             return s+1;
2913         /* FALL THROUGH */
2914     default:
2915         Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s);
2916     }
2917     return Nullch;
2918 }
2919
2920 /* compliments of Tom Christiansen */
2921
2922 /* unexec() can be found in the Gnu emacs distribution */
2923 /* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
2924
2925 void
2926 Perl_my_unexec(pTHX)
2927 {
2928 #ifdef UNEXEC
2929     SV*    prog;
2930     SV*    file;
2931     int    status = 1;
2932     extern int etext;
2933
2934     prog = newSVpv(BIN_EXP, 0);
2935     sv_catpv(prog, "/perl");
2936     file = newSVpv(PL_origfilename, 0);
2937     sv_catpv(file, ".perldump");
2938
2939     unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
2940     /* unexec prints msg to stderr in case of failure */
2941     PerlProc_exit(status);
2942 #else
2943 #  ifdef VMS
2944 #    include <lib$routines.h>
2945      lib$signal(SS$_DEBUG);  /* ssdef.h #included from vmsish.h */
2946 #  else
2947     ABORT();            /* for use with undump */
2948 #  endif
2949 #endif
2950 }
2951
2952 /* initialize curinterp */
2953 STATIC void
2954 S_init_interp(pTHX)
2955 {
2956
2957 #ifdef MULTIPLICITY
2958 #  define PERLVAR(var,type)
2959 #  define PERLVARA(var,n,type)
2960 #  if defined(PERL_IMPLICIT_CONTEXT)
2961 #    if defined(USE_5005THREADS)
2962 #      define PERLVARI(var,type,init)           PERL_GET_INTERP->var = init;
2963 #      define PERLVARIC(var,type,init)  PERL_GET_INTERP->var = init;
2964 #    else /* !USE_5005THREADS */
2965 #      define PERLVARI(var,type,init)           aTHX->var = init;
2966 #      define PERLVARIC(var,type,init)  aTHX->var = init;
2967 #    endif /* USE_5005THREADS */
2968 #  else
2969 #    define PERLVARI(var,type,init)     PERL_GET_INTERP->var = init;
2970 #    define PERLVARIC(var,type,init)    PERL_GET_INTERP->var = init;
2971 #  endif
2972 #  include "intrpvar.h"
2973 #  ifndef USE_5005THREADS
2974 #    include "thrdvar.h"
2975 #  endif
2976 #  undef PERLVAR
2977 #  undef PERLVARA
2978 #  undef PERLVARI
2979 #  undef PERLVARIC
2980 #else
2981 #  define PERLVAR(var,type)
2982 #  define PERLVARA(var,n,type)
2983 #  define PERLVARI(var,type,init)       PL_##var = init;
2984 #  define PERLVARIC(var,type,init)      PL_##var = init;
2985 #  include "intrpvar.h"
2986 #  ifndef USE_5005THREADS
2987 #    include "thrdvar.h"
2988 #  endif
2989 #  undef PERLVAR
2990 #  undef PERLVARA
2991 #  undef PERLVARI
2992 #  undef PERLVARIC
2993 #endif
2994
2995 }
2996
2997 STATIC void
2998 S_init_main_stash(pTHX)
2999 {
3000     GV *gv;
3001
3002     PL_curstash = PL_defstash = newHV();
3003     PL_curstname = newSVpvn("main",4);
3004     gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
3005     SvREFCNT_dec(GvHV(gv));
3006     GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash);
3007     SvREADONLY_on(gv);
3008     HvNAME(PL_defstash) = savepv("main");
3009     PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
3010     GvMULTI_on(PL_incgv);
3011     PL_hintgv = gv_fetchpv("\010",TRUE, SVt_PV); /* ^H */
3012     GvMULTI_on(PL_hintgv);
3013     PL_defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
3014     PL_errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
3015     GvMULTI_on(PL_errgv);
3016     PL_replgv = gv_fetchpv("\022", TRUE, SVt_PV); /* ^R */
3017     GvMULTI_on(PL_replgv);
3018     (void)Perl_form(aTHX_ "%240s","");  /* Preallocate temp - for immediate signals. */
3019     sv_grow(ERRSV, 240);        /* Preallocate - for immediate signals. */
3020     sv_setpvn(ERRSV, "", 0);
3021     PL_curstash = PL_defstash;
3022     CopSTASH_set(&PL_compiling, PL_defstash);
3023     PL_debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
3024     PL_globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
3025     /* We must init $/ before switches are processed. */
3026     sv_setpvn(get_sv("/", TRUE), "\n", 1);
3027 }
3028
3029 /* PSz 18 Nov 03  fdscript now global but do not change prototype */
3030 STATIC void
3031 S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv)
3032 {
3033 #ifndef IAMSUID
3034     char *quote;
3035     char *code;
3036     char *cpp_discard_flag;
3037     char *perl;
3038 #endif
3039
3040     PL_fdscript = -1;
3041     PL_suidscript = -1;
3042
3043     if (PL_e_script) {
3044         PL_origfilename = savepv("-e");
3045     }
3046     else {
3047         /* if find_script() returns, it returns a malloc()-ed value */
3048         PL_origfilename = scriptname = find_script(scriptname, dosearch, NULL, 1);
3049
3050         if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
3051             char *s = scriptname + 8;
3052             PL_fdscript = atoi(s);
3053             while (isDIGIT(*s))
3054                 s++;
3055             if (*s) {
3056                 /* PSz 18 Feb 04
3057                  * Tell apart "normal" usage of fdscript, e.g.
3058                  * with bash on FreeBSD:
3059                  *   perl <( echo '#!perl -DA'; echo 'print "$0\n"')
3060                  * from usage in suidperl.
3061                  * Does any "normal" usage leave garbage after the number???
3062                  * Is it a mistake to use a similar /dev/fd/ construct for
3063                  * suidperl?
3064                  */
3065                 PL_suidscript = 1;
3066                 /* PSz 20 Feb 04
3067                  * Be supersafe and do some sanity-checks.
3068                  * Still, can we be sure we got the right thing?
3069                  */
3070                 if (*s != '/') {
3071                     Perl_croak(aTHX_ "Wrong syntax (suid) fd script name \"%s\"\n", s);
3072                 }
3073                 if (! *(s+1)) {
3074                     Perl_croak(aTHX_ "Missing (suid) fd script name\n");
3075                 }
3076                 scriptname = savepv(s + 1);
3077                 Safefree(PL_origfilename);
3078                 PL_origfilename = scriptname;
3079             }
3080         }
3081     }
3082
3083     CopFILE_free(PL_curcop);
3084     CopFILE_set(PL_curcop, PL_origfilename);
3085     if (*PL_origfilename == '-' && PL_origfilename[1] == '\0')
3086         scriptname = "";
3087     if (PL_fdscript >= 0) {
3088         PL_rsfp = PerlIO_fdopen(PL_fdscript,PERL_SCRIPT_MODE);
3089 #       if defined(HAS_FCNTL) && defined(F_SETFD)
3090             if (PL_rsfp)
3091                 /* ensure close-on-exec */
3092                 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);
3093 #       endif
3094     }
3095 #ifdef IAMSUID
3096     else {
3097         Perl_croak(aTHX_ "sperl needs fd script\n"
3098                    "You should not call sperl directly; do you need to "
3099                    "change a #! line\nfrom sperl to perl?\n");
3100
3101 /* PSz 11 Nov 03
3102  * Do not open (or do other fancy stuff) while setuid.
3103  * Perl does the open, and hands script to suidperl on a fd;
3104  * suidperl only does some checks, sets up UIDs and re-execs
3105  * perl with that fd as it has always done.
3106  */
3107     }
3108     if (PL_suidscript != 1) {
3109         Perl_croak(aTHX_ "suidperl needs (suid) fd script\n");
3110     }
3111 #else /* IAMSUID */
3112     else if (PL_preprocess) {
3113         char *cpp_cfg = CPPSTDIN;
3114         SV *cpp = newSVpvn("",0);
3115         SV *cmd = NEWSV(0,0);
3116
3117         if (cpp_cfg[0] == 0) /* PERL_MICRO? */
3118              Perl_croak(aTHX_ "Can't run with cpp -P with CPPSTDIN undefined");
3119         if (strEQ(cpp_cfg, "cppstdin"))
3120             Perl_sv_catpvf(aTHX_ cpp, "%s/", BIN_EXP);
3121         sv_catpv(cpp, cpp_cfg);
3122
3123 #       ifndef VMS
3124             sv_catpvn(sv, "-I", 2);
3125             sv_catpv(sv,PRIVLIB_EXP);
3126 #       endif
3127
3128         DEBUG_P(PerlIO_printf(Perl_debug_log,
3129                               "PL_preprocess: scriptname=\"%s\", cpp=\"%s\", sv=\"%s\", CPPMINUS=\"%s\"\n",
3130                               scriptname, SvPVX (cpp), SvPVX (sv), CPPMINUS));
3131
3132 #       if defined(MSDOS) || defined(WIN32) || defined(VMS)
3133             quote = "\"";
3134 #       else
3135             quote = "'";
3136 #       endif
3137
3138 #       ifdef VMS
3139             cpp_discard_flag = "";
3140 #       else
3141             cpp_discard_flag = "-C";
3142 #       endif
3143
3144 #       ifdef OS2
3145             perl = os2_execname(aTHX);
3146 #       else
3147             perl = PL_origargv[0];
3148 #       endif
3149
3150
3151         /* This strips off Perl comments which might interfere with
3152            the C pre-processor, including #!.  #line directives are
3153            deliberately stripped to avoid confusion with Perl's version
3154            of #line.  FWP played some golf with it so it will fit
3155            into VMS's 255 character buffer.
3156         */
3157         if( PL_doextract )
3158             code = "(1../^#!.*perl/i)|/^\\s*#(?!\\s*((ifn?|un)def|(el|end)?if|define|include|else|error|pragma)\\b)/||!($|=1)||print";
3159         else
3160             code = "/^\\s*#(?!\\s*((ifn?|un)def|(el|end)?if|define|include|else|error|pragma)\\b)/||!($|=1)||print";
3161
3162         Perl_sv_setpvf(aTHX_ cmd, "\
3163 %s -ne%s%s%s %s | %"SVf" %s %"SVf" %s",
3164                        perl, quote, code, quote, scriptname, cpp,
3165                        cpp_discard_flag, sv, CPPMINUS);
3166
3167         PL_doextract = FALSE;
3168
3169         DEBUG_P(PerlIO_printf(Perl_debug_log,
3170                               "PL_preprocess: cmd=\"%s\"\n",
3171                               SvPVX(cmd)));
3172
3173         PL_rsfp = PerlProc_popen(SvPVX(cmd), "r");
3174         SvREFCNT_dec(cmd);
3175         SvREFCNT_dec(cpp);
3176     }
3177     else if (!*scriptname) {
3178         forbid_setid("program input from stdin");
3179         PL_rsfp = PerlIO_stdin();
3180     }
3181     else {
3182         PL_rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
3183 #       if defined(HAS_FCNTL) && defined(F_SETFD)
3184             if (PL_rsfp)
3185                 /* ensure close-on-exec */
3186                 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);
3187 #       endif
3188     }
3189 #endif /* IAMSUID */
3190     if (!PL_rsfp) {
3191         /* PSz 16 Sep 03  Keep neat error message */
3192         Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
3193                 CopFILE(PL_curcop), Strerror(errno));
3194     }
3195 }
3196
3197 /* Mention
3198  * I_SYSSTATVFS HAS_FSTATVFS
3199  * I_SYSMOUNT
3200  * I_STATFS     HAS_FSTATFS     HAS_GETFSSTAT
3201  * I_MNTENT     HAS_GETMNTENT   HAS_HASMNTOPT
3202  * here so that metaconfig picks them up. */
3203
3204 #ifdef IAMSUID
3205 STATIC int
3206 S_fd_on_nosuid_fs(pTHX_ int fd)
3207 {
3208 /* PSz 27 Feb 04
3209  * We used to do this as "plain" user (after swapping UIDs with setreuid);
3210  * but is needed also on machines without setreuid.
3211  * Seems safe enough to run as root.
3212  */
3213     int check_okay = 0; /* able to do all the required sys/libcalls */
3214     int on_nosuid  = 0; /* the fd is on a nosuid fs */
3215     /* PSz 12 Nov 03
3216      * Need to check noexec also: nosuid might not be set, the average
3217      * sysadmin would say that nosuid is irrelevant once he sets noexec.
3218      */
3219     int on_noexec  = 0; /* the fd is on a noexec fs */
3220
3221 /*
3222  * Preferred order: fstatvfs(), fstatfs(), ustat()+getmnt(), getmntent().
3223  * fstatvfs() is UNIX98.
3224  * fstatfs() is 4.3 BSD.
3225  * ustat()+getmnt() is pre-4.3 BSD.
3226  * getmntent() is O(number-of-mounted-filesystems) and can hang on
3227  * an irrelevant filesystem while trying to reach the right one.
3228  */
3229
3230 #undef FD_ON_NOSUID_CHECK_OKAY  /* found the syscalls to do the check? */
3231
3232 #   if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
3233         defined(HAS_FSTATVFS)
3234 #   define FD_ON_NOSUID_CHECK_OKAY
3235     struct statvfs stfs;
3236
3237     check_okay = fstatvfs(fd, &stfs) == 0;
3238     on_nosuid  = check_okay && (stfs.f_flag  & ST_NOSUID);
3239 #ifdef ST_NOEXEC
3240     /* ST_NOEXEC certainly absent on AIX 5.1, and doesn't seem to be documented
3241        on platforms where it is present.  */
3242     on_noexec  = check_okay && (stfs.f_flag  & ST_NOEXEC);
3243 #endif
3244 #   endif /* fstatvfs */
3245
3246 #   if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
3247         defined(PERL_MOUNT_NOSUID)      && \
3248         defined(PERL_MOUNT_NOEXEC)      && \
3249         defined(HAS_FSTATFS)            && \
3250         defined(HAS_STRUCT_STATFS)      && \
3251         defined(HAS_STRUCT_STATFS_F_FLAGS)
3252 #   define FD_ON_NOSUID_CHECK_OKAY
3253     struct statfs  stfs;
3254
3255     check_okay = fstatfs(fd, &stfs)  == 0;
3256     on_nosuid  = check_okay && (stfs.f_flags & PERL_MOUNT_NOSUID);
3257     on_noexec  = check_okay && (stfs.f_flags & PERL_MOUNT_NOEXEC);
3258 #   endif /* fstatfs */
3259
3260 #   if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
3261         defined(PERL_MOUNT_NOSUID)      && \
3262         defined(PERL_MOUNT_NOEXEC)      && \
3263         defined(HAS_FSTAT)              && \
3264         defined(HAS_USTAT)              && \
3265         defined(HAS_GETMNT)             && \
3266         defined(HAS_STRUCT_FS_DATA)     && \
3267         defined(NOSTAT_ONE)
3268 #   define FD_ON_NOSUID_CHECK_OKAY
3269     Stat_t fdst;
3270
3271     if (fstat(fd, &fdst) == 0) {
3272         struct ustat us;
3273         if (ustat(fdst.st_dev, &us) == 0) {
3274             struct fs_data fsd;
3275             /* NOSTAT_ONE here because we're not examining fields which
3276              * vary between that case and STAT_ONE. */
3277             if (getmnt((int*)0, &fsd, (int)0, NOSTAT_ONE, us.f_fname) == 0) {
3278                 size_t cmplen = sizeof(us.f_fname);
3279                 if (sizeof(fsd.fd_req.path) < cmplen)
3280                     cmplen = sizeof(fsd.fd_req.path);
3281                 if (strnEQ(fsd.fd_req.path, us.f_fname, cmplen) &&
3282                     fdst.st_dev == fsd.fd_req.dev) {
3283                         check_okay = 1;
3284                         on_nosuid = fsd.fd_req.flags & PERL_MOUNT_NOSUID;
3285                         on_noexec = fsd.fd_req.flags & PERL_MOUNT_NOEXEC;
3286                     }
3287                 }
3288             }
3289         }
3290     }
3291 #   endif /* fstat+ustat+getmnt */
3292
3293 #   if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
3294         defined(HAS_GETMNTENT)          && \
3295         defined(HAS_HASMNTOPT)          && \
3296         defined(MNTOPT_NOSUID)          && \
3297         defined(MNTOPT_NOEXEC)
3298 #   define FD_ON_NOSUID_CHECK_OKAY
3299     FILE                *mtab = fopen("/etc/mtab", "r");
3300     struct mntent       *entry;
3301     Stat_t              stb, fsb;
3302
3303     if (mtab && (fstat(fd, &stb) == 0)) {
3304         while (entry = getmntent(mtab)) {
3305             if (stat(entry->mnt_dir, &fsb) == 0
3306                 && fsb.st_dev == stb.st_dev)
3307             {
3308                 /* found the filesystem */
3309                 check_okay = 1;
3310                 if (hasmntopt(entry, MNTOPT_NOSUID))
3311                     on_nosuid = 1;
3312                 if (hasmntopt(entry, MNTOPT_NOEXEC))
3313                     on_noexec = 1;
3314                 break;
3315             } /* A single fs may well fail its stat(). */
3316         }
3317     }
3318     if (mtab)
3319         fclose(mtab);
3320 #   endif /* getmntent+hasmntopt */
3321
3322     if (!check_okay)
3323         Perl_croak(aTHX_ "Can't check filesystem of script \"%s\" for nosuid/noexec", PL_origfilename);
3324     if (on_nosuid)
3325         Perl_croak(aTHX_ "Setuid script \"%s\" on nosuid filesystem", PL_origfilename);
3326     if (on_noexec)
3327         Perl_croak(aTHX_ "Setuid script \"%s\" on noexec filesystem", PL_origfilename);
3328     return ((!check_okay) || on_nosuid || on_noexec);
3329 }
3330 #endif /* IAMSUID */
3331
3332 STATIC void
3333 S_validate_suid(pTHX_ char *validarg, char *scriptname)
3334 {
3335 #ifdef IAMSUID
3336     /* int which; */
3337 #endif /* IAMSUID */
3338
3339     /* do we need to emulate setuid on scripts? */
3340
3341     /* This code is for those BSD systems that have setuid #! scripts disabled
3342      * in the kernel because of a security problem.  Merely defining DOSUID
3343      * in perl will not fix that problem, but if you have disabled setuid
3344      * scripts in the kernel, this will attempt to emulate setuid and setgid
3345      * on scripts that have those now-otherwise-useless bits set.  The setuid
3346      * root version must be called suidperl or sperlN.NNN.  If regular perl
3347      * discovers that it has opened a setuid script, it calls suidperl with
3348      * the same argv that it had.  If suidperl finds that the script it has
3349      * just opened is NOT setuid root, it sets the effective uid back to the
3350      * uid.  We don't just make perl setuid root because that loses the
3351      * effective uid we had before invoking perl, if it was different from the
3352      * uid.
3353      * PSz 27 Feb 04
3354      * Description/comments above do not match current workings:
3355      *   suidperl must be hardlinked to sperlN.NNN (that is what we exec);
3356      *   suidperl called with script open and name changed to /dev/fd/N/X;
3357      *   suidperl croaks if script is not setuid;
3358      *   making perl setuid would be a huge security risk (and yes, that
3359      *     would lose any euid we might have had).
3360      *
3361      * DOSUID must be defined in both perl and suidperl, and IAMSUID must
3362      * be defined in suidperl only.  suidperl must be setuid root.  The
3363      * Configure script will set this up for you if you want it.
3364      */
3365
3366 #ifdef DOSUID
3367     char *s, *s2;
3368
3369     if (PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf) < 0)  /* normal stat is insecure */
3370         Perl_croak(aTHX_ "Can't stat script \"%s\"",PL_origfilename);
3371     if (PL_statbuf.st_mode & (S_ISUID|S_ISGID)) {
3372         I32 len;
3373         STRLEN n_a;
3374
3375 #ifdef IAMSUID
3376         if (PL_fdscript < 0 || PL_suidscript != 1)
3377             Perl_croak(aTHX_ "Need (suid) fdscript in suidperl\n");     /* We already checked this */
3378         /* PSz 11 Nov 03
3379          * Since the script is opened by perl, not suidperl, some of these
3380          * checks are superfluous. Leaving them in probably does not lower
3381          * security(?!).
3382          */
3383         /* PSz 27 Feb 04
3384          * Do checks even for systems with no HAS_SETREUID.
3385          * We used to swap, then re-swap UIDs with
3386 #ifdef HAS_SETREUID
3387             if (setreuid(PL_euid,PL_uid) < 0
3388                 || PerlProc_getuid() != PL_euid || PerlProc_geteuid() != PL_uid)
3389                 Perl_croak(aTHX_ "Can't swap uid and euid");
3390 #endif
3391 #ifdef HAS_SETREUID
3392             if (setreuid(PL_uid,PL_euid) < 0
3393                 || PerlProc_getuid() != PL_uid || PerlProc_geteuid() != PL_euid)
3394                 Perl_croak(aTHX_ "Can't reswap uid and euid");
3395 #endif
3396          */
3397
3398         /* On this access check to make sure the directories are readable,
3399          * there is actually a small window that the user could use to make
3400          * filename point to an accessible directory.  So there is a faint
3401          * chance that someone could execute a setuid script down in a
3402          * non-accessible directory.  I don't know what to do about that.
3403          * But I don't think it's too important.  The manual lies when
3404          * it says access() is useful in setuid programs.
3405          *
3406          * So, access() is pretty useless... but not harmful... do anyway.
3407          */
3408         if (PerlLIO_access(CopFILE(PL_curcop),1)) { /*double check*/
3409             Perl_croak(aTHX_ "Can't access() script\n");
3410         }
3411
3412         /* If we can swap euid and uid, then we can determine access rights
3413          * with a simple stat of the file, and then compare device and
3414          * inode to make sure we did stat() on the same file we opened.
3415          * Then we just have to make sure he or she can execute it.
3416          *
3417          * PSz 24 Feb 04
3418          * As the script is opened by perl, not suidperl, we do not need to
3419          * care much about access rights.
3420          *
3421          * The 'script changed' check is needed, or we can get lied to
3422          * about $0 with e.g.
3423          *  suidperl /dev/fd/4//bin/x 4<setuidscript
3424          * Without HAS_SETREUID, is it safe to stat() as root?
3425          *
3426          * Are there any operating systems that pass /dev/fd/xxx for setuid
3427          * scripts, as suggested/described in perlsec(1)? Surely they do not
3428          * pass the script name as we do, so the "script changed" test would
3429          * fail for them... but we never get here with
3430          * SETUID_SCRIPTS_ARE_SECURE_NOW defined.
3431          *
3432          * This is one place where we must "lie" about return status: not
3433          * say if the stat() failed. We are doing this as root, and could
3434          * be tricked into reporting existence or not of files that the
3435          * "plain" user cannot even see.
3436          */
3437         {
3438             Stat_t tmpstatbuf;
3439             if (PerlLIO_stat(CopFILE(PL_curcop),&tmpstatbuf) < 0 ||
3440                 tmpstatbuf.st_dev != PL_statbuf.st_dev ||
3441                 tmpstatbuf.st_ino != PL_statbuf.st_ino) {
3442                 Perl_croak(aTHX_ "Setuid script changed\n");
3443             }
3444
3445         }
3446         if (!cando(S_IXUSR,FALSE,&PL_statbuf))          /* can real uid exec? */
3447             Perl_croak(aTHX_ "Real UID cannot exec script\n");
3448
3449         /* PSz 27 Feb 04
3450          * We used to do this check as the "plain" user (after swapping
3451          * UIDs). But the check for nosuid and noexec filesystem is needed,
3452          * and should be done even without HAS_SETREUID. (Maybe those
3453          * operating systems do not have such mount options anyway...)
3454          * Seems safe enough to do as root.
3455          */
3456 #if !defined(NO_NOSUID_CHECK)
3457         if (fd_on_nosuid_fs(PerlIO_fileno(PL_rsfp))) {
3458             Perl_croak(aTHX_ "Setuid script on nosuid or noexec filesystem\n");
3459         }
3460 #endif
3461 #endif /* IAMSUID */
3462
3463         if (!S_ISREG(PL_statbuf.st_mode)) {
3464             Perl_croak(aTHX_ "Setuid script not plain file\n");
3465         }
3466         if (PL_statbuf.st_mode & S_IWOTH)
3467             Perl_croak(aTHX_ "Setuid/gid script is writable by world");
3468         PL_doswitches = FALSE;          /* -s is insecure in suid */
3469         /* PSz 13 Nov 03  But -s was caught elsewhere ... so unsetting it here is useless(?!) */
3470         CopLINE_inc(PL_curcop);
3471         if (sv_gets(PL_linestr, PL_rsfp, 0) == Nullch ||
3472           strnNE(SvPV(PL_linestr,n_a),"#!",2) ) /* required even on Sys V */
3473             Perl_croak(aTHX_ "No #! line");
3474         s = SvPV(PL_linestr,n_a)+2;
3475         /* PSz 27 Feb 04 */
3476         /* Sanity check on line length */
3477         if (strlen(s) < 1 || strlen(s) > 4000)
3478             Perl_croak(aTHX_ "Very long #! line");
3479         /* Allow more than a single space after #! */
3480         while (isSPACE(*s)) s++;
3481         /* Sanity check on buffer end */
3482         while ((*s) && !isSPACE(*s)) s++;
3483         for (s2 = s;  (s2 > SvPV(PL_linestr,n_a)+2 &&
3484                        (isDIGIT(s2[-1]) || s2[-1] == '.' || s2[-1] == '_'
3485                         || s2[-1] == '-'));  s2--) ;
3486         /* Sanity check on buffer start */
3487         if ( (s2-4 < SvPV(PL_linestr,n_a)+2 || strnNE(s2-4,"perl",4)) &&
3488               (s-9 < SvPV(PL_linestr,n_a)+2 || strnNE(s-9,"perl",4)) )
3489             Perl_croak(aTHX_ "Not a perl script");
3490         while (*s == ' ' || *s == '\t') s++;
3491         /*
3492          * #! arg must be what we saw above.  They can invoke it by
3493          * mentioning suidperl explicitly, but they may not add any strange
3494          * arguments beyond what #! says if they do invoke suidperl that way.
3495          */
3496         /*
3497          * The way validarg was set up, we rely on the kernel to start
3498          * scripts with argv[1] set to contain all #! line switches (the
3499          * whole line).
3500          */
3501         /*
3502          * Check that we got all the arguments listed in the #! line (not
3503          * just that there are no extraneous arguments). Might not matter
3504          * much, as switches from #! line seem to be acted upon (also), and
3505          * so may be checked and trapped in perl. But, security checks must
3506          * be done in suidperl and not deferred to perl. Note that suidperl
3507          * does not get around to parsing (and checking) the switches on
3508          * the #! line (but execs perl sooner).
3509          * Allow (require) a trailing newline (which may be of two
3510          * characters on some architectures?) (but no other trailing
3511          * whitespace).
3512          */
3513         len = strlen(validarg);
3514         if (strEQ(validarg," PHOOEY ") ||
3515             strnNE(s,validarg,len) || !isSPACE(s[len]) ||
3516             !(strlen(s) == len+1 || (strlen(s) == len+2 && isSPACE(s[len+1]))))
3517             Perl_croak(aTHX_ "Args must match #! line");
3518
3519 #ifndef IAMSUID
3520         if (PL_fdscript < 0 &&
3521             PL_euid != PL_uid && (PL_statbuf.st_mode & S_ISUID) &&
3522             PL_euid == PL_statbuf.st_uid)
3523             if (!PL_do_undump)
3524                 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
3525 FIX YOUR KERNEL, OR PUT A C WRAPPER AROUND THIS SCRIPT!\n");
3526 #endif /* IAMSUID */
3527
3528         if (PL_fdscript < 0 &&
3529             PL_euid) {  /* oops, we're not the setuid root perl */
3530             /* PSz 18 Feb 04
3531              * When root runs a setuid script, we do not go through the same
3532              * steps of execing sperl and then perl with fd scripts, but
3533              * simply set up UIDs within the same perl invocation; so do
3534              * not have the same checks (on options, whatever) that we have
3535              * for plain users. No problem really: would have to be a script
3536              * that does not actually work for plain users; and if root is
3537              * foolish and can be persuaded to run such an unsafe script, he
3538              * might run also non-setuid ones, and deserves what he gets.
3539              *
3540              * Or, we might drop the PL_euid check above (and rely just on
3541              * PL_fdscript to avoid loops), and do the execs
3542              * even for root.
3543              */
3544 #ifndef IAMSUID
3545             int which;
3546             /* PSz 11 Nov 03
3547              * Pass fd script to suidperl.
3548              * Exec suidperl, substituting fd script for scriptname.
3549              * Pass script name as "subdir" of fd, which perl will grok;
3550              * in fact will use that to distinguish this from "normal"
3551              * usage, see comments above.
3552              */
3553             PerlIO_rewind(PL_rsfp);
3554             PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0);  /* just in case rewind didn't */
3555             /* PSz 27 Feb 04  Sanity checks on scriptname */
3556             if ((!scriptname) || (!*scriptname) ) {
3557                 Perl_croak(aTHX_ "No setuid script name\n");
3558             }
3559             if (*scriptname == '-') {
3560                 Perl_croak(aTHX_ "Setuid script name may not begin with dash\n");
3561                 /* Or we might confuse it with an option when replacing
3562                  * name in argument list, below (though we do pointer, not
3563                  * string, comparisons).
3564                  */
3565             }
3566             for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ;
3567             if (!PL_origargv[which]) {
3568                 Perl_croak(aTHX_ "Can't change argv to have fd script\n");
3569             }
3570             PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s",
3571                                           PerlIO_fileno(PL_rsfp), PL_origargv[which]));
3572 #if defined(HAS_FCNTL) && defined(F_SETFD)
3573             fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0);    /* ensure no close-on-exec */
3574 #endif
3575             PERL_FPU_PRE_EXEC
3576             PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT, BIN_EXP,
3577                                      (int)PERL_REVISION, (int)PERL_VERSION,
3578                                      (int)PERL_SUBVERSION), PL_origargv);
3579             PERL_FPU_POST_EXEC
3580 #endif /* IAMSUID */
3581             Perl_croak(aTHX_ "Can't do setuid (cannot exec sperl)\n");
3582         }
3583
3584         if (PL_statbuf.st_mode & S_ISGID && PL_statbuf.st_gid != PL_egid) {
3585 /* PSz 26 Feb 04
3586  * This seems back to front: we try HAS_SETEGID first; if not available
3587  * then try HAS_SETREGID; as a last chance we try HAS_SETRESGID. May be OK
3588  * in the sense that we only want to set EGID; but are there any machines
3589  * with either of the latter, but not the former? Same with UID, later.
3590  */
3591 #ifdef HAS_SETEGID
3592             (void)setegid(PL_statbuf.st_gid);
3593 #else
3594 #ifdef HAS_SETREGID
3595            (void)setregid((Gid_t)-1,PL_statbuf.st_gid);
3596 #else
3597 #ifdef HAS_SETRESGID
3598            (void)setresgid((Gid_t)-1,PL_statbuf.st_gid,(Gid_t)-1);
3599 #else
3600             PerlProc_setgid(PL_statbuf.st_gid);
3601 #endif
3602 #endif
3603 #endif
3604             if (PerlProc_getegid() != PL_statbuf.st_gid)
3605                 Perl_croak(aTHX_ "Can't do setegid!\n");
3606         }
3607         if (PL_statbuf.st_mode & S_ISUID) {
3608             if (PL_statbuf.st_uid != PL_euid)
3609 #ifdef HAS_SETEUID
3610                 (void)seteuid(PL_statbuf.st_uid);       /* all that for this */
3611 #else
3612 #ifdef HAS_SETREUID
3613                 (void)setreuid((Uid_t)-1,PL_statbuf.st_uid);
3614 #else
3615 #ifdef HAS_SETRESUID
3616                 (void)setresuid((Uid_t)-1,PL_statbuf.st_uid,(Uid_t)-1);
3617 #else
3618                 PerlProc_setuid(PL_statbuf.st_uid);
3619 #endif
3620 #endif
3621 #endif
3622             if (PerlProc_geteuid() != PL_statbuf.st_uid)
3623                 Perl_croak(aTHX_ "Can't do seteuid!\n");
3624         }
3625         else if (PL_uid) {                      /* oops, mustn't run as root */
3626 #ifdef HAS_SETEUID
3627           (void)seteuid((Uid_t)PL_uid);
3628 #else
3629 #ifdef HAS_SETREUID
3630           (void)setreuid((Uid_t)-1,(Uid_t)PL_uid);
3631 #else
3632 #ifdef HAS_SETRESUID
3633           (void)setresuid((Uid_t)-1,(Uid_t)PL_uid,(Uid_t)-1);
3634 #else
3635           PerlProc_setuid((Uid_t)PL_uid);
3636 #endif
3637 #endif
3638 #endif
3639             if (PerlProc_geteuid() != PL_uid)
3640                 Perl_croak(aTHX_ "Can't do seteuid!\n");
3641         }
3642         init_ids();
3643         if (!cando(S_IXUSR,TRUE,&PL_statbuf))
3644             Perl_croak(aTHX_ "Effective UID cannot exec script\n");     /* they can't do this */
3645     }
3646 #ifdef IAMSUID
3647     else if (PL_preprocess)     /* PSz 13 Nov 03  Caught elsewhere, useless(?!) here */
3648         Perl_croak(aTHX_ "-P not allowed for setuid/setgid script\n");
3649     else if (PL_fdscript < 0 || PL_suidscript != 1)
3650         /* PSz 13 Nov 03  Caught elsewhere, useless(?!) here */
3651         Perl_croak(aTHX_ "(suid) fdscript needed in suidperl\n");
3652     else {
3653 /* PSz 16 Sep 03  Keep neat error message */
3654         Perl_croak(aTHX_ "Script is not setuid/setgid in suidperl\n");
3655     }
3656
3657     /* We absolutely must clear out any saved ids here, so we */
3658     /* exec the real perl, substituting fd script for scriptname. */
3659     /* (We pass script name as "subdir" of fd, which perl will grok.) */
3660     /*
3661      * It might be thought that using setresgid and/or setresuid (changed to
3662      * set the saved IDs) above might obviate the need to exec, and we could
3663      * go on to "do the perl thing".
3664      *
3665      * Is there such a thing as "saved GID", and is that set for setuid (but
3666      * not setgid) execution like suidperl? Without exec, it would not be
3667      * cleared for setuid (but not setgid) scripts (or might need a dummy
3668      * setresgid).
3669      *
3670      * We need suidperl to do the exact same argument checking that perl
3671      * does. Thus it cannot be very small; while it could be significantly
3672      * smaller, it is safer (simpler?) to make it essentially the same
3673      * binary as perl (but they are not identical). - Maybe could defer that
3674      * check to the invoked perl, and suidperl be a tiny wrapper instead;
3675      * but prefer to do thorough checks in suidperl itself. Such deferral
3676      * would make suidperl security rely on perl, a design no-no.
3677      *
3678      * Setuid things should be short and simple, thus easy to understand and
3679      * verify. They should do their "own thing", without influence by
3680      * attackers. It may help if their internal execution flow is fixed,
3681      * regardless of platform: it may be best to exec anyway.
3682      *
3683      * Suidperl should at least be conceptually simple: a wrapper only,
3684      * never to do any real perl. Maybe we should put
3685      * #ifdef IAMSUID
3686      *         Perl_croak(aTHX_ "Suidperl should never do real perl\n");
3687      * #endif
3688      * into the perly bits.
3689      */
3690     PerlIO_rewind(PL_rsfp);
3691     PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0);  /* just in case rewind didn't */
3692     /* PSz 11 Nov 03
3693      * Keep original arguments: suidperl already has fd script.
3694      */
3695 /*  for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ;  */
3696 /*  if (!PL_origargv[which]) {                                          */
3697 /*      errno = EPERM;                                                  */
3698 /*      Perl_croak(aTHX_ "Permission denied\n");                        */
3699 /*  }                                                                   */
3700 /*  PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s",        */
3701 /*                                PerlIO_fileno(PL_rsfp), PL_origargv[which])); */
3702 #if defined(HAS_FCNTL) && defined(F_SETFD)
3703     fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0);    /* ensure no close-on-exec */
3704 #endif
3705     PERL_FPU_PRE_EXEC
3706     PerlProc_execv(Perl_form(aTHX_ "%s/perl"PERL_FS_VER_FMT, BIN_EXP,
3707                              (int)PERL_REVISION, (int)PERL_VERSION,
3708                              (int)PERL_SUBVERSION), PL_origargv);/* try again */
3709     PERL_FPU_POST_EXEC
3710     Perl_croak(aTHX_ "Can't do setuid (suidperl cannot exec perl)\n");
3711 #endif /* IAMSUID */
3712 #else /* !DOSUID */
3713     if (PL_euid != PL_uid || PL_egid != PL_gid) {       /* (suidperl doesn't exist, in fact) */
3714 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
3715         PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf);      /* may be either wrapped or real suid */
3716         if ((PL_euid != PL_uid && PL_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
3717             ||
3718             (PL_egid != PL_gid && PL_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
3719            )
3720             if (!PL_do_undump)
3721                 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
3722 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
3723 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
3724         /* not set-id, must be wrapped */
3725     }
3726 #endif /* DOSUID */
3727 }
3728
3729 STATIC void
3730 S_find_beginning(pTHX)
3731 {
3732     register char *s, *s2;
3733 #ifdef MACOS_TRADITIONAL
3734     int maclines = 0;
3735 #endif
3736
3737     /* skip forward in input to the real script? */
3738
3739     forbid_setid("-x");
3740 #ifdef MACOS_TRADITIONAL
3741     /* Since the Mac OS does not honor #! arguments for us, we do it ourselves */
3742
3743     while (PL_doextract || gMacPerl_AlwaysExtract) {
3744         if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
3745             if (!gMacPerl_AlwaysExtract)
3746                 Perl_croak(aTHX_ "No Perl script found in input\n");
3747
3748             if (PL_doextract)                   /* require explicit override ? */
3749                 if (!OverrideExtract(PL_origfilename))
3750                     Perl_croak(aTHX_ "User aborted script\n");
3751                 else
3752                     PL_doextract = FALSE;
3753
3754             /* Pater peccavi, file does not have #! */
3755             PerlIO_rewind(PL_rsfp);
3756
3757             break;
3758         }
3759 #else
3760     while (PL_doextract) {
3761         if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch)
3762             Perl_croak(aTHX_ "No Perl script found in input\n");
3763 #endif
3764         s2 = s;
3765         if (*s == '#' && s[1] == '!' && ((s = instr(s,"perl")) || (s = instr(s2,"PERL")))) {
3766             PerlIO_ungetc(PL_rsfp, '\n');               /* to keep line count right */
3767             PL_doextract = FALSE;
3768             while (*s && !(isSPACE (*s) || *s == '#')) s++;
3769             s2 = s;
3770             while (*s == ' ' || *s == '\t') s++;
3771             if (*s++ == '-') {
3772                 while (isDIGIT(s2[-1]) || s2[-1] == '-' || s2[-1] == '.'
3773                        || s2[-1] == '_') s2--;
3774                 if (strnEQ(s2-4,"perl",4))
3775                     /*SUPPRESS 530*/
3776                     while ((s = moreswitches(s)))
3777                         ;
3778             }
3779 #ifdef MACOS_TRADITIONAL
3780             /* We are always searching for the #!perl line in MacPerl,
3781              * so if we find it, still keep the line count correct
3782              * by counting lines we already skipped over
3783              */
3784             for (; maclines > 0 ; maclines--)
3785                 PerlIO_ungetc(PL_rsfp, '\n');
3786
3787             break;
3788
3789         /* gMacPerl_AlwaysExtract is false in MPW tool */
3790         } else if (gMacPerl_AlwaysExtract) {
3791             ++maclines;
3792 #endif
3793         }
3794     }
3795 }
3796
3797
3798 STATIC void
3799 S_init_ids(pTHX)
3800 {
3801     PL_uid = PerlProc_getuid();
3802     PL_euid = PerlProc_geteuid();
3803     PL_gid = PerlProc_getgid();
3804     PL_egid = PerlProc_getegid();
3805 #ifdef VMS
3806     PL_uid |= PL_gid << 16;
3807     PL_euid |= PL_egid << 16;
3808 #endif
3809     /* Should not happen: */
3810     CHECK_MALLOC_TAINT(PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
3811     PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
3812     /* BUG */
3813     /* PSz 27 Feb 04
3814      * Should go by suidscript, not uid!=euid: why disallow
3815      * system("ls") in scripts run from setuid things?
3816      * Or, is this run before we check arguments and set suidscript?
3817      * What about SETUID_SCRIPTS_ARE_SECURE_NOW: could we use fdscript then?
3818      * (We never have suidscript, can we be sure to have fdscript?)
3819      * Or must then go by UID checks? See comments in forbid_setid also.
3820      */
3821 }
3822
3823 /* This is used very early in the lifetime of the program,
3824  * before even the options are parsed, so PL_tainting has
3825  * not been initialized properly.  */
3826 bool
3827 Perl_doing_taint(int argc, char *argv[], char *envp[])
3828 {
3829 #ifndef PERL_IMPLICIT_SYS
3830     /* If we have PERL_IMPLICIT_SYS we can't call getuid() et alia
3831      * before we have an interpreter-- and the whole point of this
3832      * function is to be called at such an early stage.  If you are on
3833      * a system with PERL_IMPLICIT_SYS but you do have a concept of
3834      * "tainted because running with altered effective ids', you'll
3835      * have to add your own checks somewhere in here.  The two most
3836      * known samples of 'implicitness' are Win32 and NetWare, neither
3837      * of which has much of concept of 'uids'. */
3838     int uid  = PerlProc_getuid();
3839     int euid = PerlProc_geteuid();
3840     int gid  = PerlProc_getgid();
3841     int egid = PerlProc_getegid();
3842
3843 #ifdef VMS
3844     uid  |=  gid << 16;
3845     euid |= egid << 16;
3846 #endif
3847     if (uid && (euid != uid || egid != gid))
3848         return 1;
3849 #endif /* !PERL_IMPLICIT_SYS */
3850     /* This is a really primitive check; environment gets ignored only
3851      * if -T are the first chars together; otherwise one gets
3852      *  "Too late" message. */
3853     if ( argc > 1 && argv[1][0] == '-'
3854          && (argv[1][1] == 't' || argv[1][1] == 'T') )
3855         return 1;
3856     return 0;
3857 }
3858
3859 STATIC void
3860 S_forbid_setid(pTHX_ char *s)
3861 {
3862 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
3863     if (PL_euid != PL_uid)
3864         Perl_croak(aTHX_ "No %s allowed while running setuid", s);
3865     if (PL_egid != PL_gid)
3866         Perl_croak(aTHX_ "No %s allowed while running setgid", s);
3867 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
3868     /* PSz 29 Feb 04
3869      * Checks for UID/GID above "wrong": why disallow
3870      *   perl -e 'print "Hello\n"'
3871      * from within setuid things?? Simply drop them: replaced by
3872      * fdscript/suidscript and #ifdef IAMSUID checks below.
3873      *
3874      * This may be too late for command-line switches. Will catch those on
3875      * the #! line, after finding the script name and setting up
3876      * fdscript/suidscript. Note that suidperl does not get around to
3877      * parsing (and checking) the switches on the #! line, but checks that
3878      * the two sets are identical.
3879      *
3880      * With SETUID_SCRIPTS_ARE_SECURE_NOW, could we use fdscript, also or
3881      * instead, or would that be "too late"? (We never have suidscript, can
3882      * we be sure to have fdscript?)
3883      *
3884      * Catch things with suidscript (in descendant of suidperl), even with
3885      * right UID/GID. Was already checked in suidperl, with #ifdef IAMSUID,
3886      * below; but I am paranoid.
3887      *
3888      * Also see comments about root running a setuid script, elsewhere.
3889      */
3890     if (PL_suidscript >= 0)
3891         Perl_croak(aTHX_ "No %s allowed with (suid) fdscript", s);
3892 #ifdef IAMSUID
3893     /* PSz 11 Nov 03  Catch it in suidperl, always! */
3894     Perl_croak(aTHX_ "No %s allowed in suidperl", s);
3895 #endif /* IAMSUID */
3896 }
3897
3898 void
3899 Perl_init_debugger(pTHX)
3900 {
3901     HV *ostash = PL_curstash;
3902
3903     PL_curstash = PL_debstash;
3904     PL_dbargs = GvAV(gv_AVadd((gv_fetchpv("DB::args", GV_ADDMULTI, SVt_PVAV))));
3905     AvREAL_off(PL_dbargs);
3906     PL_DBgv = gv_fetchpv("DB::DB", GV_ADDMULTI, SVt_PVGV);
3907     PL_DBline = gv_fetchpv("DB::dbline", GV_ADDMULTI, SVt_PVAV);
3908     PL_DBsub = gv_HVadd(gv_fetchpv("DB::sub", GV_ADDMULTI, SVt_PVHV));
3909     sv_upgrade(GvSV(PL_DBsub), SVt_IV); /* IVX accessed if PERLDB_SUB_NN */
3910     PL_DBsingle = GvSV((gv_fetchpv("DB::single", GV_ADDMULTI, SVt_PV)));
3911     sv_setiv(PL_DBsingle, 0);
3912     PL_DBtrace = GvSV((gv_fetchpv("DB::trace", GV_ADDMULTI, SVt_PV)));
3913     sv_setiv(PL_DBtrace, 0);
3914     PL_DBsignal = GvSV((gv_fetchpv("DB::signal", GV_ADDMULTI, SVt_PV)));
3915     sv_setiv(PL_DBsignal, 0);
3916     PL_DBassertion = GvSV((gv_fetchpv("DB::assertion", GV_ADDMULTI, SVt_PV)));
3917     sv_setiv(PL_DBassertion, 0);
3918     PL_curstash = ostash;
3919 }
3920
3921 #ifndef STRESS_REALLOC
3922 #define REASONABLE(size) (size)
3923 #else
3924 #define REASONABLE(size) (1) /* unreasonable */
3925 #endif
3926
3927 void
3928 Perl_init_stacks(pTHX)
3929 {
3930     /* start with 128-item stack and 8K cxstack */
3931     PL_curstackinfo = new_stackinfo(REASONABLE(128),
3932                                  REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
3933     PL_curstackinfo->si_type = PERLSI_MAIN;
3934     PL_curstack = PL_curstackinfo->si_stack;
3935     PL_mainstack = PL_curstack;         /* remember in case we switch stacks */
3936
3937     PL_stack_base = AvARRAY(PL_curstack);
3938     PL_stack_sp = PL_stack_base;
3939     PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
3940
3941     New(50,PL_tmps_stack,REASONABLE(128),SV*);
3942     PL_tmps_floor = -1;
3943     PL_tmps_ix = -1;
3944     PL_tmps_max = REASONABLE(128);
3945
3946     New(54,PL_markstack,REASONABLE(32),I32);
3947     PL_markstack_ptr = PL_markstack;
3948     PL_markstack_max = PL_markstack + REASONABLE(32);
3949
3950     SET_MARK_OFFSET;
3951
3952     New(54,PL_scopestack,REASONABLE(32),I32);
3953     PL_scopestack_ix = 0;
3954     PL_scopestack_max = REASONABLE(32);
3955
3956     New(54,PL_savestack,REASONABLE(128),ANY);
3957     PL_savestack_ix = 0;
3958     PL_savestack_max = REASONABLE(128);
3959 }
3960
3961 #undef REASONABLE
3962
3963 STATIC void
3964 S_nuke_stacks(pTHX)
3965 {
3966     while (PL_curstackinfo->si_next)
3967         PL_curstackinfo = PL_curstackinfo->si_next;
3968     while (PL_curstackinfo) {
3969         PERL_SI *p = PL_curstackinfo->si_prev;
3970         /* curstackinfo->si_stack got nuked by sv_free_arenas() */
3971         Safefree(PL_curstackinfo->si_cxstack);
3972         Safefree(PL_curstackinfo);
3973         PL_curstackinfo = p;
3974     }
3975     Safefree(PL_tmps_stack);
3976     Safefree(PL_markstack);
3977     Safefree(PL_scopestack);
3978     Safefree(PL_savestack);
3979 }
3980
3981 STATIC void
3982 S_init_lexer(pTHX)
3983 {
3984     PerlIO *tmpfp;
3985     tmpfp = PL_rsfp;
3986     PL_rsfp = Nullfp;
3987     lex_start(PL_linestr);
3988     PL_rsfp = tmpfp;
3989     PL_subname = newSVpvn("main",4);
3990 }
3991
3992 STATIC void
3993 S_init_predump_symbols(pTHX)
3994 {
3995     GV *tmpgv;
3996     IO *io;
3997
3998     sv_setpvn(get_sv("\"", TRUE), " ", 1);
3999     PL_stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
4000     GvMULTI_on(PL_stdingv);
4001     io = GvIOp(PL_stdingv);
4002     IoTYPE(io) = IoTYPE_RDONLY;
4003     IoIFP(io) = PerlIO_stdin();
4004     tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
4005     GvMULTI_on(tmpgv);
4006     GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
4007
4008     tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
4009     GvMULTI_on(tmpgv);
4010     io = GvIOp(tmpgv);
4011     IoTYPE(io) = IoTYPE_WRONLY;
4012     IoOFP(io) = IoIFP(io) = PerlIO_stdout();
4013     setdefout(tmpgv);
4014     tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
4015     GvMULTI_on(tmpgv);
4016     GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
4017
4018     PL_stderrgv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
4019     GvMULTI_on(PL_stderrgv);
4020     io = GvIOp(PL_stderrgv);
4021     IoTYPE(io) = IoTYPE_WRONLY;
4022     IoOFP(io) = IoIFP(io) = PerlIO_stderr();
4023     tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
4024     GvMULTI_on(tmpgv);
4025     GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
4026
4027     PL_statname = NEWSV(66,0);          /* last filename we did stat on */
4028
4029     if (PL_osname)
4030         Safefree(PL_osname);
4031     PL_osname = savepv(OSNAME);
4032 }
4033
4034 void
4035 Perl_init_argv_symbols(pTHX_ register int argc, register char **argv)
4036 {
4037     char *s;
4038     argc--,argv++;      /* skip name of script */
4039     if (PL_doswitches) {
4040         for (; argc > 0 && **argv == '-'; argc--,argv++) {
4041             if (!argv[0][1])
4042                 break;
4043             if (argv[0][1] == '-' && !argv[0][2]) {
4044                 argc--,argv++;
4045                 break;
4046             }
4047             if ((s = strchr(argv[0], '='))) {
4048                 *s++ = '\0';
4049                 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
4050             }
4051             else
4052                 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
4053         }
4054     }
4055     if ((PL_argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV))) {
4056         GvMULTI_on(PL_argvgv);
4057         (void)gv_AVadd(PL_argvgv);
4058         av_clear(GvAVn(PL_argvgv));
4059         for (; argc > 0; argc--,argv++) {
4060             SV *sv = newSVpv(argv[0],0);
4061             av_push(GvAVn(PL_argvgv),sv);
4062             if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) {
4063                  if (PL_unicode & PERL_UNICODE_ARGV_FLAG)
4064                       SvUTF8_on(sv);
4065             }
4066             if (PL_unicode & PERL_UNICODE_WIDESYSCALLS_FLAG) /* Sarathy? */
4067                  (void)sv_utf8_decode(sv);
4068         }
4069     }
4070 }
4071
4072 STATIC void
4073 S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env)
4074 {
4075     char *s;
4076     SV *sv;
4077     GV* tmpgv;
4078
4079     PL_toptarget = NEWSV(0,0);
4080     sv_upgrade(PL_toptarget, SVt_PVFM);
4081     sv_setpvn(PL_toptarget, "", 0);
4082     PL_bodytarget = NEWSV(0,0);
4083     sv_upgrade(PL_bodytarget, SVt_PVFM);
4084     sv_setpvn(PL_bodytarget, "", 0);
4085     PL_formtarget = PL_bodytarget;
4086
4087     TAINT;
4088
4089     init_argv_symbols(argc,argv);
4090
4091     if ((tmpgv = gv_fetchpv("0",TRUE, SVt_PV))) {
4092 #ifdef MACOS_TRADITIONAL
4093         /* $0 is not majick on a Mac */
4094         sv_setpv(GvSV(tmpgv),MacPerl_MPWFileName(PL_origfilename));
4095 #else
4096         sv_setpv(GvSV(tmpgv),PL_origfilename);
4097         magicname("0", "0", 1);
4098 #endif
4099     }
4100     if ((PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV))) {
4101         HV *hv;
4102         GvMULTI_on(PL_envgv);
4103         hv = GvHVn(PL_envgv);
4104         hv_magic(hv, Nullgv, PERL_MAGIC_env);
4105 #ifndef PERL_MICRO
4106 #ifdef USE_ENVIRON_ARRAY
4107         /* Note that if the supplied env parameter is actually a copy
4108            of the global environ then it may now point to free'd memory
4109            if the environment has been modified since. To avoid this
4110            problem we treat env==NULL as meaning 'use the default'
4111         */
4112         if (!env)
4113             env = environ;
4114         if (env != environ
4115 #  ifdef USE_ITHREADS
4116             && PL_curinterp == aTHX
4117 #  endif
4118            )
4119         {
4120             environ[0] = Nullch;
4121         }
4122         if (env) {
4123           char** origenv = environ;
4124           for (; *env; env++) {
4125             if (!(s = strchr(*env,'=')) || s == *env)
4126                 continue;
4127 #if defined(MSDOS) && !defined(DJGPP)
4128             *s = '\0';
4129             (void)strupr(*env);
4130             *s = '=';
4131 #endif
4132             sv = newSVpv(s+1, 0);
4133             (void)hv_store(hv, *env, s - *env, sv, 0);
4134             if (env != environ)
4135                 mg_set(sv);
4136             if (origenv != environ) {
4137               /* realloc has shifted us */
4138               env = (env - origenv) + environ;
4139               origenv = environ;
4140             }
4141           }
4142       }
4143 #endif /* USE_ENVIRON_ARRAY */
4144 #endif /* !PERL_MICRO */
4145     }
4146     TAINT_NOT;
4147     if ((tmpgv = gv_fetchpv("$",TRUE, SVt_PV))) {
4148         SvREADONLY_off(GvSV(tmpgv));
4149         sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
4150         SvREADONLY_on(GvSV(tmpgv));
4151     }
4152 #ifdef THREADS_HAVE_PIDS
4153     PL_ppid = (IV)getppid();
4154 #endif
4155
4156     /* touch @F array to prevent spurious warnings 20020415 MJD */
4157     if (PL_minus_a) {
4158       (void) get_av("main::F", TRUE | GV_ADDMULTI);
4159     }
4160     /* touch @- and @+ arrays to prevent spurious warnings 20020415 MJD */
4161     (void) get_av("main::-", TRUE | GV_ADDMULTI);
4162     (void) get_av("main::+", TRUE | GV_ADDMULTI);
4163 }
4164
4165 STATIC void
4166 S_init_perllib(pTHX)
4167 {
4168     char *s;
4169     if (!PL_tainting) {
4170 #ifndef VMS
4171         s = PerlEnv_getenv("PERL5LIB");
4172         if (s)
4173             incpush(s, TRUE, TRUE, TRUE, FALSE);
4174         else
4175             incpush(PerlEnv_getenv("PERLLIB"), FALSE, FALSE, TRUE, FALSE);
4176 #else /* VMS */
4177         /* Treat PERL5?LIB as a possible search list logical name -- the
4178          * "natural" VMS idiom for a Unix path string.  We allow each
4179          * element to be a set of |-separated directories for compatibility.
4180          */
4181         char buf[256];
4182         int idx = 0;
4183         if (my_trnlnm("PERL5LIB",buf,0))
4184             do { incpush(buf,TRUE,TRUE,TRUE,FALSE); } while (my_trnlnm("PERL5LIB",buf,++idx));
4185         else
4186             while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE,FALSE,TRUE,FALSE);
4187 #endif /* VMS */
4188     }
4189
4190 /* Use the ~-expanded versions of APPLLIB (undocumented),
4191     ARCHLIB PRIVLIB SITEARCH SITELIB VENDORARCH and VENDORLIB
4192 */
4193 #ifdef APPLLIB_EXP
4194     incpush(APPLLIB_EXP, TRUE, TRUE, TRUE, TRUE);
4195 #endif
4196
4197 #ifdef ARCHLIB_EXP
4198     incpush(ARCHLIB_EXP, FALSE, FALSE, TRUE, TRUE);
4199 #endif
4200 #ifdef MACOS_TRADITIONAL
4201     {
4202         Stat_t tmpstatbuf;
4203         SV * privdir = NEWSV(55, 0);
4204         char * macperl = PerlEnv_getenv("MACPERL");
4205
4206         if (!macperl)
4207             macperl = "";
4208
4209         Perl_sv_setpvf(aTHX_ privdir, "%slib:", macperl);
4210         if (PerlLIO_stat(SvPVX(privdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode))
4211             incpush(SvPVX(privdir), TRUE, FALSE, TRUE, FALSE);
4212         Perl_sv_setpvf(aTHX_ privdir, "%ssite_perl:", macperl);
4213         if (PerlLIO_stat(SvPVX(privdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode))
4214             incpush(SvPVX(privdir), TRUE, FALSE, TRUE, FALSE);
4215
4216         SvREFCNT_dec(privdir);
4217     }
4218     if (!PL_tainting)
4219         incpush(":", FALSE, FALSE, TRUE, FALSE);
4220 #else
4221 #ifndef PRIVLIB_EXP
4222 #  define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
4223 #endif
4224 #if defined(WIN32)
4225     incpush(PRIVLIB_EXP, TRUE, FALSE, TRUE, TRUE);
4226 #else
4227     incpush(PRIVLIB_EXP, FALSE, FALSE, TRUE, TRUE);
4228 #endif
4229
4230 #ifdef SITEARCH_EXP
4231     /* sitearch is always relative to sitelib on Windows for
4232      * DLL-based path intuition to work correctly */
4233 #  if !defined(WIN32)
4234     incpush(SITEARCH_EXP, FALSE, FALSE, TRUE, TRUE);
4235 #  endif
4236 #endif
4237
4238 #ifdef SITELIB_EXP
4239 #  if defined(WIN32)
4240     /* this picks up sitearch as well */
4241     incpush(SITELIB_EXP, TRUE, FALSE, TRUE, TRUE);
4242 #  else
4243     incpush(SITELIB_EXP, FALSE, FALSE, TRUE, TRUE);
4244 #  endif
4245 #endif
4246
4247 #ifdef SITELIB_STEM /* Search for version-specific dirs below here */
4248     incpush(SITELIB_STEM, FALSE, TRUE, TRUE, TRUE);
4249 #endif
4250
4251 #ifdef PERL_VENDORARCH_EXP
4252     /* vendorarch is always relative to vendorlib on Windows for
4253      * DLL-based path intuition to work correctly */
4254 #  if !defined(WIN32)
4255     incpush(PERL_VENDORARCH_EXP, FALSE, FALSE, TRUE, TRUE);
4256 #  endif
4257 #endif
4258
4259 #ifdef PERL_VENDORLIB_EXP
4260 #  if defined(WIN32)
4261     incpush(PERL_VENDORLIB_EXP, TRUE, FALSE, TRUE, TRUE);       /* this picks up vendorarch as well */
4262 #  else
4263     incpush(PERL_VENDORLIB_EXP, FALSE, FALSE, TRUE, TRUE);
4264 #  endif
4265 #endif
4266
4267 #ifdef PERL_VENDORLIB_STEM /* Search for version-specific dirs below here */
4268     incpush(PERL_VENDORLIB_STEM, FALSE, TRUE, TRUE, TRUE);
4269 #endif
4270
4271 #ifdef PERL_OTHERLIBDIRS
4272     incpush(PERL_OTHERLIBDIRS, TRUE, TRUE, TRUE, TRUE);
4273 #endif
4274
4275     if (!PL_tainting)
4276         incpush(".", FALSE, FALSE, TRUE, FALSE);
4277 #endif /* MACOS_TRADITIONAL */
4278 }
4279
4280 #if defined(DOSISH) || defined(EPOC)
4281 #    define PERLLIB_SEP ';'
4282 #else
4283 #  if defined(VMS)
4284 #    define PERLLIB_SEP '|'
4285 #  else
4286 #    if defined(MACOS_TRADITIONAL)
4287 #      define PERLLIB_SEP ','
4288 #    else
4289 #      define PERLLIB_SEP ':'
4290 #    endif
4291 #  endif
4292 #endif
4293 #ifndef PERLLIB_MANGLE
4294 #  define PERLLIB_MANGLE(s,n) (s)
4295 #endif
4296
4297 /* Push a directory onto @INC if it exists.
4298    Generate a new SV if we do this, to save needing to copy the SV we push
4299    onto @INC  */
4300 STATIC SV *
4301 S_incpush_if_exists(pTHX_ SV *dir)
4302 {
4303     Stat_t tmpstatbuf;
4304     if (PerlLIO_stat(SvPVX(dir), &tmpstatbuf) >= 0 &&
4305         S_ISDIR(tmpstatbuf.st_mode)) {
4306         av_push(GvAVn(PL_incgv), dir);
4307         dir = NEWSV(0,0);
4308     }
4309     return dir;
4310 }
4311
4312 STATIC void
4313 S_incpush(pTHX_ char *p, int addsubdirs, int addoldvers, int usesep,
4314           int canrelocate)
4315 {
4316     SV *subdir = Nullsv;
4317
4318     if (!p || !*p)
4319         return;
4320
4321     if (addsubdirs || addoldvers) {
4322         subdir = NEWSV(0,0);
4323     }
4324
4325     /* Break at all separators */
4326     while (p && *p) {
4327         SV *libdir = NEWSV(55,0);
4328         char *s;
4329
4330         /* skip any consecutive separators */
4331         if (usesep) {
4332             while ( *p == PERLLIB_SEP ) {
4333                 /* Uncomment the next line for PATH semantics */
4334                 /* av_push(GvAVn(PL_incgv), newSVpvn(".", 1)); */
4335                 p++;
4336             }
4337         }
4338
4339         if ( usesep && (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
4340             sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
4341                       (STRLEN)(s - p));
4342             p = s + 1;
4343         }
4344         else {
4345             sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
4346             p = Nullch; /* break out */
4347         }
4348 #ifdef MACOS_TRADITIONAL
4349         if (!strchr(SvPVX(libdir), ':')) {
4350             char buf[256];
4351
4352             sv_setpv(libdir, MacPerl_CanonDir(SvPVX(libdir), buf, 0));
4353         }
4354         if (SvPVX(libdir)[SvCUR(libdir)-1] != ':')
4355             sv_catpv(libdir, ":");
4356 #endif
4357
4358 #ifdef PERL_RELOCATABLE_INC
4359         /*
4360          * Relocatable include entries are marked with a leading .../
4361          *
4362          * The algorithm is
4363          * 0: Remove that leading ".../"
4364          * 1: Remove trailing executable name (anything after the last '/')
4365          *    from the perl path to give a perl prefix
4366          * Then
4367          * While the @INC element starts "../" and the prefix ends with a real
4368          * directory (ie not . or ..) chop that real directory off the prefix
4369          * and the leading "../" from the @INC element. ie a logical "../"
4370          * cleanup
4371          * Finally concatenate the prefix and the remainder of the @INC element
4372          * The intent is that /usr/local/bin/perl and .../../lib/perl5
4373          * generates /usr/local/lib/perl5
4374          */
4375         {
4376             char *libpath = SvPVX(libdir);
4377             STRLEN libpath_len = SvCUR(libdir);
4378             if (libpath_len >= 4 && memEQ (libpath, ".../", 4)) {
4379                 /* Game on!  */
4380                 SV *caret_X = get_sv("\030", 0);
4381                 /* Going to use the SV just as a scratch buffer holding a C
4382                    string:  */
4383                 SV *prefix_sv;
4384                 char *prefix;
4385                 char *lastslash;
4386
4387                 /* $^X is *the* source of taint if tainting is on, hence
4388                    SvPOK() won't be true.  */
4389                 assert(caret_X);
4390                 assert(SvPOKp(caret_X));
4391                 prefix_sv = newSVpvn(SvPVX(caret_X), SvCUR(caret_X));
4392                 /* Firstly take off the leading .../
4393                    If all else fail we'll do the paths relative to the current
4394                    directory.  */
4395                 sv_chop(libdir, libpath + 4);
4396                 /* Don't use SvPV as we're intentionally bypassing taining,
4397                    mortal copies that the mg_get of tainting creates, and
4398                    corruption that seems to come via the save stack.
4399                    I guess that the save stack isn't correctly set up yet.  */
4400                 libpath = SvPVX(libdir);
4401                 libpath_len = SvCUR(libdir);
4402
4403                 /* This would work more efficiently with memrchr, but as it's
4404                    only a GNU extension we'd need to probe for it and
4405                    implement our own. Not hard, but maybe not worth it?  */
4406
4407                 prefix = SvPVX(prefix_sv);
4408                 lastslash = strrchr(prefix, '/');
4409
4410                 /* First time in with the *lastslash = '\0' we just wipe off
4411                    the trailing /perl from (say) /usr/foo/bin/perl
4412                 */
4413                 if (lastslash) {
4414                     SV *tempsv;
4415                     while ((*lastslash = '\0'), /* Do that, come what may.  */
4416                            (libpath_len >= 3 && memEQ(libpath, "../", 3)
4417                             && (lastslash = strrchr(prefix, '/')))) {
4418                         if (lastslash[1] == '\0'
4419                             || (lastslash[1] == '.'
4420                                 && (lastslash[2] == '/' /* ends "/."  */
4421                                     || (lastslash[2] == '/'
4422                                         && lastslash[3] == '/' /* or "/.."  */
4423                                         )))) {
4424                             /* Prefix ends "/" or "/." or "/..", any of which
4425                                are fishy, so don't do any more logical cleanup.
4426                             */
4427                             break;
4428                         }
4429                         /* Remove leading "../" from path  */
4430                         libpath += 3;
4431                         libpath_len -= 3;
4432                         /* Next iteration round the loop removes the last
4433                            directory name from prefix by writing a '\0' in
4434                            the while clause.  */
4435                     }
4436                     /* prefix has been terminated with a '\0' to the correct
4437                        length. libpath points somewhere into the libdir SV.
4438                        We need to join the 2 with '/' and drop the result into
4439                        libdir.  */
4440                     tempsv = Perl_newSVpvf(aTHX_ "%s/%s", prefix, libpath);
4441                     SvREFCNT_dec(libdir);
4442                     /* And this is the new libdir.  */
4443                     libdir = tempsv;
4444                     if (PL_tainting &&
4445                         (PL_uid != PL_euid || PL_gid != PL_egid)) {
4446                         /* Need to taint reloccated paths if running set ID  */
4447                         SvTAINTED_on(libdir);
4448                     }
4449                 }
4450                 SvREFCNT_dec(prefix_sv);
4451             }
4452         }
4453 #endif
4454         /*
4455          * BEFORE pushing libdir onto @INC we may first push version- and
4456          * archname-specific sub-directories.
4457          */
4458         if (addsubdirs || addoldvers) {
4459 #ifdef PERL_INC_VERSION_LIST
4460             /* Configure terminates PERL_INC_VERSION_LIST with a NULL */
4461             const char *incverlist[] = { PERL_INC_VERSION_LIST };
4462             const char **incver;
4463 #endif
4464 #ifdef VMS
4465             char *unix;
4466             STRLEN len;
4467
4468             if ((unix = tounixspec_ts(SvPV(libdir,len),Nullch)) != Nullch) {
4469                 len = strlen(unix);
4470                 while (unix[len-1] == '/') len--;  /* Cosmetic */
4471                 sv_usepvn(libdir,unix,len);
4472             }
4473             else
4474                 PerlIO_printf(Perl_error_log,
4475                               "Failed to unixify @INC element \"%s\"\n",
4476                               SvPV(libdir,len));
4477 #endif
4478             if (addsubdirs) {
4479 #ifdef MACOS_TRADITIONAL
4480 #define PERL_AV_SUFFIX_FMT      ""
4481 #define PERL_ARCH_FMT           "%s:"
4482 #define PERL_ARCH_FMT_PATH      PERL_FS_VER_FMT PERL_AV_SUFFIX_FMT
4483 #else
4484 #define PERL_AV_SUFFIX_FMT      "/"
4485 #define PERL_ARCH_FMT           "/%s"
4486 #define PERL_ARCH_FMT_PATH      PERL_AV_SUFFIX_FMT PERL_FS_VER_FMT
4487 #endif
4488                 /* .../version/archname if -d .../version/archname */
4489                 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT_PATH PERL_ARCH_FMT,
4490                                 libdir,
4491                                (int)PERL_REVISION, (int)PERL_VERSION,
4492                                (int)PERL_SUBVERSION, ARCHNAME);
4493                 subdir = S_incpush_if_exists(aTHX_ subdir);
4494
4495                 /* .../version if -d .../version */
4496                 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT_PATH, libdir,
4497                                (int)PERL_REVISION, (int)PERL_VERSION,
4498                                (int)PERL_SUBVERSION);
4499                 subdir = S_incpush_if_exists(aTHX_ subdir);
4500
4501                 /* .../archname if -d .../archname */
4502                 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT, libdir, ARCHNAME);
4503                 subdir = S_incpush_if_exists(aTHX_ subdir);
4504
4505             }
4506
4507 #ifdef PERL_INC_VERSION_LIST
4508             if (addoldvers) {
4509                 for (incver = incverlist; *incver; incver++) {
4510                     /* .../xxx if -d .../xxx */
4511                     Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT, libdir, *incver);
4512                     subdir = S_incpush_if_exists(aTHX_ subdir);
4513                 }
4514             }
4515 #endif
4516         }
4517
4518         /* finally push this lib directory on the end of @INC */
4519         av_push(GvAVn(PL_incgv), libdir);
4520     }
4521     if (subdir) {
4522         assert (SvREFCNT(subdir) == 1);
4523         SvREFCNT_dec(subdir);
4524     }
4525 }
4526
4527 #ifdef USE_5005THREADS
4528 STATIC struct perl_thread *
4529 S_init_main_thread(pTHX)
4530 {
4531 #if !defined(PERL_IMPLICIT_CONTEXT)
4532     struct perl_thread *thr;
4533 #endif
4534     XPV *xpv;
4535
4536     Newz(53, thr, 1, struct perl_thread);
4537     PL_curcop = &PL_compiling;
4538     thr->interp = PERL_GET_INTERP;
4539     thr->cvcache = newHV();
4540     thr->threadsv = newAV();
4541     /* thr->threadsvp is set when find_threadsv is called */
4542     thr->specific = newAV();
4543     thr->flags = THRf_R_JOINABLE;
4544     MUTEX_INIT(&thr->mutex);
4545     /* Handcraft thrsv similarly to mess_sv */
4546     New(53, PL_thrsv, 1, SV);
4547     Newz(53, xpv, 1, XPV);
4548     SvFLAGS(PL_thrsv) = SVt_PV;
4549     SvANY(PL_thrsv) = (void*)xpv;
4550     SvREFCNT(PL_thrsv) = 1 << 30;       /* practically infinite */
4551     SvPVX(PL_thrsv) = (char*)thr;
4552     SvCUR_set(PL_thrsv, sizeof(thr));
4553     SvLEN_set(PL_thrsv, sizeof(thr));
4554     *SvEND(PL_thrsv) = '\0';    /* in the trailing_nul field */
4555     thr->oursv = PL_thrsv;
4556     PL_chopset = " \n-";
4557     PL_dumpindent = 4;
4558
4559     MUTEX_LOCK(&PL_threads_mutex);
4560     PL_nthreads++;
4561     thr->tid = 0;
4562     thr->next = thr;
4563     thr->prev = thr;
4564     thr->thr_done = 0;
4565     MUTEX_UNLOCK(&PL_threads_mutex);
4566
4567 #ifdef HAVE_THREAD_INTERN
4568     Perl_init_thread_intern(thr);
4569 #endif
4570
4571 #ifdef SET_THREAD_SELF
4572     SET_THREAD_SELF(thr);
4573 #else
4574     thr->self = pthread_self();
4575 #endif /* SET_THREAD_SELF */
4576     PERL_SET_THX(thr);
4577
4578     /*
4579      * These must come after the thread self setting
4580      * because sv_setpvn does SvTAINT and the taint
4581      * fields thread selfness being set.
4582      */
4583     PL_toptarget = NEWSV(0,0);
4584     sv_upgrade(PL_toptarget, SVt_PVFM);
4585     sv_setpvn(PL_toptarget, "", 0);
4586     PL_bodytarget = NEWSV(0,0);
4587     sv_upgrade(PL_bodytarget, SVt_PVFM);
4588     sv_setpvn(PL_bodytarget, "", 0);
4589     PL_formtarget = PL_bodytarget;
4590     thr->errsv = newSVpvn("", 0);
4591     (void) find_threadsv("@");  /* Ensure $@ is initialised early */
4592
4593     PL_maxscream = -1;
4594     PL_peepp = MEMBER_TO_FPTR(Perl_peep);
4595     PL_regcompp = MEMBER_TO_FPTR(Perl_pregcomp);
4596     PL_regexecp = MEMBER_TO_FPTR(Perl_regexec_flags);
4597     PL_regint_start = MEMBER_TO_FPTR(Perl_re_intuit_start);
4598     PL_regint_string = MEMBER_TO_FPTR(Perl_re_intuit_string);
4599     PL_regfree = MEMBER_TO_FPTR(Perl_pregfree);
4600     PL_regindent = 0;
4601     PL_reginterp_cnt = 0;
4602
4603     return thr;
4604 }
4605 #endif /* USE_5005THREADS */
4606
4607 void
4608 Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
4609 {
4610     SV *atsv;
4611     line_t oldline = CopLINE(PL_curcop);
4612     CV *cv;
4613     STRLEN len;
4614     int ret;
4615     dJMPENV;
4616
4617     while (AvFILL(paramList) >= 0) {
4618         cv = (CV*)av_shift(paramList);
4619         if (PL_savebegin) {
4620             if (paramList == PL_beginav) {
4621                 /* save PL_beginav for compiler */
4622                 if (! PL_beginav_save)
4623                     PL_beginav_save = newAV();
4624                 av_push(PL_beginav_save, (SV*)cv);
4625             }
4626             else if (paramList == PL_checkav) {
4627                 /* save PL_checkav for compiler */
4628                 if (! PL_checkav_save)
4629                     PL_checkav_save = newAV();
4630                 av_push(PL_checkav_save, (SV*)cv);
4631             }
4632         } else {
4633             SAVEFREESV(cv);
4634         }
4635 #ifdef PERL_FLEXIBLE_EXCEPTIONS
4636         CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_list_body), cv);
4637 #else
4638         JMPENV_PUSH(ret);
4639 #endif
4640         switch (ret) {
4641         case 0:
4642 #ifndef PERL_FLEXIBLE_EXCEPTIONS
4643             call_list_body(cv);
4644 #endif
4645             atsv = ERRSV;
4646             (void)SvPV(atsv, len);
4647             if (len) {
4648                 PL_curcop = &PL_compiling;
4649                 CopLINE_set(PL_curcop, oldline);
4650                 if (paramList == PL_beginav)
4651                     sv_catpv(atsv, "BEGIN failed--compilation aborted");
4652                 else
4653                     Perl_sv_catpvf(aTHX_ atsv,
4654                                    "%s failed--call queue aborted",
4655                                    paramList == PL_checkav ? "CHECK"
4656                                    : paramList == PL_initav ? "INIT"
4657                                    : "END");
4658                 while (PL_scopestack_ix > oldscope)
4659                     LEAVE;
4660                 JMPENV_POP;
4661                 Perl_croak(aTHX_ "%"SVf"", atsv);
4662             }
4663             break;
4664         case 1:
4665             STATUS_ALL_FAILURE;
4666             /* FALL THROUGH */
4667         case 2:
4668             /* my_exit() was called */
4669             while (PL_scopestack_ix > oldscope)
4670                 LEAVE;
4671             FREETMPS;
4672             PL_curstash = PL_defstash;
4673             PL_curcop = &PL_compiling;
4674             CopLINE_set(PL_curcop, oldline);
4675             JMPENV_POP;
4676             if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED)) {
4677                 if (paramList == PL_beginav)
4678                     Perl_croak(aTHX_ "BEGIN failed--compilation aborted");
4679                 else
4680                     Perl_croak(aTHX_ "%s failed--call queue aborted",
4681                                paramList == PL_checkav ? "CHECK"
4682                                : paramList == PL_initav ? "INIT"
4683                                : "END");
4684             }
4685             my_exit_jump();
4686             /* NOTREACHED */
4687         case 3:
4688             if (PL_restartop) {
4689                 PL_curcop = &PL_compiling;
4690                 CopLINE_set(PL_curcop, oldline);
4691                 JMPENV_JUMP(3);
4692             }
4693             PerlIO_printf(Perl_error_log, "panic: restartop\n");
4694             FREETMPS;
4695             break;
4696         }
4697         JMPENV_POP;
4698     }
4699 }
4700
4701 #ifdef PERL_FLEXIBLE_EXCEPTIONS
4702 STATIC void *
4703 S_vcall_list_body(pTHX_ va_list args)
4704 {
4705     CV *cv = va_arg(args, CV*);
4706     return call_list_body(cv);
4707 }
4708 #endif
4709
4710 STATIC void *
4711 S_call_list_body(pTHX_ CV *cv)
4712 {
4713     PUSHMARK(PL_stack_sp);
4714     call_sv((SV*)cv, G_EVAL|G_DISCARD);
4715     return NULL;
4716 }
4717
4718 void
4719 Perl_my_exit(pTHX_ U32 status)
4720 {
4721     DEBUG_S(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
4722                           thr, (unsigned long) status));
4723     switch (status) {
4724     case 0:
4725         STATUS_ALL_SUCCESS;
4726         break;
4727     case 1:
4728         STATUS_ALL_FAILURE;
4729         break;
4730     default:
4731         STATUS_NATIVE_SET(status);
4732         break;
4733     }
4734     my_exit_jump();
4735 }
4736
4737 void
4738 Perl_my_failure_exit(pTHX)
4739 {
4740 #ifdef VMS
4741     if (vaxc$errno & 1) {
4742         if (STATUS_NATIVE & 1)          /* fortuitiously includes "-1" */
4743             STATUS_NATIVE_SET(44);
4744     }
4745     else {
4746         if (!vaxc$errno)                /* unlikely */
4747             STATUS_NATIVE_SET(44);
4748         else
4749             STATUS_NATIVE_SET(vaxc$errno);
4750     }
4751 #else
4752     int exitstatus;
4753     if (errno & 255)
4754         STATUS_POSIX_SET(errno);
4755     else {
4756         exitstatus = STATUS_POSIX >> 8;
4757         if (exitstatus & 255)
4758             STATUS_POSIX_SET(exitstatus);
4759         else
4760             STATUS_POSIX_SET(255);
4761     }
4762 #endif
4763     my_exit_jump();
4764 }
4765
4766 STATIC void
4767 S_my_exit_jump(pTHX)
4768 {
4769     register PERL_CONTEXT *cx;
4770     I32 gimme;
4771     SV **newsp;
4772
4773     if (PL_e_script) {
4774         SvREFCNT_dec(PL_e_script);
4775         PL_e_script = Nullsv;
4776     }
4777
4778     POPSTACK_TO(PL_mainstack);
4779     if (cxstack_ix >= 0) {
4780         if (cxstack_ix > 0)
4781             dounwind(0);
4782         POPBLOCK(cx,PL_curpm);
4783         LEAVE;
4784     }
4785
4786     JMPENV_JUMP(2);
4787 }
4788
4789 static I32
4790 read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen)
4791 {
4792     char *p, *nl;
4793     p  = SvPVX(PL_e_script);
4794     nl = strchr(p, '\n');
4795     nl = (nl) ? nl+1 : SvEND(PL_e_script);
4796     if (nl-p == 0) {
4797         filter_del(read_e_script);
4798         return 0;
4799     }
4800     sv_catpvn(buf_sv, p, nl-p);
4801     sv_chop(PL_e_script, nl);
4802     return 1;
4803 }