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