perl.c

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