perl.c

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