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