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     bool minus_f = FALSE;
1233
1234     PL_fdscript = -1;
1235     PL_suidscript = -1;
1236     sv_setpvn(PL_linestr,"",0);
1237     sv = newSVpvn("",0);                /* first used for -I flags */
1238     SAVEFREESV(sv);
1239     init_main_stash();
1240
1241     for (argc--,argv++; argc > 0; argc--,argv++) {
1242         if (argv[0][0] != '-' || !argv[0][1])
1243             break;
1244 #ifdef DOSUID
1245     if (*validarg)
1246         validarg = " PHOOEY ";
1247     else
1248         validarg = argv[0];
1249     /*
1250      * Can we rely on the kernel to start scripts with argv[1] set to
1251      * contain all #! line switches (the whole line)? (argv[0] is set to
1252      * the interpreter name, argv[2] to the script name; argv[3] and
1253      * above may contain other arguments.)
1254      */
1255 #endif
1256         s = argv[0]+1;
1257       reswitch:
1258         switch (*s) {
1259         case 'C':
1260 #ifndef PERL_STRICT_CR
1261         case '\r':
1262 #endif
1263         case ' ':
1264         case '0':
1265         case 'F':
1266         case 'a':
1267         case 'c':
1268         case 'd':
1269         case 'D':
1270         case 'h':
1271         case 'i':
1272         case 'l':
1273         case 'M':
1274         case 'm':
1275         case 'n':
1276         case 'p':
1277         case 's':
1278         case 'u':
1279         case 'U':
1280         case 'v':
1281         case 'W':
1282         case 'X':
1283         case 'w':
1284         case 'A':
1285             if ((s = moreswitches(s)))
1286                 goto reswitch;
1287             break;
1288
1289         case 't':
1290             CHECK_MALLOC_TOO_LATE_FOR('t');
1291             if( !PL_tainting ) {
1292                  PL_taint_warn = TRUE;
1293                  PL_tainting = TRUE;
1294             }
1295             s++;
1296             goto reswitch;
1297         case 'T':
1298             CHECK_MALLOC_TOO_LATE_FOR('T');
1299             PL_tainting = TRUE;
1300             PL_taint_warn = FALSE;
1301             s++;
1302             goto reswitch;
1303
1304         case 'e':
1305 #ifdef MACOS_TRADITIONAL
1306             /* ignore -e for Dev:Pseudo argument */
1307             if (argv[1] && !strcmp(argv[1], "Dev:Pseudo"))
1308                 break;
1309 #endif
1310             forbid_setid("-e");
1311             if (!PL_e_script) {
1312                 PL_e_script = newSVpvn("",0);
1313                 filter_add(read_e_script, NULL);
1314             }
1315             if (*++s)
1316                 sv_catpv(PL_e_script, s);
1317             else if (argv[1]) {
1318                 sv_catpv(PL_e_script, argv[1]);
1319                 argc--,argv++;
1320             }
1321             else
1322                 Perl_croak(aTHX_ "No code specified for -e");
1323             sv_catpv(PL_e_script, "\n");
1324             break;
1325
1326         case 'f':
1327             minus_f = TRUE;
1328             s++;
1329             goto reswitch;
1330
1331         case 'I':       /* -I handled both here and in moreswitches() */
1332             forbid_setid("-I");
1333             if (!*++s && (s=argv[1]) != Nullch) {
1334                 argc--,argv++;
1335             }
1336             if (s && *s) {
1337                 char *p;
1338                 STRLEN len = strlen(s);
1339                 p = savepvn(s, len);
1340                 incpush(p, TRUE, TRUE, FALSE, FALSE);
1341                 sv_catpvn(sv, "-I", 2);
1342                 sv_catpvn(sv, p, len);
1343                 sv_catpvn(sv, " ", 1);
1344                 Safefree(p);
1345             }
1346             else
1347                 Perl_croak(aTHX_ "No directory specified for -I");
1348             break;
1349         case 'P':
1350             forbid_setid("-P");
1351             PL_preprocess = TRUE;
1352             s++;
1353             goto reswitch;
1354         case 'S':
1355             forbid_setid("-S");
1356             dosearch = TRUE;
1357             s++;
1358             goto reswitch;
1359         case 'V':
1360             if (!PL_preambleav)
1361                 PL_preambleav = newAV();
1362             av_push(PL_preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
1363             if (*++s != ':')  {
1364                 PL_Sv = newSVpv("print myconfig();",0);
1365 #ifdef VMS
1366                 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
1367 #else
1368                 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
1369 #endif
1370                 sv_catpv(PL_Sv,"\"  Compile-time options:");
1371 #  ifdef DEBUGGING
1372                 sv_catpv(PL_Sv," DEBUGGING");
1373 #  endif
1374 #  ifdef MULTIPLICITY
1375                 sv_catpv(PL_Sv," MULTIPLICITY");
1376 #  endif
1377 #  ifdef USE_5005THREADS
1378                 sv_catpv(PL_Sv," USE_5005THREADS");
1379 #  endif
1380 #  ifdef USE_ITHREADS
1381                 sv_catpv(PL_Sv," USE_ITHREADS");
1382 #  endif
1383 #  ifdef USE_64_BIT_INT
1384                 sv_catpv(PL_Sv," USE_64_BIT_INT");
1385 #  endif
1386 #  ifdef USE_64_BIT_ALL
1387                 sv_catpv(PL_Sv," USE_64_BIT_ALL");
1388 #  endif
1389 #  ifdef USE_LONG_DOUBLE
1390                 sv_catpv(PL_Sv," USE_LONG_DOUBLE");
1391 #  endif
1392 #  ifdef USE_LARGE_FILES
1393                 sv_catpv(PL_Sv," USE_LARGE_FILES");
1394 #  endif
1395 #  ifdef USE_SOCKS
1396                 sv_catpv(PL_Sv," USE_SOCKS");
1397 #  endif
1398 #  ifdef USE_SITECUSTOMIZE
1399                 sv_catpv(PL_Sv," USE_SITECUSTOMIZE");
1400 #  endif
1401 #  ifdef PERL_IMPLICIT_CONTEXT
1402                 sv_catpv(PL_Sv," PERL_IMPLICIT_CONTEXT");
1403 #  endif
1404 #  ifdef PERL_IMPLICIT_SYS
1405                 sv_catpv(PL_Sv," PERL_IMPLICIT_SYS");
1406 #  endif
1407                 sv_catpv(PL_Sv,"\\n\",");
1408
1409 #if defined(LOCAL_PATCH_COUNT)
1410                 if (LOCAL_PATCH_COUNT > 0) {
1411                     int i;
1412                     sv_catpv(PL_Sv,"\"  Locally applied patches:\\n\",");
1413                     for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
1414                         if (PL_localpatches[i])
1415                             Perl_sv_catpvf(aTHX_ PL_Sv,"q%c\t%s\n%c,",
1416                                     0, PL_localpatches[i], 0);
1417                     }
1418                 }
1419 #endif
1420                 Perl_sv_catpvf(aTHX_ PL_Sv,"\"  Built under %s\\n\"",OSNAME);
1421 #ifdef __DATE__
1422 #  ifdef __TIME__
1423                 Perl_sv_catpvf(aTHX_ PL_Sv,",\"  Compiled at %s %s\\n\"",__DATE__,__TIME__);
1424 #  else
1425                 Perl_sv_catpvf(aTHX_ PL_Sv,",\"  Compiled on %s\\n\"",__DATE__);
1426 #  endif
1427 #endif
1428                 sv_catpv(PL_Sv, "; \
1429 $\"=\"\\n    \"; \
1430 @env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; ");
1431 #ifdef __CYGWIN__
1432                 sv_catpv(PL_Sv,"\
1433 push @env, \"CYGWIN=\\\"$ENV{CYGWIN}\\\"\";");
1434 #endif
1435                 sv_catpv(PL_Sv, "\
1436 print \"  \\%ENV:\\n    @env\\n\" if @env; \
1437 print \"  \\@INC:\\n    @INC\\n\";");
1438             }
1439             else {
1440                 PL_Sv = newSVpv("config_vars(qw(",0);
1441                 sv_catpv(PL_Sv, ++s);
1442                 sv_catpv(PL_Sv, "))");
1443                 s += strlen(s);
1444             }
1445             av_push(PL_preambleav, PL_Sv);
1446             scriptname = BIT_BUCKET;    /* don't look for script or read stdin */
1447             goto reswitch;
1448         case 'x':
1449             PL_doextract = TRUE;
1450             s++;
1451             if (*s)
1452                 cddir = s;
1453             break;
1454         case 0:
1455             break;
1456         case '-':
1457             if (!*++s || isSPACE(*s)) {
1458                 argc--,argv++;
1459                 goto switch_end;
1460             }
1461             /* catch use of gnu style long options */
1462             if (strEQ(s, "version")) {
1463                 s = "v";
1464                 goto reswitch;
1465             }
1466             if (strEQ(s, "help")) {
1467                 s = "h";
1468                 goto reswitch;
1469             }
1470             s--;
1471             /* FALL THROUGH */
1472         default:
1473             Perl_croak(aTHX_ "Unrecognized switch: -%s  (-h will show valid options)",s);
1474         }
1475     }
1476   switch_end:
1477
1478     if (
1479 #ifndef SECURE_INTERNAL_GETENV
1480         !PL_tainting &&
1481 #endif
1482         (s = PerlEnv_getenv("PERL5OPT")))
1483     {
1484         char *popt = s;
1485         while (isSPACE(*s))
1486             s++;
1487         if (*s == '-' && *(s+1) == 'T') {
1488             CHECK_MALLOC_TOO_LATE_FOR('T');
1489             PL_tainting = TRUE;
1490             PL_taint_warn = FALSE;
1491         }
1492         else {
1493             char *popt_copy = Nullch;
1494             while (s && *s) {
1495                 char *d;
1496                 while (isSPACE(*s))
1497                     s++;
1498                 if (*s == '-') {
1499                     s++;
1500                     if (isSPACE(*s))
1501                         continue;
1502                 }
1503                 d = s;
1504                 if (!*s)
1505                     break;
1506                 if (!strchr("DIMUdmtwA", *s))
1507                     Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s);
1508                 while (++s && *s) {
1509                     if (isSPACE(*s)) {
1510                         if (!popt_copy) {
1511                             popt_copy = SvPVX(sv_2mortal(newSVpv(popt,0)));
1512                             s = popt_copy + (s - popt);
1513                             d = popt_copy + (d - popt);
1514                         }
1515                         *s++ = '\0';
1516                         break;
1517                     }
1518                 }
1519                 if (*d == 't') {
1520                     if( !PL_tainting ) {
1521                         PL_taint_warn = TRUE;
1522                         PL_tainting = TRUE;
1523                     }
1524                 } else {
1525                     moreswitches(d);
1526                 }
1527             }
1528         }
1529     }
1530
1531 #ifdef USE_SITECUSTOMIZE
1532     if (!minus_f) {
1533         if (!PL_preambleav)
1534             PL_preambleav = newAV();
1535         av_unshift(PL_preambleav, 1);
1536         (void)av_store(PL_preambleav, 0, Perl_newSVpvf(aTHX_ "BEGIN { do '%s/sitecustomize.pl' }", SITELIB_EXP));
1537     }
1538 #endif
1539
1540     if (PL_taint_warn && PL_dowarn != G_WARN_ALL_OFF) {
1541        PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
1542     }
1543
1544     if (!scriptname)
1545         scriptname = argv[0];
1546     if (PL_e_script) {
1547         argc++,argv--;
1548         scriptname = BIT_BUCKET;        /* don't look for script or read stdin */
1549     }
1550     else if (scriptname == Nullch) {
1551 #ifdef MSDOS
1552         if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) )
1553             moreswitches("h");
1554 #endif
1555         scriptname = "-";
1556     }
1557
1558     /* Set $^X early so that it can be used for relocatable paths in @INC  */
1559     assert (!PL_tainted);
1560     TAINT;
1561     S_set_caret_X(aTHX);
1562     TAINT_NOT;
1563     init_perllib();
1564
1565     open_script(scriptname,dosearch,sv);
1566
1567     validate_suid(validarg, scriptname);
1568
1569 #ifndef PERL_MICRO
1570 #if defined(SIGCHLD) || defined(SIGCLD)
1571     {
1572 #ifndef SIGCHLD
1573 #  define SIGCHLD SIGCLD
1574 #endif
1575         Sighandler_t sigstate = rsignal_state(SIGCHLD);
1576         if (sigstate == SIG_IGN) {
1577             if (ckWARN(WARN_SIGNAL))
1578                 Perl_warner(aTHX_ packWARN(WARN_SIGNAL),
1579                             "Can't ignore signal CHLD, forcing to default");
1580             (void)rsignal(SIGCHLD, (Sighandler_t)SIG_DFL);
1581         }
1582     }
1583 #endif
1584 #endif
1585
1586 #ifdef MACOS_TRADITIONAL
1587     if (PL_doextract || gMacPerl_AlwaysExtract) {
1588 #else
1589     if (PL_doextract) {
1590 #endif
1591         find_beginning();
1592         if (cddir && PerlDir_chdir(cddir) < 0)
1593             Perl_croak(aTHX_ "Can't chdir to %s",cddir);
1594
1595     }
1596
1597     PL_main_cv = PL_compcv = (CV*)NEWSV(1104,0);
1598     sv_upgrade((SV *)PL_compcv, SVt_PVCV);
1599     CvUNIQUE_on(PL_compcv);
1600
1601     CvPADLIST(PL_compcv) = pad_new(0);
1602 #ifdef USE_5005THREADS
1603     CvOWNER(PL_compcv) = 0;
1604     New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
1605     MUTEX_INIT(CvMUTEXP(PL_compcv));
1606 #endif /* USE_5005THREADS */
1607
1608     boot_core_PerlIO();
1609     boot_core_UNIVERSAL();
1610     boot_core_xsutils();
1611
1612     if (xsinit)
1613         (*xsinit)(aTHX);        /* in case linked C routines want magical variables */
1614 #ifndef PERL_MICRO
1615 #if defined(VMS) || defined(WIN32) || defined(DJGPP) || defined(__CYGWIN__) || defined(EPOC)
1616     init_os_extras();
1617 #endif
1618 #endif
1619
1620 #ifdef USE_SOCKS
1621 #   ifdef HAS_SOCKS5_INIT
1622     socks5_init(argv[0]);
1623 #   else
1624     SOCKSinit(argv[0]);
1625 #   endif
1626 #endif
1627
1628     init_predump_symbols();
1629     /* init_postdump_symbols not currently designed to be called */
1630     /* more than once (ENV isn't cleared first, for example)     */
1631     /* But running with -u leaves %ENV & @ARGV undefined!    XXX */
1632     if (!PL_do_undump)
1633         init_postdump_symbols(argc,argv,env);
1634
1635     /* PL_unicode is turned on by -C or by $ENV{PERL_UNICODE}.
1636      * PL_utf8locale is conditionally turned on by
1637      * locale.c:Perl_init_i18nl10n() if the environment
1638      * look like the user wants to use UTF-8. */
1639     if (PL_unicode) {
1640          /* Requires init_predump_symbols(). */
1641          if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) {
1642               IO* io;
1643               PerlIO* fp;
1644               SV* sv;
1645
1646               /* Turn on UTF-8-ness on STDIN, STDOUT, STDERR
1647                * and the default open disciplines. */
1648               if ((PL_unicode & PERL_UNICODE_STDIN_FLAG) &&
1649                   PL_stdingv  && (io = GvIO(PL_stdingv)) &&
1650                   (fp = IoIFP(io)))
1651                    PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
1652               if ((PL_unicode & PERL_UNICODE_STDOUT_FLAG) &&
1653                   PL_defoutgv && (io = GvIO(PL_defoutgv)) &&
1654                   (fp = IoOFP(io)))
1655                    PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
1656               if ((PL_unicode & PERL_UNICODE_STDERR_FLAG) &&
1657                   PL_stderrgv && (io = GvIO(PL_stderrgv)) &&
1658                   (fp = IoOFP(io)))
1659                    PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
1660               if ((PL_unicode & PERL_UNICODE_INOUT_FLAG) &&
1661                   (sv = GvSV(gv_fetchpv("\017PEN", TRUE, SVt_PV)))) {
1662                    U32 in  = PL_unicode & PERL_UNICODE_IN_FLAG;
1663                    U32 out = PL_unicode & PERL_UNICODE_OUT_FLAG;
1664                    if (in) {
1665                         if (out)
1666                              sv_setpvn(sv, ":utf8\0:utf8", 11);
1667                         else
1668                              sv_setpvn(sv, ":utf8\0", 6);
1669                    }
1670                    else if (out)
1671                         sv_setpvn(sv, "\0:utf8", 6);
1672                    SvSETMAGIC(sv);
1673               }
1674          }
1675     }
1676
1677     if ((s = PerlEnv_getenv("PERL_SIGNALS"))) {
1678          if (strEQ(s, "unsafe"))
1679               PL_signals |=  PERL_SIGNALS_UNSAFE_FLAG;
1680          else if (strEQ(s, "safe"))
1681               PL_signals &= ~PERL_SIGNALS_UNSAFE_FLAG;
1682          else
1683               Perl_croak(aTHX_ "PERL_SIGNALS illegal: \"%s\"", s);
1684     }
1685
1686     init_lexer();
1687
1688     /* now parse the script */
1689
1690     SETERRNO(0,SS_NORMAL);
1691     PL_error_count = 0;
1692 #ifdef MACOS_TRADITIONAL
1693     if (gMacPerl_SyntaxError = (yyparse() || PL_error_count)) {
1694         if (PL_minus_c)
1695             Perl_croak(aTHX_ "%s had compilation errors.\n", MacPerl_MPWFileName(PL_origfilename));
1696         else {
1697             Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
1698                        MacPerl_MPWFileName(PL_origfilename));
1699         }
1700     }
1701 #else
1702     if (yyparse() || PL_error_count) {
1703         if (PL_minus_c)
1704             Perl_croak(aTHX_ "%s had compilation errors.\n", PL_origfilename);
1705         else {
1706             Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
1707                        PL_origfilename);
1708         }
1709     }
1710 #endif
1711     CopLINE_set(PL_curcop, 0);
1712     PL_curstash = PL_defstash;
1713     PL_preprocess = FALSE;
1714     if (PL_e_script) {
1715         SvREFCNT_dec(PL_e_script);
1716         PL_e_script = Nullsv;
1717     }
1718
1719     if (PL_do_undump)
1720         my_unexec();
1721
1722     if (isWARN_ONCE) {
1723         SAVECOPFILE(PL_curcop);
1724         SAVECOPLINE(PL_curcop);
1725         gv_check(PL_defstash);
1726     }
1727
1728     LEAVE;
1729     FREETMPS;
1730
1731 #ifdef MYMALLOC
1732     if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
1733         dump_mstats("after compilation:");
1734 #endif
1735
1736     ENTER;
1737     PL_restartop = 0;
1738     return NULL;
1739 }
1740
1741 /*
1742 =for apidoc perl_run
1743
1744 Tells a Perl interpreter to run.  See L<perlembed>.
1745
1746 =cut
1747 */
1748
1749 int
1750 perl_run(pTHXx)
1751 {
1752     I32 oldscope;
1753     int ret = 0;
1754     dJMPENV;
1755
1756     oldscope = PL_scopestack_ix;
1757 #ifdef VMS
1758     VMSISH_HUSHED = 0;
1759 #endif
1760
1761     JMPENV_PUSH(ret);
1762     switch (ret) {
1763     case 1:
1764         cxstack_ix = -1;                /* start context stack again */
1765         goto redo_body;
1766     case 0:                             /* normal completion */
1767  redo_body:
1768         run_body(oldscope);
1769         /* FALL THROUGH */
1770     case 2:                             /* my_exit() */
1771         while (PL_scopestack_ix > oldscope)
1772             LEAVE;
1773         FREETMPS;
1774         PL_curstash = PL_defstash;
1775         if (!(PL_exit_flags & PERL_EXIT_DESTRUCT_END) &&
1776             PL_endav && !PL_minus_c)
1777             call_list(oldscope, PL_endav);
1778 #ifdef MYMALLOC
1779         if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
1780             dump_mstats("after execution:  ");
1781 #endif
1782         ret = STATUS_NATIVE_EXPORT;
1783         break;
1784     case 3:
1785         if (PL_restartop) {
1786             POPSTACK_TO(PL_mainstack);
1787             goto redo_body;
1788         }
1789         PerlIO_printf(Perl_error_log, "panic: restartop\n");
1790         FREETMPS;
1791         ret = 1;
1792         break;
1793     }
1794
1795     JMPENV_POP;
1796     return ret;
1797 }
1798
1799
1800 STATIC void *
1801 S_run_body(pTHX_ I32 oldscope)
1802 {
1803     DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
1804                     PL_sawampersand ? "Enabling" : "Omitting"));
1805
1806     if (!PL_restartop) {
1807         DEBUG_x(dump_all());
1808         if (!DEBUG_q_TEST)
1809           PERL_DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
1810         DEBUG_S(PerlIO_printf(Perl_debug_log, "main thread is 0x%"UVxf"\n",
1811                               PTR2UV(thr)));
1812
1813         if (PL_minus_c) {
1814 #ifdef MACOS_TRADITIONAL
1815             PerlIO_printf(Perl_error_log, "%s%s syntax OK\n",
1816                 (gMacPerl_ErrorFormat ? "# " : ""),
1817                 MacPerl_MPWFileName(PL_origfilename));
1818 #else
1819             PerlIO_printf(Perl_error_log, "%s syntax OK\n", PL_origfilename);
1820 #endif
1821             my_exit(0);
1822         }
1823         if (PERLDB_SINGLE && PL_DBsingle)
1824             sv_setiv(PL_DBsingle, 1);
1825         if (PL_initav)
1826             call_list(oldscope, PL_initav);
1827     }
1828
1829     /* do it */
1830
1831     if (PL_restartop) {
1832         PL_op = PL_restartop;
1833         PL_restartop = 0;
1834         CALLRUNOPS(aTHX);
1835     }
1836     else if (PL_main_start) {
1837         CvDEPTH(PL_main_cv) = 1;
1838         PL_op = PL_main_start;
1839         CALLRUNOPS(aTHX);
1840     }
1841
1842     my_exit(0);
1843     /* NOTREACHED */
1844     return NULL;
1845 }
1846
1847 /*
1848 =head1 SV Manipulation Functions
1849
1850 =for apidoc p||get_sv
1851
1852 Returns the SV of the specified Perl scalar.  If C<create> is set and the
1853 Perl variable does not exist then it will be created.  If C<create> is not
1854 set and the variable does not exist then NULL is returned.
1855
1856 =cut
1857 */
1858
1859 SV*
1860 Perl_get_sv(pTHX_ const char *name, I32 create)
1861 {
1862     GV *gv;
1863 #ifdef USE_5005THREADS
1864     if (name[1] == '\0' && !isALPHA(name[0])) {
1865         PADOFFSET tmp = find_threadsv(name);
1866         if (tmp != NOT_IN_PAD)
1867             return THREADSV(tmp);
1868     }
1869 #endif /* USE_5005THREADS */
1870     gv = gv_fetchpv(name, create, SVt_PV);
1871     if (gv)
1872         return GvSV(gv);
1873     return Nullsv;
1874 }
1875
1876 /*
1877 =head1 Array Manipulation Functions
1878
1879 =for apidoc p||get_av
1880
1881 Returns the AV of the specified Perl array.  If C<create> is set and the
1882 Perl variable does not exist then it will be created.  If C<create> is not
1883 set and the variable does not exist then NULL is returned.
1884
1885 =cut
1886 */
1887
1888 AV*
1889 Perl_get_av(pTHX_ const char *name, I32 create)
1890 {
1891     GV* gv = gv_fetchpv(name, create, SVt_PVAV);
1892     if (create)
1893         return GvAVn(gv);
1894     if (gv)
1895         return GvAV(gv);
1896     return Nullav;
1897 }
1898
1899 /*
1900 =head1 Hash Manipulation Functions
1901
1902 =for apidoc p||get_hv
1903
1904 Returns the HV of the specified Perl hash.  If C<create> is set and the
1905 Perl variable does not exist then it will be created.  If C<create> is not
1906 set and the variable does not exist then NULL is returned.
1907
1908 =cut
1909 */
1910
1911 HV*
1912 Perl_get_hv(pTHX_ const char *name, I32 create)
1913 {
1914     GV* gv = gv_fetchpv(name, create, SVt_PVHV);
1915     if (create)
1916         return GvHVn(gv);
1917     if (gv)
1918         return GvHV(gv);
1919     return Nullhv;
1920 }
1921
1922 /*
1923 =head1 CV Manipulation Functions
1924
1925 =for apidoc p||get_cv
1926
1927 Returns the CV of the specified Perl subroutine.  If C<create> is set and
1928 the Perl subroutine does not exist then it will be declared (which has the
1929 same effect as saying C<sub name;>).  If C<create> is not set and the
1930 subroutine does not exist then NULL is returned.
1931
1932 =cut
1933 */
1934
1935 CV*
1936 Perl_get_cv(pTHX_ const char *name, I32 create)
1937 {
1938     GV* gv = gv_fetchpv(name, create, SVt_PVCV);
1939     /* XXX unsafe for threads if eval_owner isn't held */
1940     /* XXX this is probably not what they think they're getting.
1941      * It has the same effect as "sub name;", i.e. just a forward
1942      * declaration! */
1943     if (create && !GvCVu(gv))
1944         return newSUB(start_subparse(FALSE, 0),
1945                       newSVOP(OP_CONST, 0, newSVpv(name,0)),
1946                       Nullop,
1947                       Nullop);
1948     if (gv)
1949         return GvCVu(gv);
1950     return Nullcv;
1951 }
1952
1953 /* Be sure to refetch the stack pointer after calling these routines. */
1954
1955 /*
1956
1957 =head1 Callback Functions
1958
1959 =for apidoc p||call_argv
1960
1961 Performs a callback to the specified Perl sub.  See L<perlcall>.
1962
1963 =cut
1964 */
1965
1966 I32
1967 Perl_call_argv(pTHX_ const char *sub_name, I32 flags, register char **argv)
1968
1969                         /* See G_* flags in cop.h */
1970                         /* null terminated arg list */
1971 {
1972     dSP;
1973
1974     PUSHMARK(SP);
1975     if (argv) {
1976         while (*argv) {
1977             XPUSHs(sv_2mortal(newSVpv(*argv,0)));
1978             argv++;
1979         }
1980         PUTBACK;
1981     }
1982     return call_pv(sub_name, flags);
1983 }
1984
1985 /*
1986 =for apidoc p||call_pv
1987
1988 Performs a callback to the specified Perl sub.  See L<perlcall>.
1989
1990 =cut
1991 */
1992
1993 I32
1994 Perl_call_pv(pTHX_ const char *sub_name, I32 flags)
1995                         /* name of the subroutine */
1996                         /* See G_* flags in cop.h */
1997 {
1998     return call_sv((SV*)get_cv(sub_name, TRUE), flags);
1999 }
2000
2001 /*
2002 =for apidoc p||call_method
2003
2004 Performs a callback to the specified Perl method.  The blessed object must
2005 be on the stack.  See L<perlcall>.
2006
2007 =cut
2008 */
2009
2010 I32
2011 Perl_call_method(pTHX_ const char *methname, I32 flags)
2012                         /* name of the subroutine */
2013                         /* See G_* flags in cop.h */
2014 {
2015     return call_sv(sv_2mortal(newSVpv(methname,0)), flags | G_METHOD);
2016 }
2017
2018 /* May be called with any of a CV, a GV, or an SV containing the name. */
2019 /*
2020 =for apidoc p||call_sv
2021
2022 Performs a callback to the Perl sub whose name is in the SV.  See
2023 L<perlcall>.
2024
2025 =cut
2026 */
2027
2028 I32
2029 Perl_call_sv(pTHX_ SV *sv, I32 flags)
2030                         /* See G_* flags in cop.h */
2031 {
2032     dSP;
2033     LOGOP myop;         /* fake syntax tree node */
2034     UNOP method_op;
2035     I32 oldmark;
2036     volatile I32 retval = 0;
2037     I32 oldscope;
2038     bool oldcatch = CATCH_GET;
2039     int ret;
2040     OP* oldop = PL_op;
2041     dJMPENV;
2042
2043     if (flags & G_DISCARD) {
2044         ENTER;
2045         SAVETMPS;
2046     }
2047
2048     Zero(&myop, 1, LOGOP);
2049     myop.op_next = Nullop;
2050     if (!(flags & G_NOARGS))
2051         myop.op_flags |= OPf_STACKED;
2052     myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
2053                       (flags & G_ARRAY) ? OPf_WANT_LIST :
2054                       OPf_WANT_SCALAR);
2055     SAVEOP();
2056     PL_op = (OP*)&myop;
2057
2058     EXTEND(PL_stack_sp, 1);
2059     *++PL_stack_sp = sv;
2060     oldmark = TOPMARK;
2061     oldscope = PL_scopestack_ix;
2062
2063     if (PERLDB_SUB && PL_curstash != PL_debstash
2064            /* Handle first BEGIN of -d. */
2065           && (PL_DBcv || (PL_DBcv = GvCV(PL_DBsub)))
2066            /* Try harder, since this may have been a sighandler, thus
2067             * curstash may be meaningless. */
2068           && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != PL_debstash)
2069           && !(flags & G_NODEBUG))
2070         PL_op->op_private |= OPpENTERSUB_DB;
2071
2072     if (flags & G_METHOD) {
2073         Zero(&method_op, 1, UNOP);
2074         method_op.op_next = PL_op;
2075         method_op.op_ppaddr = PL_ppaddr[OP_METHOD];
2076         myop.op_ppaddr = PL_ppaddr[OP_ENTERSUB];
2077         PL_op = (OP*)&method_op;
2078     }
2079
2080     if (!(flags & G_EVAL)) {
2081         CATCH_SET(TRUE);
2082         call_body((OP*)&myop, FALSE);
2083         retval = PL_stack_sp - (PL_stack_base + oldmark);
2084         CATCH_SET(oldcatch);
2085     }
2086     else {
2087         myop.op_other = (OP*)&myop;
2088         PL_markstack_ptr--;
2089         /* we're trying to emulate pp_entertry() here */
2090         {
2091             register PERL_CONTEXT *cx;
2092             I32 gimme = GIMME_V;
2093
2094             ENTER;
2095             SAVETMPS;
2096
2097             PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
2098             PUSHEVAL(cx, 0, 0);
2099             PL_eval_root = PL_op;             /* Only needed so that goto works right. */
2100
2101             PL_in_eval = EVAL_INEVAL;
2102             if (flags & G_KEEPERR)
2103                 PL_in_eval |= EVAL_KEEPERR;
2104             else
2105                 sv_setpv(ERRSV,"");
2106         }
2107         PL_markstack_ptr++;
2108
2109         JMPENV_PUSH(ret);
2110         switch (ret) {
2111         case 0:
2112  redo_body:
2113             call_body((OP*)&myop, FALSE);
2114             retval = PL_stack_sp - (PL_stack_base + oldmark);
2115             if (!(flags & G_KEEPERR))
2116                 sv_setpv(ERRSV,"");
2117             break;
2118         case 1:
2119             STATUS_ALL_FAILURE;
2120             /* FALL THROUGH */
2121         case 2:
2122             /* my_exit() was called */
2123             PL_curstash = PL_defstash;
2124             FREETMPS;
2125             JMPENV_POP;
2126             if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
2127                 Perl_croak(aTHX_ "Callback called exit");
2128             my_exit_jump();
2129             /* NOTREACHED */
2130         case 3:
2131             if (PL_restartop) {
2132                 PL_op = PL_restartop;
2133                 PL_restartop = 0;
2134                 goto redo_body;
2135             }
2136             PL_stack_sp = PL_stack_base + oldmark;
2137             if (flags & G_ARRAY)
2138                 retval = 0;
2139             else {
2140                 retval = 1;
2141                 *++PL_stack_sp = &PL_sv_undef;
2142             }
2143             break;
2144         }
2145
2146         if (PL_scopestack_ix > oldscope) {
2147             SV **newsp;
2148             PMOP *newpm;
2149             I32 gimme;
2150             register PERL_CONTEXT *cx;
2151             I32 optype;
2152
2153             POPBLOCK(cx,newpm);
2154             POPEVAL(cx);
2155             PL_curpm = newpm;
2156             LEAVE;
2157         }
2158         JMPENV_POP;
2159     }
2160
2161     if (flags & G_DISCARD) {
2162         PL_stack_sp = PL_stack_base + oldmark;
2163         retval = 0;
2164         FREETMPS;
2165         LEAVE;
2166     }
2167     PL_op = oldop;
2168     return retval;
2169 }
2170
2171 STATIC void
2172 S_call_body(pTHX_ OP *myop, int is_eval)
2173 {
2174     if (PL_op == myop) {
2175         if (is_eval)
2176             PL_op = Perl_pp_entereval(aTHX);    /* this doesn't do a POPMARK */
2177         else
2178             PL_op = Perl_pp_entersub(aTHX);     /* this does */
2179     }
2180     if (PL_op)
2181         CALLRUNOPS(aTHX);
2182 }
2183
2184 /* Eval a string. The G_EVAL flag is always assumed. */
2185
2186 /*
2187 =for apidoc p||eval_sv
2188
2189 Tells Perl to C<eval> the string in the SV.
2190
2191 =cut
2192 */
2193
2194 I32
2195 Perl_eval_sv(pTHX_ SV *sv, I32 flags)
2196
2197                         /* See G_* flags in cop.h */
2198 {
2199     dSP;
2200     UNOP myop;          /* fake syntax tree node */
2201     volatile I32 oldmark = SP - PL_stack_base;
2202     volatile I32 retval = 0;
2203     I32 oldscope;
2204     int ret;
2205     OP* oldop = PL_op;
2206     dJMPENV;
2207
2208     if (flags & G_DISCARD) {
2209         ENTER;
2210         SAVETMPS;
2211     }
2212
2213     SAVEOP();
2214     PL_op = (OP*)&myop;
2215     Zero(PL_op, 1, UNOP);
2216     EXTEND(PL_stack_sp, 1);
2217     *++PL_stack_sp = sv;
2218     oldscope = PL_scopestack_ix;
2219
2220     if (!(flags & G_NOARGS))
2221         myop.op_flags = OPf_STACKED;
2222     myop.op_next = Nullop;
2223     myop.op_type = OP_ENTEREVAL;
2224     myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
2225                       (flags & G_ARRAY) ? OPf_WANT_LIST :
2226                       OPf_WANT_SCALAR);
2227     if (flags & G_KEEPERR)
2228         myop.op_flags |= OPf_SPECIAL;
2229
2230     /* fail now; otherwise we could fail after the JMPENV_PUSH but
2231      * before a PUSHEVAL, which corrupts the stack after a croak */
2232     TAINT_PROPER("eval_sv()");
2233
2234     JMPENV_PUSH(ret);
2235     switch (ret) {
2236     case 0:
2237  redo_body:
2238         call_body((OP*)&myop,TRUE);
2239         retval = PL_stack_sp - (PL_stack_base + oldmark);
2240         if (!(flags & G_KEEPERR))
2241             sv_setpv(ERRSV,"");
2242         break;
2243     case 1:
2244         STATUS_ALL_FAILURE;
2245         /* FALL THROUGH */
2246     case 2:
2247         /* my_exit() was called */
2248         PL_curstash = PL_defstash;
2249         FREETMPS;
2250         JMPENV_POP;
2251         if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
2252             Perl_croak(aTHX_ "Callback called exit");
2253         my_exit_jump();
2254         /* NOTREACHED */
2255     case 3:
2256         if (PL_restartop) {
2257             PL_op = PL_restartop;
2258             PL_restartop = 0;
2259             goto redo_body;
2260         }
2261         PL_stack_sp = PL_stack_base + oldmark;
2262         if (flags & G_ARRAY)
2263             retval = 0;
2264         else {
2265             retval = 1;
2266             *++PL_stack_sp = &PL_sv_undef;
2267         }
2268         break;
2269     }
2270
2271     JMPENV_POP;
2272     if (flags & G_DISCARD) {
2273         PL_stack_sp = PL_stack_base + oldmark;
2274         retval = 0;
2275         FREETMPS;
2276         LEAVE;
2277     }
2278     PL_op = oldop;
2279     return retval;
2280 }
2281
2282 /*
2283 =for apidoc p||eval_pv
2284
2285 Tells Perl to C<eval> the given string and return an SV* result.
2286
2287 =cut
2288 */
2289
2290 SV*
2291 Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error)
2292 {
2293     dSP;
2294     SV* sv = newSVpv(p, 0);
2295
2296     eval_sv(sv, G_SCALAR);
2297     SvREFCNT_dec(sv);
2298
2299     SPAGAIN;
2300     sv = POPs;
2301     PUTBACK;
2302
2303     if (croak_on_error && SvTRUE(ERRSV)) {
2304         STRLEN n_a;
2305         Perl_croak(aTHX_ SvPVx(ERRSV, n_a));
2306     }
2307
2308     return sv;
2309 }
2310
2311 /* Require a module. */
2312
2313 /*
2314 =head1 Embedding Functions
2315
2316 =for apidoc p||require_pv
2317
2318 Tells Perl to C<require> the file named by the string argument.  It is
2319 analogous to the Perl code C<eval "require '$file'">.  It's even
2320 implemented that way; consider using load_module instead.
2321
2322 =cut */
2323
2324 void
2325 Perl_require_pv(pTHX_ const char *pv)
2326 {
2327     SV* sv;
2328     dSP;
2329     PUSHSTACKi(PERLSI_REQUIRE);
2330     PUTBACK;
2331     sv = sv_newmortal();
2332     sv_setpv(sv, "require '");
2333     sv_catpv(sv, pv);
2334     sv_catpv(sv, "'");
2335     eval_sv(sv, G_DISCARD);
2336     SPAGAIN;
2337     POPSTACK;
2338 }
2339
2340 void
2341 Perl_magicname(pTHX_ char *sym, char *name, I32 namlen)
2342 {
2343     register GV *gv;
2344
2345     if ((gv = gv_fetchpv(sym,TRUE, SVt_PV)))
2346         sv_magic(GvSV(gv), (SV*)gv, PERL_MAGIC_sv, name, namlen);
2347 }
2348
2349 STATIC void
2350 S_usage(pTHX_ char *name)               /* XXX move this out into a module ? */
2351 {
2352     /* This message really ought to be max 23 lines.
2353      * Removed -h because the user already knows that option. Others? */
2354
2355     static char *usage_msg[] = {
2356 "-0[octal]       specify record separator (\\0, if no argument)",
2357 "-a              autosplit mode with -n or -p (splits $_ into @F)",
2358 "-C[number/list] enables the listed Unicode features",
2359 "-c              check syntax only (runs BEGIN and CHECK blocks)",
2360 "-d[:debugger]   run program under debugger",
2361 "-D[number/list] set debugging flags (argument is a bit mask or alphabets)",
2362 "-e program      one line of program (several -e's allowed, omit programfile)",
2363 "-f              don't do $sitelib/sitecustomize.pl at startup",
2364 "-F/pattern/     split() pattern for -a switch (//'s are optional)",
2365 "-i[extension]   edit <> files in place (makes backup if extension supplied)",
2366 "-Idirectory     specify @INC/#include directory (several -I's allowed)",
2367 "-l[octal]       enable line ending processing, specifies line terminator",
2368 "-[mM][-]module  execute `use/no module...' before executing program",
2369 "-n              assume 'while (<>) { ... }' loop around program",
2370 "-p              assume loop like -n but print line also, like sed",
2371 "-P              run program through C preprocessor before compilation",
2372 "-s              enable rudimentary parsing for switches after programfile",
2373 "-S              look for programfile using PATH environment variable",
2374 "-t              enable tainting warnings",
2375 "-T              enable tainting checks",
2376 "-u              dump core after parsing program",
2377 "-U              allow unsafe operations",
2378 "-v              print version, subversion (includes VERY IMPORTANT perl info)",
2379 "-V[:variable]   print configuration summary (or a single Config.pm variable)",
2380 "-w              enable many useful warnings (RECOMMENDED)",
2381 "-W              enable all warnings",
2382 "-x[directory]   strip off text before #!perl line and perhaps cd to directory",
2383 "-X              disable all warnings",
2384 "\n",
2385 NULL
2386 };
2387     char **p = usage_msg;
2388
2389     PerlIO_printf(PerlIO_stdout(),
2390                   "\nUsage: %s [switches] [--] [programfile] [arguments]",
2391                   name);
2392     while (*p)
2393         PerlIO_printf(PerlIO_stdout(), "\n  %s", *p++);
2394 }
2395
2396 /* convert a string of -D options (or digits) into an int.
2397  * sets *s to point to the char after the options */
2398
2399 #ifdef DEBUGGING
2400 int
2401 Perl_get_debug_opts(pTHX_ char **s, bool givehelp)
2402 {
2403     static char *usage_msgd[] = {
2404       " Debugging flag values: (see also -d)",
2405       "  p  Tokenizing and parsing (with v, displays parse stack)",
2406       "  s  Stack snapshots (with v, displays all stacks)",
2407       "  l  Context (loop) stack processing",
2408       "  t  Trace execution",
2409       "  o  Method and overloading resolution",
2410       "  c  String/numeric conversions",
2411       "  P  Print profiling info, preprocessor command for -P, source file input state",
2412       "  m  Memory allocation",
2413       "  f  Format processing",
2414       "  r  Regular expression parsing and execution",
2415       "  x  Syntax tree dump",
2416       "  u  Tainting checks",
2417       "  H  Hash dump -- usurps values()",
2418       "  X  Scratchpad allocation",
2419       "  D  Cleaning up",
2420       "  S  Thread synchronization",
2421       "  T  Tokenising",
2422       "  R  Include reference counts of dumped variables (eg when using -Ds)",
2423       "  J  Do not s,t,P-debug (Jump over) opcodes within package DB",
2424       "  v  Verbose: use in conjunction with other flags",
2425       "  C  Copy On Write",
2426       "  A  Consistency checks on internal structures",
2427       "  q  quiet - currently only suppresses the 'EXECUTING' message",
2428       NULL
2429     };
2430     int i = 0;
2431     if (isALPHA(**s)) {
2432         /* if adding extra options, remember to update DEBUG_MASK */
2433         static char debopts[] = "psltocPmfrxu HXDSTRJvCAq";
2434
2435         for (; isALNUM(**s); (*s)++) {
2436             char *d = strchr(debopts,**s);
2437             if (d)
2438                 i |= 1 << (d - debopts);
2439             else if (ckWARN_d(WARN_DEBUGGING))
2440                 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
2441                     "invalid option -D%c, use -D'' to see choices\n", **s);
2442         }
2443     }
2444     else if (isDIGIT(**s)) {
2445         i = atoi(*s);
2446         for (; isALNUM(**s); (*s)++) ;
2447     }
2448     else if (givehelp) {
2449       char **p = usage_msgd;
2450       while (*p) PerlIO_printf(PerlIO_stdout(), "%s\n", *p++);
2451     }
2452 #  ifdef EBCDIC
2453     if ((i & DEBUG_p_FLAG) && ckWARN_d(WARN_DEBUGGING))
2454         Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
2455                 "-Dp not implemented on this platform\n");
2456 #  endif
2457     return i;
2458 }
2459 #endif
2460
2461 /* This routine handles any switches that can be given during run */
2462
2463 char *
2464 Perl_moreswitches(pTHX_ char *s)
2465 {
2466     STRLEN numlen;
2467     UV rschar;
2468
2469     switch (*s) {
2470     case '0':
2471     {
2472          I32 flags = 0;
2473
2474          SvREFCNT_dec(PL_rs);
2475          if (s[1] == 'x' && s[2]) {
2476               char *e;
2477               U8 *tmps;
2478
2479               for (s += 2, e = s; *e; e++);
2480               numlen = e - s;
2481               flags = PERL_SCAN_SILENT_ILLDIGIT;
2482               rschar = (U32)grok_hex(s, &numlen, &flags, NULL);
2483               if (s + numlen < e) {
2484                    rschar = 0; /* Grandfather -0xFOO as -0 -xFOO. */
2485                    numlen = 0;
2486                    s--;
2487               }
2488               PL_rs = newSVpvn("", 0);
2489               SvGROW(PL_rs, (STRLEN)(UNISKIP(rschar) + 1));
2490               tmps = (U8*)SvPVX(PL_rs);
2491               uvchr_to_utf8(tmps, rschar);
2492               SvCUR_set(PL_rs, UNISKIP(rschar));
2493               SvUTF8_on(PL_rs);
2494          }
2495          else {
2496               numlen = 4;
2497               rschar = (U32)grok_oct(s, &numlen, &flags, NULL);
2498               if (rschar & ~((U8)~0))
2499                    PL_rs = &PL_sv_undef;
2500               else if (!rschar && numlen >= 2)
2501                    PL_rs = newSVpvn("", 0);
2502               else {
2503                    char ch = (char)rschar;
2504                    PL_rs = newSVpvn(&ch, 1);
2505               }
2506          }
2507          sv_setsv(get_sv("/", TRUE), PL_rs);
2508          return s + numlen;
2509     }
2510     case 'C':
2511         s++;
2512         PL_unicode = parse_unicode_opts(&s);
2513         return s;
2514     case 'F':
2515         PL_minus_F = TRUE;
2516         PL_splitstr = ++s;
2517         while (*s && !isSPACE(*s)) ++s;
2518         *s = '\0';
2519         PL_splitstr = savepv(PL_splitstr);
2520         return s;
2521     case 'a':
2522         PL_minus_a = TRUE;
2523         s++;
2524         return s;
2525     case 'c':
2526         PL_minus_c = TRUE;
2527         s++;
2528         return s;
2529     case 'd':
2530         forbid_setid("-d");
2531         s++;
2532
2533         /* -dt indicates to the debugger that threads will be used */
2534         if (*s == 't' && !isALNUM(s[1])) {
2535             ++s;
2536             my_setenv("PERL5DB_THREADED", "1");
2537         }
2538
2539         /* The following permits -d:Mod to accepts arguments following an =
2540            in the fashion that -MSome::Mod does. */
2541         if (*s == ':' || *s == '=') {
2542             char *start;
2543             SV *sv;
2544             sv = newSVpv("use Devel::", 0);
2545             start = ++s;
2546             /* We now allow -d:Module=Foo,Bar */
2547             while(isALNUM(*s) || *s==':') ++s;
2548             if (*s != '=')
2549                 sv_catpv(sv, start);
2550             else {
2551                 sv_catpvn(sv, start, s-start);
2552                 sv_catpv(sv, " split(/,/,q{");
2553                 sv_catpv(sv, ++s);
2554                 sv_catpv(sv, "})");
2555             }
2556             s += strlen(s);
2557             my_setenv("PERL5DB", SvPV(sv, PL_na));
2558         }
2559         if (!PL_perldb) {
2560             PL_perldb = PERLDB_ALL;
2561             init_debugger();
2562         }
2563         return s;
2564     case 'D':
2565     {
2566 #ifdef DEBUGGING
2567         forbid_setid("-D");
2568         s++;
2569         PL_debug = get_debug_opts(&s, 1) | DEBUG_TOP_FLAG;
2570 #else /* !DEBUGGING */
2571         if (ckWARN_d(WARN_DEBUGGING))
2572             Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
2573                    "Recompile perl with -DDEBUGGING to use -D switch (did you mean -d ?)\n");
2574         for (s++; isALNUM(*s); s++) ;
2575 #endif
2576         /*SUPPRESS 530*/
2577         return s;
2578     }
2579     case 'h':
2580         usage(PL_origargv[0]);
2581         my_exit(0);
2582     case 'i':
2583         if (PL_inplace)
2584             Safefree(PL_inplace);
2585 #if defined(__CYGWIN__) /* do backup extension automagically */
2586         if (*(s+1) == '\0') {
2587         PL_inplace = savepv(".bak");
2588         return s+1;
2589         }
2590 #endif /* __CYGWIN__ */
2591         PL_inplace = savepv(s+1);
2592         /*SUPPRESS 530*/
2593         for (s = PL_inplace; *s && !isSPACE(*s); s++) ;
2594         if (*s) {
2595             *s++ = '\0';
2596             if (*s == '-')      /* Additional switches on #! line. */
2597                 s++;
2598         }
2599         return s;
2600     case 'I':   /* -I handled both here and in parse_body() */
2601         forbid_setid("-I");
2602         ++s;
2603         while (*s && isSPACE(*s))
2604             ++s;
2605         if (*s) {
2606             char *e, *p;
2607             p = s;
2608             /* ignore trailing spaces (possibly followed by other switches) */
2609             do {
2610                 for (e = p; *e && !isSPACE(*e); e++) ;
2611                 p = e;
2612                 while (isSPACE(*p))
2613                     p++;
2614             } while (*p && *p != '-');
2615             e = savepvn(s, e-s);
2616             incpush(e, TRUE, TRUE, FALSE, FALSE);
2617             Safefree(e);
2618             s = p;
2619             if (*s == '-')
2620                 s++;
2621         }
2622         else
2623             Perl_croak(aTHX_ "No directory specified for -I");
2624         return s;
2625     case 'l':
2626         PL_minus_l = TRUE;
2627         s++;
2628         if (PL_ors_sv) {
2629             SvREFCNT_dec(PL_ors_sv);
2630             PL_ors_sv = Nullsv;
2631         }
2632         if (isDIGIT(*s)) {
2633             I32 flags = 0;
2634             PL_ors_sv = newSVpvn("\n",1);
2635             numlen = 3 + (*s == '0');
2636             *SvPVX(PL_ors_sv) = (char)grok_oct(s, &numlen, &flags, NULL);
2637             s += numlen;
2638         }
2639         else {
2640             if (RsPARA(PL_rs)) {
2641                 PL_ors_sv = newSVpvn("\n\n",2);
2642             }
2643             else {
2644                 PL_ors_sv = newSVsv(PL_rs);
2645             }
2646         }
2647         return s;
2648     case 'A':
2649         forbid_setid("-A");
2650         if (!PL_preambleav)
2651             PL_preambleav = newAV();
2652         if (*++s) {
2653             SV *sv = newSVpv("use assertions::activate split(/,/,q", 0);
2654             sv_catpvn(sv, "\0", 1);     /* Use NUL as q//-delimiter. */
2655             sv_catpv(sv,s);
2656             sv_catpvn(sv, "\0)", 2);
2657             s+=strlen(s);
2658             av_push(PL_preambleav, sv);
2659         }
2660         else
2661             av_push(PL_preambleav, newSVpvn("use assertions::activate",24));
2662         return s;
2663     case 'M':
2664         forbid_setid("-M");     /* XXX ? */
2665         /* FALL THROUGH */
2666     case 'm':
2667         forbid_setid("-m");     /* XXX ? */
2668         if (*++s) {
2669             char *start;
2670             SV *sv;
2671             char *use = "use ";
2672             /* -M-foo == 'no foo'       */
2673             if (*s == '-') { use = "no "; ++s; }
2674             sv = newSVpv(use,0);
2675             start = s;
2676             /* We allow -M'Module qw(Foo Bar)'  */
2677             while(isALNUM(*s) || *s==':') ++s;
2678             if (*s != '=') {
2679                 sv_catpv(sv, start);
2680                 if (*(start-1) == 'm') {
2681                     if (*s != '\0')
2682                         Perl_croak(aTHX_ "Can't use '%c' after -mname", *s);
2683                     sv_catpv( sv, " ()");
2684                 }
2685             } else {
2686                 if (s == start)
2687                     Perl_croak(aTHX_ "Module name required with -%c option",
2688                                s[-1]);
2689                 sv_catpvn(sv, start, s-start);
2690                 sv_catpv(sv, " split(/,/,q");
2691                 sv_catpvn(sv, "\0)", 1);        /* Use NUL as q//-delimiter. */
2692                 sv_catpv(sv, ++s);
2693                 sv_catpvn(sv,  "\0)", 2);
2694             }
2695             s += strlen(s);
2696             if (!PL_preambleav)
2697                 PL_preambleav = newAV();
2698             av_push(PL_preambleav, sv);
2699         }
2700         else
2701             Perl_croak(aTHX_ "Missing argument to -%c", *(s-1));
2702         return s;
2703     case 'n':
2704         PL_minus_n = TRUE;
2705         s++;
2706         return s;
2707     case 'p':
2708         PL_minus_p = TRUE;
2709         s++;
2710         return s;
2711     case 's':
2712         forbid_setid("-s");
2713         PL_doswitches = TRUE;
2714         s++;
2715         return s;
2716     case 't':
2717         if (!PL_tainting)
2718             TOO_LATE_FOR('t');
2719         s++;
2720         return s;
2721     case 'T':
2722         if (!PL_tainting)
2723             TOO_LATE_FOR('T');
2724         s++;
2725         return s;
2726     case 'u':
2727 #ifdef MACOS_TRADITIONAL
2728         Perl_croak(aTHX_ "Believe me, you don't want to use \"-u\" on a Macintosh");
2729 #endif
2730         PL_do_undump = TRUE;
2731         s++;
2732         return s;
2733     case 'U':
2734         PL_unsafe = TRUE;
2735         s++;
2736         return s;
2737     case 'v':
2738         if (!sv_derived_from(PL_patchlevel, "version"))
2739                 (void *)upg_version(PL_patchlevel);
2740 #if !defined(DGUX)
2741         PerlIO_printf(PerlIO_stdout(),
2742                 Perl_form(aTHX_ "\nThis is perl, v%"SVf" built for %s",
2743                     vstringify(PL_patchlevel),
2744                     ARCHNAME));
2745 #else /* DGUX */
2746 /* Adjust verbose output as in the perl that ships with the DG/UX OS from EMC */
2747         PerlIO_printf(PerlIO_stdout(),
2748                 Perl_form(aTHX_ "\nThis is perl, v%"SVf"\n",
2749                     vstringify(PL_patchlevel)));
2750         PerlIO_printf(PerlIO_stdout(),
2751                         Perl_form(aTHX_ "        built under %s at %s %s\n",
2752                                         OSNAME, __DATE__, __TIME__));
2753         PerlIO_printf(PerlIO_stdout(),
2754                         Perl_form(aTHX_ "        OS Specific Release: %s\n",
2755                                         OSVERS));
2756 #endif /* !DGUX */
2757
2758 #if defined(LOCAL_PATCH_COUNT)
2759         if (LOCAL_PATCH_COUNT > 0)
2760             PerlIO_printf(PerlIO_stdout(),
2761                           "\n(with %d registered patch%s, "
2762                           "see perl -V for more detail)",
2763                           (int)LOCAL_PATCH_COUNT,
2764                           (LOCAL_PATCH_COUNT!=1) ? "es" : "");
2765 #endif
2766
2767         PerlIO_printf(PerlIO_stdout(),
2768                       "\n\nCopyright 1987-2005, Larry Wall\n");
2769 #ifdef MACOS_TRADITIONAL
2770         PerlIO_printf(PerlIO_stdout(),
2771                       "\nMac OS port Copyright 1991-2002, Matthias Neeracher;\n"
2772                       "maintained by Chris Nandor\n");
2773 #endif
2774 #ifdef MSDOS
2775         PerlIO_printf(PerlIO_stdout(),
2776                       "\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
2777 #endif
2778 #ifdef DJGPP
2779         PerlIO_printf(PerlIO_stdout(),
2780                       "djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n"
2781                       "djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n");
2782 #endif
2783 #ifdef OS2
2784         PerlIO_printf(PerlIO_stdout(),
2785                       "\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
2786                       "Version 5 port Copyright (c) 1994-2002, Andreas Kaiser, Ilya Zakharevich\n");
2787 #endif
2788 #ifdef atarist
2789         PerlIO_printf(PerlIO_stdout(),
2790                       "atariST series port, ++jrb  bammi@cadence.com\n");
2791 #endif
2792 #ifdef __BEOS__
2793         PerlIO_printf(PerlIO_stdout(),
2794                       "BeOS port Copyright Tom Spindler, 1997-1999\n");
2795 #endif
2796 #ifdef MPE
2797         PerlIO_printf(PerlIO_stdout(),
2798                       "MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-2003\n");
2799 #endif
2800 #ifdef OEMVS
2801         PerlIO_printf(PerlIO_stdout(),
2802                       "MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
2803 #endif
2804 #ifdef __VOS__
2805         PerlIO_printf(PerlIO_stdout(),
2806                       "Stratus VOS port by Paul.Green@stratus.com, 1997-2002\n");
2807 #endif
2808 #ifdef __OPEN_VM
2809         PerlIO_printf(PerlIO_stdout(),
2810                       "VM/ESA port by Neale Ferguson, 1998-1999\n");
2811 #endif
2812 #ifdef POSIX_BC
2813         PerlIO_printf(PerlIO_stdout(),
2814                       "BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
2815 #endif
2816 #ifdef __MINT__
2817         PerlIO_printf(PerlIO_stdout(),
2818                       "MiNT port by Guido Flohr, 1997-1999\n");
2819 #endif
2820 #ifdef EPOC
2821         PerlIO_printf(PerlIO_stdout(),
2822                       "EPOC port by Olaf Flebbe, 1999-2002\n");
2823 #endif
2824 #ifdef UNDER_CE
2825         PerlIO_printf(PerlIO_stdout(),"WINCE port by Rainer Keuchel, 2001-2002\n");
2826         PerlIO_printf(PerlIO_stdout(),"Built on " __DATE__ " " __TIME__ "\n\n");
2827         wce_hitreturn();
2828 #endif
2829 #ifdef BINARY_BUILD_NOTICE
2830         BINARY_BUILD_NOTICE;
2831 #endif
2832         PerlIO_printf(PerlIO_stdout(),
2833                       "\n\
2834 Perl may be copied only under the terms of either the Artistic License or the\n\
2835 GNU General Public License, which may be found in the Perl 5 source kit.\n\n\
2836 Complete documentation for Perl, including FAQ lists, should be found on\n\
2837 this system using `man perl' or `perldoc perl'.  If you have access to the\n\
2838 Internet, point your browser at http://www.perl.org/, the Perl Home Page.\n\n");
2839         my_exit(0);
2840     case 'w':
2841         if (! (PL_dowarn & G_WARN_ALL_MASK))
2842             PL_dowarn |= G_WARN_ON;
2843         s++;
2844         return s;
2845     case 'W':
2846         PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
2847         if (!specialWARN(PL_compiling.cop_warnings))
2848             SvREFCNT_dec(PL_compiling.cop_warnings);
2849         PL_compiling.cop_warnings = pWARN_ALL ;
2850         s++;
2851         return s;
2852     case 'X':
2853         PL_dowarn = G_WARN_ALL_OFF;
2854         if (!specialWARN(PL_compiling.cop_warnings))
2855             SvREFCNT_dec(PL_compiling.cop_warnings);
2856         PL_compiling.cop_warnings = pWARN_NONE ;
2857         s++;
2858         return s;
2859     case '*':
2860     case ' ':
2861         if (s[1] == '-')        /* Additional switches on #! line. */
2862             return s+2;
2863         break;
2864     case '-':
2865     case 0:
2866 #if defined(WIN32) || !defined(PERL_STRICT_CR)
2867     case '\r':
2868 #endif
2869     case '\n':
2870     case '\t':
2871         break;
2872 #ifdef ALTERNATE_SHEBANG
2873     case 'S':                   /* OS/2 needs -S on "extproc" line. */
2874         break;
2875 #endif
2876     case 'P':
2877         if (PL_preprocess)
2878             return s+1;
2879         /* FALL THROUGH */
2880     default:
2881         Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s);
2882     }
2883     return Nullch;
2884 }
2885
2886 /* compliments of Tom Christiansen */
2887
2888 /* unexec() can be found in the Gnu emacs distribution */
2889 /* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
2890
2891 void
2892 Perl_my_unexec(pTHX)
2893 {
2894 #ifdef UNEXEC
2895     SV*    prog;
2896     SV*    file;
2897     int    status = 1;
2898     extern int etext;
2899
2900     prog = newSVpv(BIN_EXP, 0);
2901     sv_catpv(prog, "/perl");
2902     file = newSVpv(PL_origfilename, 0);
2903     sv_catpv(file, ".perldump");
2904
2905     unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
2906     /* unexec prints msg to stderr in case of failure */
2907     PerlProc_exit(status);
2908 #else
2909 #  ifdef VMS
2910 #    include <lib$routines.h>
2911      lib$signal(SS$_DEBUG);  /* ssdef.h #included from vmsish.h */
2912 #  else
2913     ABORT();            /* for use with undump */
2914 #  endif
2915 #endif
2916 }
2917
2918 /* initialize curinterp */
2919 STATIC void
2920 S_init_interp(pTHX)
2921 {
2922
2923 #ifdef MULTIPLICITY
2924 #  define PERLVAR(var,type)
2925 #  define PERLVARA(var,n,type)
2926 #  if defined(PERL_IMPLICIT_CONTEXT)
2927 #    if defined(USE_5005THREADS)
2928 #      define PERLVARI(var,type,init)           PERL_GET_INTERP->var = init;
2929 #      define PERLVARIC(var,type,init)  PERL_GET_INTERP->var = init;
2930 #    else /* !USE_5005THREADS */
2931 #      define PERLVARI(var,type,init)           aTHX->var = init;
2932 #      define PERLVARIC(var,type,init)  aTHX->var = init;
2933 #    endif /* USE_5005THREADS */
2934 #  else
2935 #    define PERLVARI(var,type,init)     PERL_GET_INTERP->var = init;
2936 #    define PERLVARIC(var,type,init)    PERL_GET_INTERP->var = init;
2937 #  endif
2938 #  include "intrpvar.h"
2939 #  ifndef USE_5005THREADS
2940 #    include "thrdvar.h"
2941 #  endif
2942 #  undef PERLVAR
2943 #  undef PERLVARA
2944 #  undef PERLVARI
2945 #  undef PERLVARIC
2946 #else
2947 #  define PERLVAR(var,type)
2948 #  define PERLVARA(var,n,type)
2949 #  define PERLVARI(var,type,init)       PL_##var = init;
2950 #  define PERLVARIC(var,type,init)      PL_##var = init;
2951 #  include "intrpvar.h"
2952 #  ifndef USE_5005THREADS
2953 #    include "thrdvar.h"
2954 #  endif
2955 #  undef PERLVAR
2956 #  undef PERLVARA
2957 #  undef PERLVARI
2958 #  undef PERLVARIC
2959 #endif
2960
2961 }
2962
2963 STATIC void
2964 S_init_main_stash(pTHX)
2965 {
2966     GV *gv;
2967
2968     PL_curstash = PL_defstash = newHV();
2969     PL_curstname = newSVpvn("main",4);
2970     gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
2971     SvREFCNT_dec(GvHV(gv));
2972     GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash);
2973     SvREADONLY_on(gv);
2974     HvNAME(PL_defstash) = savepvn("main", 4);
2975     PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
2976     GvMULTI_on(PL_incgv);
2977     PL_hintgv = gv_fetchpv("\010",TRUE, SVt_PV); /* ^H */
2978     GvMULTI_on(PL_hintgv);
2979     PL_defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
2980     PL_errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
2981     GvMULTI_on(PL_errgv);
2982     PL_replgv = gv_fetchpv("\022", TRUE, SVt_PV); /* ^R */
2983     GvMULTI_on(PL_replgv);
2984     (void)Perl_form(aTHX_ "%240s","");  /* Preallocate temp - for immediate signals. */
2985     sv_grow(ERRSV, 240);        /* Preallocate - for immediate signals. */
2986     sv_setpvn(ERRSV, "", 0);
2987     PL_curstash = PL_defstash;
2988     CopSTASH_set(&PL_compiling, PL_defstash);
2989     PL_debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
2990     PL_globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
2991     /* We must init $/ before switches are processed. */
2992     sv_setpvn(get_sv("/", TRUE), "\n", 1);
2993 }
2994
2995 /* PSz 18 Nov 03  fdscript now global but do not change prototype */
2996 STATIC void
2997 S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv)
2998 {
2999 #ifndef IAMSUID
3000     char *quote;
3001     char *code;
3002     char *cpp_discard_flag;
3003     char *perl;
3004 #endif
3005
3006     PL_fdscript = -1;
3007     PL_suidscript = -1;
3008
3009     if (PL_e_script) {
3010         PL_origfilename = savepvn("-e", 2);
3011     }
3012     else {
3013         /* if find_script() returns, it returns a malloc()-ed value */
3014         PL_origfilename = scriptname = find_script(scriptname, dosearch, NULL, 1);
3015
3016         if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
3017             char *s = scriptname + 8;
3018             PL_fdscript = atoi(s);
3019             while (isDIGIT(*s))
3020                 s++;
3021             if (*s) {
3022                 /* PSz 18 Feb 04
3023                  * Tell apart "normal" usage of fdscript, e.g.
3024                  * with bash on FreeBSD:
3025                  *   perl <( echo '#!perl -DA'; echo 'print "$0\n"')
3026                  * from usage in suidperl.
3027                  * Does any "normal" usage leave garbage after the number???
3028                  * Is it a mistake to use a similar /dev/fd/ construct for
3029                  * suidperl?
3030                  */
3031                 PL_suidscript = 1;
3032                 /* PSz 20 Feb 04
3033                  * Be supersafe and do some sanity-checks.
3034                  * Still, can we be sure we got the right thing?
3035                  */
3036                 if (*s != '/') {
3037                     Perl_croak(aTHX_ "Wrong syntax (suid) fd script name \"%s\"\n", s);
3038                 }
3039                 if (! *(s+1)) {
3040                     Perl_croak(aTHX_ "Missing (suid) fd script name\n");
3041                 }
3042                 scriptname = savepv(s + 1);
3043                 Safefree(PL_origfilename);
3044                 PL_origfilename = scriptname;
3045             }
3046         }
3047     }
3048
3049     CopFILE_free(PL_curcop);
3050     CopFILE_set(PL_curcop, PL_origfilename);
3051     if (*PL_origfilename == '-' && PL_origfilename[1] == '\0')
3052         scriptname = "";
3053     if (PL_fdscript >= 0) {
3054         PL_rsfp = PerlIO_fdopen(PL_fdscript,PERL_SCRIPT_MODE);
3055 #       if defined(HAS_FCNTL) && defined(F_SETFD)
3056             if (PL_rsfp)
3057                 /* ensure close-on-exec */
3058                 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);
3059 #       endif
3060     }
3061 #ifdef IAMSUID
3062     else {
3063         Perl_croak(aTHX_ "sperl needs fd script\n"
3064                    "You should not call sperl directly; do you need to "
3065                    "change a #! line\nfrom sperl to perl?\n");
3066
3067 /* PSz 11 Nov 03
3068  * Do not open (or do other fancy stuff) while setuid.
3069  * Perl does the open, and hands script to suidperl on a fd;
3070  * suidperl only does some checks, sets up UIDs and re-execs
3071  * perl with that fd as it has always done.
3072  */
3073     }
3074     if (PL_suidscript != 1) {
3075         Perl_croak(aTHX_ "suidperl needs (suid) fd script\n");
3076     }
3077 #else /* IAMSUID */
3078     else if (PL_preprocess) {
3079         char *cpp_cfg = CPPSTDIN;
3080         SV *cpp = newSVpvn("",0);
3081         SV *cmd = NEWSV(0,0);
3082
3083         if (cpp_cfg[0] == 0) /* PERL_MICRO? */
3084              Perl_croak(aTHX_ "Can't run with cpp -P with CPPSTDIN undefined");
3085         if (strEQ(cpp_cfg, "cppstdin"))
3086             Perl_sv_catpvf(aTHX_ cpp, "%s/", BIN_EXP);
3087         sv_catpv(cpp, cpp_cfg);
3088
3089 #       ifndef VMS
3090             sv_catpvn(sv, "-I", 2);
3091             sv_catpv(sv,PRIVLIB_EXP);
3092 #       endif
3093
3094         DEBUG_P(PerlIO_printf(Perl_debug_log,
3095                               "PL_preprocess: scriptname=\"%s\", cpp=\"%s\", sv=\"%s\", CPPMINUS=\"%s\"\n",
3096                               scriptname, SvPVX (cpp), SvPVX (sv), CPPMINUS));
3097
3098 #       if defined(MSDOS) || defined(WIN32) || defined(VMS)
3099             quote = "\"";
3100 #       else
3101             quote = "'";
3102 #       endif
3103
3104 #       ifdef VMS
3105             cpp_discard_flag = "";
3106 #       else
3107             cpp_discard_flag = "-C";
3108 #       endif
3109
3110 #       ifdef OS2
3111             perl = os2_execname(aTHX);
3112 #       else
3113             perl = PL_origargv[0];
3114 #       endif
3115
3116
3117         /* This strips off Perl comments which might interfere with
3118            the C pre-processor, including #!.  #line directives are
3119            deliberately stripped to avoid confusion with Perl's version
3120            of #line.  FWP played some golf with it so it will fit
3121            into VMS's 255 character buffer.
3122         */
3123         if( PL_doextract )
3124             code = "(1../^#!.*perl/i)|/^\\s*#(?!\\s*((ifn?|un)def|(el|end)?if|define|include|else|error|pragma)\\b)/||!($|=1)||print";
3125         else
3126             code = "/^\\s*#(?!\\s*((ifn?|un)def|(el|end)?if|define|include|else|error|pragma)\\b)/||!($|=1)||print";
3127
3128         Perl_sv_setpvf(aTHX_ cmd, "\
3129 %s -ne%s%s%s %s | %"SVf" %s %"SVf" %s",
3130                        perl, quote, code, quote, scriptname, cpp,
3131                        cpp_discard_flag, sv, CPPMINUS);
3132
3133         PL_doextract = FALSE;
3134
3135         DEBUG_P(PerlIO_printf(Perl_debug_log,
3136                               "PL_preprocess: cmd=\"%s\"\n",
3137                               SvPVX(cmd)));
3138
3139         PL_rsfp = PerlProc_popen(SvPVX(cmd), "r");
3140         SvREFCNT_dec(cmd);
3141         SvREFCNT_dec(cpp);
3142     }
3143     else if (!*scriptname) {
3144         forbid_setid("program input from stdin");
3145         PL_rsfp = PerlIO_stdin();
3146     }
3147     else {
3148         PL_rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
3149 #       if defined(HAS_FCNTL) && defined(F_SETFD)
3150             if (PL_rsfp)
3151                 /* ensure close-on-exec */
3152                 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);
3153 #       endif
3154     }
3155 #endif /* IAMSUID */
3156     if (!PL_rsfp) {
3157         /* PSz 16 Sep 03  Keep neat error message */
3158         Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
3159                 CopFILE(PL_curcop), Strerror(errno));
3160     }
3161 }
3162
3163 /* Mention
3164  * I_SYSSTATVFS HAS_FSTATVFS
3165  * I_SYSMOUNT
3166  * I_STATFS     HAS_FSTATFS     HAS_GETFSSTAT
3167  * I_MNTENT     HAS_GETMNTENT   HAS_HASMNTOPT
3168  * here so that metaconfig picks them up. */
3169
3170 #ifdef IAMSUID
3171 STATIC int
3172 S_fd_on_nosuid_fs(pTHX_ int fd)
3173 {
3174 /* PSz 27 Feb 04
3175  * We used to do this as "plain" user (after swapping UIDs with setreuid);
3176  * but is needed also on machines without setreuid.
3177  * Seems safe enough to run as root.
3178  */
3179     int check_okay = 0; /* able to do all the required sys/libcalls */
3180     int on_nosuid  = 0; /* the fd is on a nosuid fs */
3181     /* PSz 12 Nov 03
3182      * Need to check noexec also: nosuid might not be set, the average
3183      * sysadmin would say that nosuid is irrelevant once he sets noexec.
3184      */
3185     int on_noexec  = 0; /* the fd is on a noexec fs */
3186
3187 /*
3188  * Preferred order: fstatvfs(), fstatfs(), ustat()+getmnt(), getmntent().
3189  * fstatvfs() is UNIX98.
3190  * fstatfs() is 4.3 BSD.
3191  * ustat()+getmnt() is pre-4.3 BSD.
3192  * getmntent() is O(number-of-mounted-filesystems) and can hang on
3193  * an irrelevant filesystem while trying to reach the right one.
3194  */
3195
3196 #undef FD_ON_NOSUID_CHECK_OKAY  /* found the syscalls to do the check? */
3197
3198 #   if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
3199         defined(HAS_FSTATVFS)
3200 #   define FD_ON_NOSUID_CHECK_OKAY
3201     struct statvfs stfs;
3202
3203     check_okay = fstatvfs(fd, &stfs) == 0;
3204     on_nosuid  = check_okay && (stfs.f_flag  & ST_NOSUID);
3205 #ifdef ST_NOEXEC
3206     /* ST_NOEXEC certainly absent on AIX 5.1, and doesn't seem to be documented
3207        on platforms where it is present.  */
3208     on_noexec  = check_okay && (stfs.f_flag  & ST_NOEXEC);
3209 #endif
3210 #   endif /* fstatvfs */
3211
3212 #   if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
3213         defined(PERL_MOUNT_NOSUID)      && \
3214         defined(PERL_MOUNT_NOEXEC)      && \
3215         defined(HAS_FSTATFS)            && \
3216         defined(HAS_STRUCT_STATFS)      && \
3217         defined(HAS_STRUCT_STATFS_F_FLAGS)
3218 #   define FD_ON_NOSUID_CHECK_OKAY
3219     struct statfs  stfs;
3220
3221     check_okay = fstatfs(fd, &stfs)  == 0;
3222     on_nosuid  = check_okay && (stfs.f_flags & PERL_MOUNT_NOSUID);
3223     on_noexec  = check_okay && (stfs.f_flags & PERL_MOUNT_NOEXEC);
3224 #   endif /* fstatfs */
3225
3226 #   if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
3227         defined(PERL_MOUNT_NOSUID)      && \
3228         defined(PERL_MOUNT_NOEXEC)      && \
3229         defined(HAS_FSTAT)              && \
3230         defined(HAS_USTAT)              && \
3231         defined(HAS_GETMNT)             && \
3232         defined(HAS_STRUCT_FS_DATA)     && \
3233         defined(NOSTAT_ONE)
3234 #   define FD_ON_NOSUID_CHECK_OKAY
3235     Stat_t fdst;
3236
3237     if (fstat(fd, &fdst) == 0) {
3238         struct ustat us;
3239         if (ustat(fdst.st_dev, &us) == 0) {
3240             struct fs_data fsd;
3241             /* NOSTAT_ONE here because we're not examining fields which
3242              * vary between that case and STAT_ONE. */
3243             if (getmnt((int*)0, &fsd, (int)0, NOSTAT_ONE, us.f_fname) == 0) {
3244                 size_t cmplen = sizeof(us.f_fname);
3245                 if (sizeof(fsd.fd_req.path) < cmplen)
3246                     cmplen = sizeof(fsd.fd_req.path);
3247                 if (strnEQ(fsd.fd_req.path, us.f_fname, cmplen) &&
3248                     fdst.st_dev == fsd.fd_req.dev) {
3249                         check_okay = 1;
3250                         on_nosuid = fsd.fd_req.flags & PERL_MOUNT_NOSUID;
3251                         on_noexec = fsd.fd_req.flags & PERL_MOUNT_NOEXEC;
3252                     }
3253                 }
3254             }
3255         }
3256     }
3257 #   endif /* fstat+ustat+getmnt */
3258
3259 #   if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
3260         defined(HAS_GETMNTENT)          && \
3261         defined(HAS_HASMNTOPT)          && \
3262         defined(MNTOPT_NOSUID)          && \
3263         defined(MNTOPT_NOEXEC)
3264 #   define FD_ON_NOSUID_CHECK_OKAY
3265     FILE                *mtab = fopen("/etc/mtab", "r");
3266     struct mntent       *entry;
3267     Stat_t              stb, fsb;
3268
3269     if (mtab && (fstat(fd, &stb) == 0)) {
3270         while (entry = getmntent(mtab)) {
3271             if (stat(entry->mnt_dir, &fsb) == 0
3272                 && fsb.st_dev == stb.st_dev)
3273             {
3274                 /* found the filesystem */
3275                 check_okay = 1;
3276                 if (hasmntopt(entry, MNTOPT_NOSUID))
3277                     on_nosuid = 1;
3278                 if (hasmntopt(entry, MNTOPT_NOEXEC))
3279                     on_noexec = 1;
3280                 break;
3281             } /* A single fs may well fail its stat(). */
3282         }
3283     }
3284     if (mtab)
3285         fclose(mtab);
3286 #   endif /* getmntent+hasmntopt */
3287
3288     if (!check_okay)
3289         Perl_croak(aTHX_ "Can't check filesystem of script \"%s\" for nosuid/noexec", PL_origfilename);
3290     if (on_nosuid)
3291         Perl_croak(aTHX_ "Setuid script \"%s\" on nosuid filesystem", PL_origfilename);
3292     if (on_noexec)
3293         Perl_croak(aTHX_ "Setuid script \"%s\" on noexec filesystem", PL_origfilename);
3294     return ((!check_okay) || on_nosuid || on_noexec);
3295 }
3296 #endif /* IAMSUID */
3297
3298 STATIC void
3299 S_validate_suid(pTHX_ char *validarg, char *scriptname)
3300 {
3301 #ifdef IAMSUID
3302     /* int which; */
3303 #endif /* IAMSUID */
3304
3305     /* do we need to emulate setuid on scripts? */
3306
3307     /* This code is for those BSD systems that have setuid #! scripts disabled
3308      * in the kernel because of a security problem.  Merely defining DOSUID
3309      * in perl will not fix that problem, but if you have disabled setuid
3310      * scripts in the kernel, this will attempt to emulate setuid and setgid
3311      * on scripts that have those now-otherwise-useless bits set.  The setuid
3312      * root version must be called suidperl or sperlN.NNN.  If regular perl
3313      * discovers that it has opened a setuid script, it calls suidperl with
3314      * the same argv that it had.  If suidperl finds that the script it has
3315      * just opened is NOT setuid root, it sets the effective uid back to the
3316      * uid.  We don't just make perl setuid root because that loses the
3317      * effective uid we had before invoking perl, if it was different from the
3318      * uid.
3319      * PSz 27 Feb 04
3320      * Description/comments above do not match current workings:
3321      *   suidperl must be hardlinked to sperlN.NNN (that is what we exec);
3322      *   suidperl called with script open and name changed to /dev/fd/N/X;
3323      *   suidperl croaks if script is not setuid;
3324      *   making perl setuid would be a huge security risk (and yes, that
3325      *     would lose any euid we might have had).
3326      *
3327      * DOSUID must be defined in both perl and suidperl, and IAMSUID must
3328      * be defined in suidperl only.  suidperl must be setuid root.  The
3329      * Configure script will set this up for you if you want it.
3330      */
3331
3332 #ifdef DOSUID
3333     char *s, *s2;
3334
3335     if (PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf) < 0)  /* normal stat is insecure */
3336         Perl_croak(aTHX_ "Can't stat script \"%s\"",PL_origfilename);
3337     if (PL_statbuf.st_mode & (S_ISUID|S_ISGID)) {
3338         I32 len;
3339         STRLEN n_a;
3340
3341 #ifdef IAMSUID
3342         if (PL_fdscript < 0 || PL_suidscript != 1)
3343             Perl_croak(aTHX_ "Need (suid) fdscript in suidperl\n");     /* We already checked this */
3344         /* PSz 11 Nov 03
3345          * Since the script is opened by perl, not suidperl, some of these
3346          * checks are superfluous. Leaving them in probably does not lower
3347          * security(?!).
3348          */
3349         /* PSz 27 Feb 04
3350          * Do checks even for systems with no HAS_SETREUID.
3351          * We used to swap, then re-swap UIDs with
3352 #ifdef HAS_SETREUID
3353             if (setreuid(PL_euid,PL_uid) < 0
3354                 || PerlProc_getuid() != PL_euid || PerlProc_geteuid() != PL_uid)
3355                 Perl_croak(aTHX_ "Can't swap uid and euid");
3356 #endif
3357 #ifdef HAS_SETREUID
3358             if (setreuid(PL_uid,PL_euid) < 0
3359                 || PerlProc_getuid() != PL_uid || PerlProc_geteuid() != PL_euid)
3360                 Perl_croak(aTHX_ "Can't reswap uid and euid");
3361 #endif
3362          */
3363
3364         /* On this access check to make sure the directories are readable,
3365          * there is actually a small window that the user could use to make
3366          * filename point to an accessible directory.  So there is a faint
3367          * chance that someone could execute a setuid script down in a
3368          * non-accessible directory.  I don't know what to do about that.
3369          * But I don't think it's too important.  The manual lies when
3370          * it says access() is useful in setuid programs.
3371          *
3372          * So, access() is pretty useless... but not harmful... do anyway.
3373          */
3374         if (PerlLIO_access(CopFILE(PL_curcop),1)) { /*double check*/
3375             Perl_croak(aTHX_ "Can't access() script\n");
3376         }
3377
3378         /* If we can swap euid and uid, then we can determine access rights
3379          * with a simple stat of the file, and then compare device and
3380          * inode to make sure we did stat() on the same file we opened.
3381          * Then we just have to make sure he or she can execute it.
3382          *
3383          * PSz 24 Feb 04
3384          * As the script is opened by perl, not suidperl, we do not need to
3385          * care much about access rights.
3386          *
3387          * The 'script changed' check is needed, or we can get lied to
3388          * about $0 with e.g.
3389          *  suidperl /dev/fd/4//bin/x 4<setuidscript
3390          * Without HAS_SETREUID, is it safe to stat() as root?
3391          *
3392          * Are there any operating systems that pass /dev/fd/xxx for setuid
3393          * scripts, as suggested/described in perlsec(1)? Surely they do not
3394          * pass the script name as we do, so the "script changed" test would
3395          * fail for them... but we never get here with
3396          * SETUID_SCRIPTS_ARE_SECURE_NOW defined.
3397          *
3398          * This is one place where we must "lie" about return status: not
3399          * say if the stat() failed. We are doing this as root, and could
3400          * be tricked into reporting existence or not of files that the
3401          * "plain" user cannot even see.
3402          */
3403         {
3404             Stat_t tmpstatbuf;
3405             if (PerlLIO_stat(CopFILE(PL_curcop),&tmpstatbuf) < 0 ||
3406                 tmpstatbuf.st_dev != PL_statbuf.st_dev ||
3407                 tmpstatbuf.st_ino != PL_statbuf.st_ino) {
3408                 Perl_croak(aTHX_ "Setuid script changed\n");
3409             }
3410
3411         }
3412         if (!cando(S_IXUSR,FALSE,&PL_statbuf))          /* can real uid exec? */
3413             Perl_croak(aTHX_ "Real UID cannot exec script\n");
3414
3415         /* PSz 27 Feb 04
3416          * We used to do this check as the "plain" user (after swapping
3417          * UIDs). But the check for nosuid and noexec filesystem is needed,
3418          * and should be done even without HAS_SETREUID. (Maybe those
3419          * operating systems do not have such mount options anyway...)
3420          * Seems safe enough to do as root.
3421          */
3422 #if !defined(NO_NOSUID_CHECK)
3423         if (fd_on_nosuid_fs(PerlIO_fileno(PL_rsfp))) {
3424             Perl_croak(aTHX_ "Setuid script on nosuid or noexec filesystem\n");
3425         }
3426 #endif
3427 #endif /* IAMSUID */
3428
3429         if (!S_ISREG(PL_statbuf.st_mode)) {
3430             Perl_croak(aTHX_ "Setuid script not plain file\n");
3431         }
3432         if (PL_statbuf.st_mode & S_IWOTH)
3433             Perl_croak(aTHX_ "Setuid/gid script is writable by world");
3434         PL_doswitches = FALSE;          /* -s is insecure in suid */
3435         /* PSz 13 Nov 03  But -s was caught elsewhere ... so unsetting it here is useless(?!) */
3436         CopLINE_inc(PL_curcop);
3437         if (sv_gets(PL_linestr, PL_rsfp, 0) == Nullch ||
3438           strnNE(SvPV(PL_linestr,n_a),"#!",2) ) /* required even on Sys V */
3439             Perl_croak(aTHX_ "No #! line");
3440         s = SvPV(PL_linestr,n_a)+2;
3441         /* PSz 27 Feb 04 */
3442         /* Sanity check on line length */
3443         if (strlen(s) < 1 || strlen(s) > 4000)
3444             Perl_croak(aTHX_ "Very long #! line");
3445         /* Allow more than a single space after #! */
3446         while (isSPACE(*s)) s++;
3447         /* Sanity check on buffer end */
3448         while ((*s) && !isSPACE(*s)) s++;
3449         for (s2 = s;  (s2 > SvPV(PL_linestr,n_a)+2 &&
3450                        (isDIGIT(s2[-1]) || s2[-1] == '.' || s2[-1] == '_'
3451                         || s2[-1] == '-'));  s2--) ;
3452         /* Sanity check on buffer start */
3453         if ( (s2-4 < SvPV(PL_linestr,n_a)+2 || strnNE(s2-4,"perl",4)) &&
3454               (s-9 < SvPV(PL_linestr,n_a)+2 || strnNE(s-9,"perl",4)) )
3455             Perl_croak(aTHX_ "Not a perl script");
3456         while (*s == ' ' || *s == '\t') s++;
3457         /*
3458          * #! arg must be what we saw above.  They can invoke it by
3459          * mentioning suidperl explicitly, but they may not add any strange
3460          * arguments beyond what #! says if they do invoke suidperl that way.
3461          */
3462         /*
3463          * The way validarg was set up, we rely on the kernel to start
3464          * scripts with argv[1] set to contain all #! line switches (the
3465          * whole line).
3466          */
3467         /*
3468          * Check that we got all the arguments listed in the #! line (not
3469          * just that there are no extraneous arguments). Might not matter
3470          * much, as switches from #! line seem to be acted upon (also), and
3471          * so may be checked and trapped in perl. But, security checks must
3472          * be done in suidperl and not deferred to perl. Note that suidperl
3473          * does not get around to parsing (and checking) the switches on
3474          * the #! line (but execs perl sooner).
3475          * Allow (require) a trailing newline (which may be of two
3476          * characters on some architectures?) (but no other trailing
3477          * whitespace).
3478          */
3479         len = strlen(validarg);
3480         if (strEQ(validarg," PHOOEY ") ||
3481             strnNE(s,validarg,len) || !isSPACE(s[len]) ||
3482             !(strlen(s) == len+1 || (strlen(s) == len+2 && isSPACE(s[len+1]))))
3483             Perl_croak(aTHX_ "Args must match #! line");
3484
3485 #ifndef IAMSUID
3486         if (PL_fdscript < 0 &&
3487             PL_euid != PL_uid && (PL_statbuf.st_mode & S_ISUID) &&
3488             PL_euid == PL_statbuf.st_uid)
3489             if (!PL_do_undump)
3490                 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
3491 FIX YOUR KERNEL, OR PUT A C WRAPPER AROUND THIS SCRIPT!\n");
3492 #endif /* IAMSUID */
3493
3494         if (PL_fdscript < 0 &&
3495             PL_euid) {  /* oops, we're not the setuid root perl */
3496             /* PSz 18 Feb 04
3497              * When root runs a setuid script, we do not go through the same
3498              * steps of execing sperl and then perl with fd scripts, but
3499              * simply set up UIDs within the same perl invocation; so do
3500              * not have the same checks (on options, whatever) that we have
3501              * for plain users. No problem really: would have to be a script
3502              * that does not actually work for plain users; and if root is
3503              * foolish and can be persuaded to run such an unsafe script, he
3504              * might run also non-setuid ones, and deserves what he gets.
3505              *
3506              * Or, we might drop the PL_euid check above (and rely just on
3507              * PL_fdscript to avoid loops), and do the execs
3508              * even for root.
3509              */
3510 #ifndef IAMSUID
3511             int which;
3512             /* PSz 11 Nov 03
3513              * Pass fd script to suidperl.
3514              * Exec suidperl, substituting fd script for scriptname.
3515              * Pass script name as "subdir" of fd, which perl will grok;
3516              * in fact will use that to distinguish this from "normal"
3517              * usage, see comments above.
3518              */
3519             PerlIO_rewind(PL_rsfp);
3520             PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0);  /* just in case rewind didn't */
3521             /* PSz 27 Feb 04  Sanity checks on scriptname */
3522             if ((!scriptname) || (!*scriptname) ) {
3523                 Perl_croak(aTHX_ "No setuid script name\n");
3524             }
3525             if (*scriptname == '-') {
3526                 Perl_croak(aTHX_ "Setuid script name may not begin with dash\n");
3527                 /* Or we might confuse it with an option when replacing
3528                  * name in argument list, below (though we do pointer, not
3529                  * string, comparisons).
3530                  */
3531             }
3532             for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ;
3533             if (!PL_origargv[which]) {
3534                 Perl_croak(aTHX_ "Can't change argv to have fd script\n");
3535             }
3536             PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s",
3537                                           PerlIO_fileno(PL_rsfp), PL_origargv[which]));
3538 #if defined(HAS_FCNTL) && defined(F_SETFD)
3539             fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0);    /* ensure no close-on-exec */
3540 #endif
3541             PERL_FPU_PRE_EXEC
3542             PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT, BIN_EXP,
3543                                      (int)PERL_REVISION, (int)PERL_VERSION,
3544                                      (int)PERL_SUBVERSION), PL_origargv);
3545             PERL_FPU_POST_EXEC
3546 #endif /* IAMSUID */
3547             Perl_croak(aTHX_ "Can't do setuid (cannot exec sperl)\n");
3548         }
3549
3550         if (PL_statbuf.st_mode & S_ISGID && PL_statbuf.st_gid != PL_egid) {
3551 /* PSz 26 Feb 04
3552  * This seems back to front: we try HAS_SETEGID first; if not available
3553  * then try HAS_SETREGID; as a last chance we try HAS_SETRESGID. May be OK
3554  * in the sense that we only want to set EGID; but are there any machines
3555  * with either of the latter, but not the former? Same with UID, later.
3556  */
3557 #ifdef HAS_SETEGID
3558             (void)setegid(PL_statbuf.st_gid);
3559 #else
3560 #ifdef HAS_SETREGID
3561            (void)setregid((Gid_t)-1,PL_statbuf.st_gid);
3562 #else
3563 #ifdef HAS_SETRESGID
3564            (void)setresgid((Gid_t)-1,PL_statbuf.st_gid,(Gid_t)-1);
3565 #else
3566             PerlProc_setgid(PL_statbuf.st_gid);
3567 #endif
3568 #endif
3569 #endif
3570             if (PerlProc_getegid() != PL_statbuf.st_gid)
3571                 Perl_croak(aTHX_ "Can't do setegid!\n");
3572         }
3573         if (PL_statbuf.st_mode & S_ISUID) {
3574             if (PL_statbuf.st_uid != PL_euid)
3575 #ifdef HAS_SETEUID
3576                 (void)seteuid(PL_statbuf.st_uid);       /* all that for this */
3577 #else
3578 #ifdef HAS_SETREUID
3579                 (void)setreuid((Uid_t)-1,PL_statbuf.st_uid);
3580 #else
3581 #ifdef HAS_SETRESUID
3582                 (void)setresuid((Uid_t)-1,PL_statbuf.st_uid,(Uid_t)-1);
3583 #else
3584                 PerlProc_setuid(PL_statbuf.st_uid);
3585 #endif
3586 #endif
3587 #endif
3588             if (PerlProc_geteuid() != PL_statbuf.st_uid)
3589                 Perl_croak(aTHX_ "Can't do seteuid!\n");
3590         }
3591         else if (PL_uid) {                      /* oops, mustn't run as root */
3592 #ifdef HAS_SETEUID
3593           (void)seteuid((Uid_t)PL_uid);
3594 #else
3595 #ifdef HAS_SETREUID
3596           (void)setreuid((Uid_t)-1,(Uid_t)PL_uid);
3597 #else
3598 #ifdef HAS_SETRESUID
3599           (void)setresuid((Uid_t)-1,(Uid_t)PL_uid,(Uid_t)-1);
3600 #else
3601           PerlProc_setuid((Uid_t)PL_uid);
3602 #endif
3603 #endif
3604 #endif
3605             if (PerlProc_geteuid() != PL_uid)
3606                 Perl_croak(aTHX_ "Can't do seteuid!\n");
3607         }
3608         init_ids();
3609         if (!cando(S_IXUSR,TRUE,&PL_statbuf))
3610             Perl_croak(aTHX_ "Effective UID cannot exec script\n");     /* they can't do this */
3611     }
3612 #ifdef IAMSUID
3613     else if (PL_preprocess)     /* PSz 13 Nov 03  Caught elsewhere, useless(?!) here */
3614         Perl_croak(aTHX_ "-P not allowed for setuid/setgid script\n");
3615     else if (PL_fdscript < 0 || PL_suidscript != 1)
3616         /* PSz 13 Nov 03  Caught elsewhere, useless(?!) here */
3617         Perl_croak(aTHX_ "(suid) fdscript needed in suidperl\n");
3618     else {
3619 /* PSz 16 Sep 03  Keep neat error message */
3620         Perl_croak(aTHX_ "Script is not setuid/setgid in suidperl\n");
3621     }
3622
3623     /* We absolutely must clear out any saved ids here, so we */
3624     /* exec the real perl, substituting fd script for scriptname. */
3625     /* (We pass script name as "subdir" of fd, which perl will grok.) */
3626     /*
3627      * It might be thought that using setresgid and/or setresuid (changed to
3628      * set the saved IDs) above might obviate the need to exec, and we could
3629      * go on to "do the perl thing".
3630      *
3631      * Is there such a thing as "saved GID", and is that set for setuid (but
3632      * not setgid) execution like suidperl? Without exec, it would not be
3633      * cleared for setuid (but not setgid) scripts (or might need a dummy
3634      * setresgid).
3635      *
3636      * We need suidperl to do the exact same argument checking that perl
3637      * does. Thus it cannot be very small; while it could be significantly
3638      * smaller, it is safer (simpler?) to make it essentially the same
3639      * binary as perl (but they are not identical). - Maybe could defer that
3640      * check to the invoked perl, and suidperl be a tiny wrapper instead;
3641      * but prefer to do thorough checks in suidperl itself. Such deferral
3642      * would make suidperl security rely on perl, a design no-no.
3643      *
3644      * Setuid things should be short and simple, thus easy to understand and
3645      * verify. They should do their "own thing", without influence by
3646      * attackers. It may help if their internal execution flow is fixed,
3647      * regardless of platform: it may be best to exec anyway.
3648      *
3649      * Suidperl should at least be conceptually simple: a wrapper only,
3650      * never to do any real perl. Maybe we should put
3651      * #ifdef IAMSUID
3652      *         Perl_croak(aTHX_ "Suidperl should never do real perl\n");
3653      * #endif
3654      * into the perly bits.
3655      */
3656     PerlIO_rewind(PL_rsfp);
3657     PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0);  /* just in case rewind didn't */
3658     /* PSz 11 Nov 03
3659      * Keep original arguments: suidperl already has fd script.
3660      */
3661 /*  for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ;  */
3662 /*  if (!PL_origargv[which]) {                                          */
3663 /*      errno = EPERM;                                                  */
3664 /*      Perl_croak(aTHX_ "Permission denied\n");                        */
3665 /*  }                                                                   */
3666 /*  PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s",        */
3667 /*                                PerlIO_fileno(PL_rsfp), PL_origargv[which])); */
3668 #if defined(HAS_FCNTL) && defined(F_SETFD)
3669     fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0);    /* ensure no close-on-exec */
3670 #endif
3671     PERL_FPU_PRE_EXEC
3672     PerlProc_execv(Perl_form(aTHX_ "%s/perl"PERL_FS_VER_FMT, BIN_EXP,
3673                              (int)PERL_REVISION, (int)PERL_VERSION,
3674                              (int)PERL_SUBVERSION), PL_origargv);/* try again */
3675     PERL_FPU_POST_EXEC
3676     Perl_croak(aTHX_ "Can't do setuid (suidperl cannot exec perl)\n");
3677 #endif /* IAMSUID */
3678 #else /* !DOSUID */
3679     if (PL_euid != PL_uid || PL_egid != PL_gid) {       /* (suidperl doesn't exist, in fact) */
3680 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
3681         PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf);      /* may be either wrapped or real suid */
3682         if ((PL_euid != PL_uid && PL_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
3683             ||
3684             (PL_egid != PL_gid && PL_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
3685            )
3686             if (!PL_do_undump)
3687                 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
3688 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
3689 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
3690         /* not set-id, must be wrapped */
3691     }
3692 #endif /* DOSUID */
3693 }
3694
3695 STATIC void
3696 S_find_beginning(pTHX)
3697 {
3698     register char *s, *s2;
3699 #ifdef MACOS_TRADITIONAL
3700     int maclines = 0;
3701 #endif
3702
3703     /* skip forward in input to the real script? */
3704
3705     forbid_setid("-x");
3706 #ifdef MACOS_TRADITIONAL
3707     /* Since the Mac OS does not honor #! arguments for us, we do it ourselves */
3708
3709     while (PL_doextract || gMacPerl_AlwaysExtract) {
3710         if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
3711             if (!gMacPerl_AlwaysExtract)
3712                 Perl_croak(aTHX_ "No Perl script found in input\n");
3713
3714             if (PL_doextract)                   /* require explicit override ? */
3715                 if (!OverrideExtract(PL_origfilename))
3716                     Perl_croak(aTHX_ "User aborted script\n");
3717                 else
3718                     PL_doextract = FALSE;
3719
3720             /* Pater peccavi, file does not have #! */
3721             PerlIO_rewind(PL_rsfp);
3722
3723             break;
3724         }
3725 #else
3726     while (PL_doextract) {
3727         if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch)
3728             Perl_croak(aTHX_ "No Perl script found in input\n");
3729 #endif
3730         s2 = s;
3731         if (*s == '#' && s[1] == '!' && ((s = instr(s,"perl")) || (s = instr(s2,"PERL")))) {
3732             PerlIO_ungetc(PL_rsfp, '\n');               /* to keep line count right */
3733             PL_doextract = FALSE;
3734             while (*s && !(isSPACE (*s) || *s == '#')) s++;
3735             s2 = s;
3736             while (*s == ' ' || *s == '\t') s++;
3737             if (*s++ == '-') {
3738                 while (isDIGIT(s2[-1]) || s2[-1] == '-' || s2[-1] == '.'
3739                        || s2[-1] == '_') s2--;
3740                 if (strnEQ(s2-4,"perl",4))
3741                     /*SUPPRESS 530*/
3742                     while ((s = moreswitches(s)))
3743                         ;
3744             }
3745 #ifdef MACOS_TRADITIONAL
3746             /* We are always searching for the #!perl line in MacPerl,
3747              * so if we find it, still keep the line count correct
3748              * by counting lines we already skipped over
3749              */
3750             for (; maclines > 0 ; maclines--)
3751                 PerlIO_ungetc(PL_rsfp, '\n');
3752
3753             break;
3754
3755         /* gMacPerl_AlwaysExtract is false in MPW tool */
3756         } else if (gMacPerl_AlwaysExtract) {
3757             ++maclines;
3758 #endif
3759         }
3760     }
3761 }
3762
3763
3764 STATIC void
3765 S_init_ids(pTHX)
3766 {
3767     PL_uid = PerlProc_getuid();
3768     PL_euid = PerlProc_geteuid();
3769     PL_gid = PerlProc_getgid();
3770     PL_egid = PerlProc_getegid();
3771 #ifdef VMS
3772     PL_uid |= PL_gid << 16;
3773     PL_euid |= PL_egid << 16;
3774 #endif
3775     /* Should not happen: */
3776     CHECK_MALLOC_TAINT(PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
3777     PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
3778     /* BUG */
3779     /* PSz 27 Feb 04
3780      * Should go by suidscript, not uid!=euid: why disallow
3781      * system("ls") in scripts run from setuid things?
3782      * Or, is this run before we check arguments and set suidscript?
3783      * What about SETUID_SCRIPTS_ARE_SECURE_NOW: could we use fdscript then?
3784      * (We never have suidscript, can we be sure to have fdscript?)
3785      * Or must then go by UID checks? See comments in forbid_setid also.
3786      */
3787 }
3788
3789 /* This is used very early in the lifetime of the program,
3790  * before even the options are parsed, so PL_tainting has
3791  * not been initialized properly.  */
3792 bool
3793 Perl_doing_taint(int argc, char *argv[], char *envp[])
3794 {
3795 #ifndef PERL_IMPLICIT_SYS
3796     /* If we have PERL_IMPLICIT_SYS we can't call getuid() et alia
3797      * before we have an interpreter-- and the whole point of this
3798      * function is to be called at such an early stage.  If you are on
3799      * a system with PERL_IMPLICIT_SYS but you do have a concept of
3800      * "tainted because running with altered effective ids', you'll
3801      * have to add your own checks somewhere in here.  The two most
3802      * known samples of 'implicitness' are Win32 and NetWare, neither
3803      * of which has much of concept of 'uids'. */
3804     int uid  = PerlProc_getuid();
3805     int euid = PerlProc_geteuid();
3806     int gid  = PerlProc_getgid();
3807     int egid = PerlProc_getegid();
3808
3809 #ifdef VMS
3810     uid  |=  gid << 16;
3811     euid |= egid << 16;
3812 #endif
3813     if (uid && (euid != uid || egid != gid))
3814         return 1;
3815 #endif /* !PERL_IMPLICIT_SYS */
3816     /* This is a really primitive check; environment gets ignored only
3817      * if -T are the first chars together; otherwise one gets
3818      *  "Too late" message. */
3819     if ( argc > 1 && argv[1][0] == '-'
3820          && (argv[1][1] == 't' || argv[1][1] == 'T') )
3821         return 1;
3822     return 0;
3823 }
3824
3825 STATIC void
3826 S_forbid_setid(pTHX_ char *s)
3827 {
3828 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
3829     if (PL_euid != PL_uid)
3830         Perl_croak(aTHX_ "No %s allowed while running setuid", s);
3831     if (PL_egid != PL_gid)
3832         Perl_croak(aTHX_ "No %s allowed while running setgid", s);
3833 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
3834     /* PSz 29 Feb 04
3835      * Checks for UID/GID above "wrong": why disallow
3836      *   perl -e 'print "Hello\n"'
3837      * from within setuid things?? Simply drop them: replaced by
3838      * fdscript/suidscript and #ifdef IAMSUID checks below.
3839      *
3840      * This may be too late for command-line switches. Will catch those on
3841      * the #! line, after finding the script name and setting up
3842      * fdscript/suidscript. Note that suidperl does not get around to
3843      * parsing (and checking) the switches on the #! line, but checks that
3844      * the two sets are identical.
3845      *
3846      * With SETUID_SCRIPTS_ARE_SECURE_NOW, could we use fdscript, also or
3847      * instead, or would that be "too late"? (We never have suidscript, can
3848      * we be sure to have fdscript?)
3849      *
3850      * Catch things with suidscript (in descendant of suidperl), even with
3851      * right UID/GID. Was already checked in suidperl, with #ifdef IAMSUID,
3852      * below; but I am paranoid.
3853      *
3854      * Also see comments about root running a setuid script, elsewhere.
3855      */
3856     if (PL_suidscript >= 0)
3857         Perl_croak(aTHX_ "No %s allowed with (suid) fdscript", s);
3858 #ifdef IAMSUID
3859     /* PSz 11 Nov 03  Catch it in suidperl, always! */
3860     Perl_croak(aTHX_ "No %s allowed in suidperl", s);
3861 #endif /* IAMSUID */
3862 }
3863
3864 void
3865 Perl_init_debugger(pTHX)
3866 {
3867     HV *ostash = PL_curstash;
3868
3869     PL_curstash = PL_debstash;
3870     PL_dbargs = GvAV(gv_AVadd((gv_fetchpv("DB::args", GV_ADDMULTI, SVt_PVAV))));
3871     AvREAL_off(PL_dbargs);
3872     PL_DBgv = gv_fetchpv("DB::DB", GV_ADDMULTI, SVt_PVGV);
3873     PL_DBline = gv_fetchpv("DB::dbline", GV_ADDMULTI, SVt_PVAV);
3874     PL_DBsub = gv_HVadd(gv_fetchpv("DB::sub", GV_ADDMULTI, SVt_PVHV));
3875     sv_upgrade(GvSV(PL_DBsub), SVt_IV); /* IVX accessed if PERLDB_SUB_NN */
3876     PL_DBsingle = GvSV((gv_fetchpv("DB::single", GV_ADDMULTI, SVt_PV)));
3877     sv_setiv(PL_DBsingle, 0);
3878     PL_DBtrace = GvSV((gv_fetchpv("DB::trace", GV_ADDMULTI, SVt_PV)));
3879     sv_setiv(PL_DBtrace, 0);
3880     PL_DBsignal = GvSV((gv_fetchpv("DB::signal", GV_ADDMULTI, SVt_PV)));
3881     sv_setiv(PL_DBsignal, 0);
3882     PL_DBassertion = GvSV((gv_fetchpv("DB::assertion", GV_ADDMULTI, SVt_PV)));
3883     sv_setiv(PL_DBassertion, 0);
3884     PL_curstash = ostash;
3885 }
3886
3887 #ifndef STRESS_REALLOC
3888 #define REASONABLE(size) (size)
3889 #else
3890 #define REASONABLE(size) (1) /* unreasonable */
3891 #endif
3892
3893 void
3894 Perl_init_stacks(pTHX)
3895 {
3896     /* start with 128-item stack and 8K cxstack */
3897     PL_curstackinfo = new_stackinfo(REASONABLE(128),
3898                                  REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
3899     PL_curstackinfo->si_type = PERLSI_MAIN;
3900     PL_curstack = PL_curstackinfo->si_stack;
3901     PL_mainstack = PL_curstack;         /* remember in case we switch stacks */
3902
3903     PL_stack_base = AvARRAY(PL_curstack);
3904     PL_stack_sp = PL_stack_base;
3905     PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
3906
3907     New(50,PL_tmps_stack,REASONABLE(128),SV*);
3908     PL_tmps_floor = -1;
3909     PL_tmps_ix = -1;
3910     PL_tmps_max = REASONABLE(128);
3911
3912     New(54,PL_markstack,REASONABLE(32),I32);
3913     PL_markstack_ptr = PL_markstack;
3914     PL_markstack_max = PL_markstack + REASONABLE(32);
3915
3916     SET_MARK_OFFSET;
3917
3918     New(54,PL_scopestack,REASONABLE(32),I32);
3919     PL_scopestack_ix = 0;
3920     PL_scopestack_max = REASONABLE(32);
3921
3922     New(54,PL_savestack,REASONABLE(128),ANY);
3923     PL_savestack_ix = 0;
3924     PL_savestack_max = REASONABLE(128);
3925 }
3926
3927 #undef REASONABLE
3928
3929 STATIC void
3930 S_nuke_stacks(pTHX)
3931 {
3932     while (PL_curstackinfo->si_next)
3933         PL_curstackinfo = PL_curstackinfo->si_next;
3934     while (PL_curstackinfo) {
3935         PERL_SI *p = PL_curstackinfo->si_prev;
3936         /* curstackinfo->si_stack got nuked by sv_free_arenas() */
3937         Safefree(PL_curstackinfo->si_cxstack);
3938         Safefree(PL_curstackinfo);
3939         PL_curstackinfo = p;
3940     }
3941     Safefree(PL_tmps_stack);
3942     Safefree(PL_markstack);
3943     Safefree(PL_scopestack);
3944     Safefree(PL_savestack);
3945 }
3946
3947 STATIC void
3948 S_init_lexer(pTHX)
3949 {
3950     PerlIO *tmpfp;
3951     tmpfp = PL_rsfp;
3952     PL_rsfp = Nullfp;
3953     lex_start(PL_linestr);
3954     PL_rsfp = tmpfp;
3955     PL_subname = newSVpvn("main",4);
3956 }
3957
3958 STATIC void
3959 S_init_predump_symbols(pTHX)
3960 {
3961     GV *tmpgv;
3962     IO *io;
3963
3964     sv_setpvn(get_sv("\"", TRUE), " ", 1);
3965     PL_stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
3966     GvMULTI_on(PL_stdingv);
3967     io = GvIOp(PL_stdingv);
3968     IoTYPE(io) = IoTYPE_RDONLY;
3969     IoIFP(io) = PerlIO_stdin();
3970     tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
3971     GvMULTI_on(tmpgv);
3972     GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
3973
3974     tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
3975     GvMULTI_on(tmpgv);
3976     io = GvIOp(tmpgv);
3977     IoTYPE(io) = IoTYPE_WRONLY;
3978     IoOFP(io) = IoIFP(io) = PerlIO_stdout();
3979     setdefout(tmpgv);
3980     tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
3981     GvMULTI_on(tmpgv);
3982     GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
3983
3984     PL_stderrgv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
3985     GvMULTI_on(PL_stderrgv);
3986     io = GvIOp(PL_stderrgv);
3987     IoTYPE(io) = IoTYPE_WRONLY;
3988     IoOFP(io) = IoIFP(io) = PerlIO_stderr();
3989     tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
3990     GvMULTI_on(tmpgv);
3991     GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
3992
3993     PL_statname = NEWSV(66,0);          /* last filename we did stat on */
3994
3995     if (PL_osname)
3996         Safefree(PL_osname);
3997     PL_osname = savepv(OSNAME);
3998 }
3999
4000 void
4001 Perl_init_argv_symbols(pTHX_ register int argc, register char **argv)
4002 {
4003     char *s;
4004     argc--,argv++;      /* skip name of script */
4005     if (PL_doswitches) {
4006         for (; argc > 0 && **argv == '-'; argc--,argv++) {
4007             if (!argv[0][1])
4008                 break;
4009             if (argv[0][1] == '-' && !argv[0][2]) {
4010                 argc--,argv++;
4011                 break;
4012             }
4013             if ((s = strchr(argv[0], '='))) {
4014                 *s++ = '\0';
4015                 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
4016             }
4017             else
4018                 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
4019         }
4020     }
4021     if ((PL_argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV))) {
4022         GvMULTI_on(PL_argvgv);
4023         (void)gv_AVadd(PL_argvgv);
4024         av_clear(GvAVn(PL_argvgv));
4025         for (; argc > 0; argc--,argv++) {
4026             SV *sv = newSVpv(argv[0],0);
4027             av_push(GvAVn(PL_argvgv),sv);
4028             if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) {
4029                  if (PL_unicode & PERL_UNICODE_ARGV_FLAG)
4030                       SvUTF8_on(sv);
4031             }
4032             if (PL_unicode & PERL_UNICODE_WIDESYSCALLS_FLAG) /* Sarathy? */
4033                  (void)sv_utf8_decode(sv);
4034         }
4035     }
4036 }
4037
4038 STATIC void
4039 S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env)
4040 {
4041     char *s;
4042     SV *sv;
4043     GV* tmpgv;
4044
4045     PL_toptarget = NEWSV(0,0);
4046     sv_upgrade(PL_toptarget, SVt_PVFM);
4047     sv_setpvn(PL_toptarget, "", 0);
4048     PL_bodytarget = NEWSV(0,0);
4049     sv_upgrade(PL_bodytarget, SVt_PVFM);
4050     sv_setpvn(PL_bodytarget, "", 0);
4051     PL_formtarget = PL_bodytarget;
4052
4053     TAINT;
4054
4055     init_argv_symbols(argc,argv);
4056
4057     if ((tmpgv = gv_fetchpv("0",TRUE, SVt_PV))) {
4058 #ifdef MACOS_TRADITIONAL
4059         /* $0 is not majick on a Mac */
4060         sv_setpv(GvSV(tmpgv),MacPerl_MPWFileName(PL_origfilename));
4061 #else
4062         sv_setpv(GvSV(tmpgv),PL_origfilename);
4063         magicname("0", "0", 1);
4064 #endif
4065     }
4066     if ((PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV))) {
4067         HV *hv;
4068         GvMULTI_on(PL_envgv);
4069         hv = GvHVn(PL_envgv);
4070         hv_magic(hv, Nullgv, PERL_MAGIC_env);
4071 #ifndef PERL_MICRO
4072 #ifdef USE_ENVIRON_ARRAY
4073         /* Note that if the supplied env parameter is actually a copy
4074            of the global environ then it may now point to free'd memory
4075            if the environment has been modified since. To avoid this
4076            problem we treat env==NULL as meaning 'use the default'
4077         */
4078         if (!env)
4079             env = environ;
4080         if (env != environ
4081 #  ifdef USE_ITHREADS
4082             && PL_curinterp == aTHX
4083 #  endif
4084            )
4085         {
4086             environ[0] = Nullch;
4087         }
4088         if (env) {
4089           char** origenv = environ;
4090           for (; *env; env++) {
4091             if (!(s = strchr(*env,'=')) || s == *env)
4092                 continue;
4093 #if defined(MSDOS) && !defined(DJGPP)
4094             *s = '\0';
4095             (void)strupr(*env);
4096             *s = '=';
4097 #endif
4098             sv = newSVpv(s+1, 0);
4099             (void)hv_store(hv, *env, s - *env, sv, 0);
4100             if (env != environ)
4101                 mg_set(sv);
4102             if (origenv != environ) {
4103               /* realloc has shifted us */
4104               env = (env - origenv) + environ;
4105               origenv = environ;
4106             }
4107           }
4108       }
4109 #endif /* USE_ENVIRON_ARRAY */
4110 #endif /* !PERL_MICRO */
4111     }
4112     TAINT_NOT;
4113     if ((tmpgv = gv_fetchpv("$",TRUE, SVt_PV))) {
4114         SvREADONLY_off(GvSV(tmpgv));
4115         sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
4116         SvREADONLY_on(GvSV(tmpgv));
4117     }
4118 #ifdef THREADS_HAVE_PIDS
4119     PL_ppid = (IV)getppid();
4120 #endif
4121
4122     /* touch @F array to prevent spurious warnings 20020415 MJD */
4123     if (PL_minus_a) {
4124       (void) get_av("main::F", TRUE | GV_ADDMULTI);
4125     }
4126     /* touch @- and @+ arrays to prevent spurious warnings 20020415 MJD */
4127     (void) get_av("main::-", TRUE | GV_ADDMULTI);
4128     (void) get_av("main::+", TRUE | GV_ADDMULTI);
4129 }
4130
4131 STATIC void
4132 S_init_perllib(pTHX)
4133 {
4134     char *s;
4135     if (!PL_tainting) {
4136 #ifndef VMS
4137         s = PerlEnv_getenv("PERL5LIB");
4138         if (s)
4139             incpush(s, TRUE, TRUE, TRUE, FALSE);
4140         else
4141             incpush(PerlEnv_getenv("PERLLIB"), FALSE, FALSE, TRUE, FALSE);
4142 #else /* VMS */
4143         /* Treat PERL5?LIB as a possible search list logical name -- the
4144          * "natural" VMS idiom for a Unix path string.  We allow each
4145          * element to be a set of |-separated directories for compatibility.
4146          */
4147         char buf[256];
4148         int idx = 0;
4149         if (my_trnlnm("PERL5LIB",buf,0))
4150             do { incpush(buf,TRUE,TRUE,TRUE,FALSE); } while (my_trnlnm("PERL5LIB",buf,++idx));
4151         else
4152             while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE,FALSE,TRUE,FALSE);
4153 #endif /* VMS */
4154     }
4155
4156 /* Use the ~-expanded versions of APPLLIB (undocumented),
4157     ARCHLIB PRIVLIB SITEARCH SITELIB VENDORARCH and VENDORLIB
4158 */
4159 #ifdef APPLLIB_EXP
4160     incpush(APPLLIB_EXP, TRUE, TRUE, TRUE, TRUE);
4161 #endif
4162
4163 #ifdef ARCHLIB_EXP
4164     incpush(ARCHLIB_EXP, FALSE, FALSE, TRUE, TRUE);
4165 #endif
4166 #ifdef MACOS_TRADITIONAL
4167     {
4168         Stat_t tmpstatbuf;
4169         SV * privdir = NEWSV(55, 0);
4170         char * macperl = PerlEnv_getenv("MACPERL");
4171
4172         if (!macperl)
4173             macperl = "";
4174
4175         Perl_sv_setpvf(aTHX_ privdir, "%slib:", macperl);
4176         if (PerlLIO_stat(SvPVX(privdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode))
4177             incpush(SvPVX(privdir), TRUE, FALSE, TRUE, FALSE);
4178         Perl_sv_setpvf(aTHX_ privdir, "%ssite_perl:", macperl);
4179         if (PerlLIO_stat(SvPVX(privdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode))
4180             incpush(SvPVX(privdir), TRUE, FALSE, TRUE, FALSE);
4181
4182         SvREFCNT_dec(privdir);
4183     }
4184     if (!PL_tainting)
4185         incpush(":", FALSE, FALSE, TRUE, FALSE);
4186 #else
4187 #ifndef PRIVLIB_EXP
4188 #  define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
4189 #endif
4190 #if defined(WIN32)
4191     incpush(PRIVLIB_EXP, TRUE, FALSE, TRUE, TRUE);
4192 #else
4193     incpush(PRIVLIB_EXP, FALSE, FALSE, TRUE, TRUE);
4194 #endif
4195
4196 #ifdef SITEARCH_EXP
4197     /* sitearch is always relative to sitelib on Windows for
4198      * DLL-based path intuition to work correctly */
4199 #  if !defined(WIN32)
4200     incpush(SITEARCH_EXP, FALSE, FALSE, TRUE, TRUE);
4201 #  endif
4202 #endif
4203
4204 #ifdef SITELIB_EXP
4205 #  if defined(WIN32)
4206     /* this picks up sitearch as well */
4207     incpush(SITELIB_EXP, TRUE, FALSE, TRUE, TRUE);
4208 #  else
4209     incpush(SITELIB_EXP, FALSE, FALSE, TRUE, TRUE);
4210 #  endif
4211 #endif
4212
4213 #ifdef SITELIB_STEM /* Search for version-specific dirs below here */
4214     incpush(SITELIB_STEM, FALSE, TRUE, TRUE, TRUE);
4215 #endif
4216
4217 #ifdef PERL_VENDORARCH_EXP
4218     /* vendorarch is always relative to vendorlib on Windows for
4219      * DLL-based path intuition to work correctly */
4220 #  if !defined(WIN32)
4221     incpush(PERL_VENDORARCH_EXP, FALSE, FALSE, TRUE, TRUE);
4222 #  endif
4223 #endif
4224
4225 #ifdef PERL_VENDORLIB_EXP
4226 #  if defined(WIN32)
4227     incpush(PERL_VENDORLIB_EXP, TRUE, FALSE, TRUE, TRUE);       /* this picks up vendorarch as well */
4228 #  else
4229     incpush(PERL_VENDORLIB_EXP, FALSE, FALSE, TRUE, TRUE);
4230 #  endif
4231 #endif
4232
4233 #ifdef PERL_VENDORLIB_STEM /* Search for version-specific dirs below here */
4234     incpush(PERL_VENDORLIB_STEM, FALSE, TRUE, TRUE, TRUE);
4235 #endif
4236
4237 #ifdef PERL_OTHERLIBDIRS
4238     incpush(PERL_OTHERLIBDIRS, TRUE, TRUE, TRUE, TRUE);
4239 #endif
4240
4241     if (!PL_tainting)
4242         incpush(".", FALSE, FALSE, TRUE, FALSE);
4243 #endif /* MACOS_TRADITIONAL */
4244 }
4245
4246 #if defined(DOSISH) || defined(EPOC)
4247 #    define PERLLIB_SEP ';'
4248 #else
4249 #  if defined(VMS)
4250 #    define PERLLIB_SEP '|'
4251 #  else
4252 #    if defined(MACOS_TRADITIONAL)
4253 #      define PERLLIB_SEP ','
4254 #    else
4255 #      define PERLLIB_SEP ':'
4256 #    endif
4257 #  endif
4258 #endif
4259 #ifndef PERLLIB_MANGLE
4260 #  define PERLLIB_MANGLE(s,n) (s)
4261 #endif
4262
4263 /* Push a directory onto @INC if it exists.
4264    Generate a new SV if we do this, to save needing to copy the SV we push
4265    onto @INC  */
4266 STATIC SV *
4267 S_incpush_if_exists(pTHX_ SV *dir)
4268 {
4269     Stat_t tmpstatbuf;
4270     if (PerlLIO_stat(SvPVX(dir), &tmpstatbuf) >= 0 &&
4271         S_ISDIR(tmpstatbuf.st_mode)) {
4272         av_push(GvAVn(PL_incgv), dir);
4273         dir = NEWSV(0,0);
4274     }
4275     return dir;
4276 }
4277
4278 STATIC void
4279 S_incpush(pTHX_ char *p, int addsubdirs, int addoldvers, int usesep,
4280           int canrelocate)
4281 {
4282     SV *subdir = Nullsv;
4283
4284     if (!p || !*p)
4285         return;
4286
4287     if (addsubdirs || addoldvers) {
4288         subdir = NEWSV(0,0);
4289     }
4290
4291     /* Break at all separators */
4292     while (p && *p) {
4293         SV *libdir = NEWSV(55,0);
4294         char *s;
4295
4296         /* skip any consecutive separators */
4297         if (usesep) {
4298             while ( *p == PERLLIB_SEP ) {
4299                 /* Uncomment the next line for PATH semantics */
4300                 /* av_push(GvAVn(PL_incgv), newSVpvn(".", 1)); */
4301                 p++;
4302             }
4303         }
4304
4305         if ( usesep && (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
4306             sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
4307                       (STRLEN)(s - p));
4308             p = s + 1;
4309         }
4310         else {
4311             sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
4312             p = Nullch; /* break out */
4313         }
4314 #ifdef MACOS_TRADITIONAL
4315         if (!strchr(SvPVX(libdir), ':')) {
4316             char buf[256];
4317
4318             sv_setpv(libdir, MacPerl_CanonDir(SvPVX(libdir), buf, 0));
4319         }
4320         if (SvPVX(libdir)[SvCUR(libdir)-1] != ':')
4321             sv_catpv(libdir, ":");
4322 #endif
4323
4324 #ifdef PERL_RELOCATABLE_INC
4325         /*
4326          * Relocatable include entries are marked with a leading .../
4327          *
4328          * The algorithm is
4329          * 0: Remove that leading ".../"
4330          * 1: Remove trailing executable name (anything after the last '/')
4331          *    from the perl path to give a perl prefix
4332          * Then
4333          * While the @INC element starts "../" and the prefix ends with a real
4334          * directory (ie not . or ..) chop that real directory off the prefix
4335          * and the leading "../" from the @INC element. ie a logical "../"
4336          * cleanup
4337          * Finally concatenate the prefix and the remainder of the @INC element
4338          * The intent is that /usr/local/bin/perl and .../../lib/perl5
4339          * generates /usr/local/lib/perl5
4340          */
4341         {
4342             char *libpath = SvPVX(libdir);
4343             STRLEN libpath_len = SvCUR(libdir);
4344             if (libpath_len >= 4 && memEQ (libpath, ".../", 4)) {
4345                 /* Game on!  */
4346                 SV *caret_X = get_sv("\030", 0);
4347                 /* Going to use the SV just as a scratch buffer holding a C
4348                    string:  */
4349                 SV *prefix_sv;
4350                 char *prefix;
4351                 char *lastslash;
4352
4353                 /* $^X is *the* source of taint if tainting is on, hence
4354                    SvPOK() won't be true.  */
4355                 assert(caret_X);
4356                 assert(SvPOKp(caret_X));
4357                 prefix_sv = newSVpvn(SvPVX(caret_X), SvCUR(caret_X));
4358                 /* Firstly take off the leading .../
4359                    If all else fail we'll do the paths relative to the current
4360                    directory.  */
4361                 sv_chop(libdir, libpath + 4);
4362                 /* Don't use SvPV as we're intentionally bypassing taining,
4363                    mortal copies that the mg_get of tainting creates, and
4364                    corruption that seems to come via the save stack.
4365                    I guess that the save stack isn't correctly set up yet.  */
4366                 libpath = SvPVX(libdir);
4367                 libpath_len = SvCUR(libdir);
4368
4369                 /* This would work more efficiently with memrchr, but as it's
4370                    only a GNU extension we'd need to probe for it and
4371                    implement our own. Not hard, but maybe not worth it?  */
4372
4373                 prefix = SvPVX(prefix_sv);
4374                 lastslash = strrchr(prefix, '/');
4375
4376                 /* First time in with the *lastslash = '\0' we just wipe off
4377                    the trailing /perl from (say) /usr/foo/bin/perl
4378                 */
4379                 if (lastslash) {
4380                     SV *tempsv;
4381                     while ((*lastslash = '\0'), /* Do that, come what may.  */
4382                            (libpath_len >= 3 && memEQ(libpath, "../", 3)
4383                             && (lastslash = strrchr(prefix, '/')))) {
4384                         if (lastslash[1] == '\0'
4385                             || (lastslash[1] == '.'
4386                                 && (lastslash[2] == '/' /* ends "/."  */
4387                                     || (lastslash[2] == '/'
4388                                         && lastslash[3] == '/' /* or "/.."  */
4389                                         )))) {
4390                             /* Prefix ends "/" or "/." or "/..", any of which
4391                                are fishy, so don't do any more logical cleanup.
4392                             */
4393                             break;
4394                         }
4395                         /* Remove leading "../" from path  */
4396                         libpath += 3;
4397                         libpath_len -= 3;
4398                         /* Next iteration round the loop removes the last
4399                            directory name from prefix by writing a '\0' in
4400                            the while clause.  */
4401                     }
4402                     /* prefix has been terminated with a '\0' to the correct
4403                        length. libpath points somewhere into the libdir SV.
4404                        We need to join the 2 with '/' and drop the result into
4405                        libdir.  */
4406                     tempsv = Perl_newSVpvf(aTHX_ "%s/%s", prefix, libpath);
4407                     SvREFCNT_dec(libdir);
4408                     /* And this is the new libdir.  */
4409                     libdir = tempsv;
4410                     if (PL_tainting &&
4411                         (PL_uid != PL_euid || PL_gid != PL_egid)) {
4412                         /* Need to taint reloccated paths if running set ID  */
4413                         SvTAINTED_on(libdir);
4414                     }
4415                 }
4416                 SvREFCNT_dec(prefix_sv);
4417             }
4418         }
4419 #endif
4420         /*
4421          * BEFORE pushing libdir onto @INC we may first push version- and
4422          * archname-specific sub-directories.
4423          */
4424         if (addsubdirs || addoldvers) {
4425 #ifdef PERL_INC_VERSION_LIST
4426             /* Configure terminates PERL_INC_VERSION_LIST with a NULL */
4427             const char *incverlist[] = { PERL_INC_VERSION_LIST };
4428             const char **incver;
4429 #endif
4430 #ifdef VMS
4431             char *unix;
4432             STRLEN len;
4433
4434             if ((unix = tounixspec_ts(SvPV(libdir,len),Nullch)) != Nullch) {
4435                 len = strlen(unix);
4436                 while (unix[len-1] == '/') len--;  /* Cosmetic */
4437                 sv_usepvn(libdir,unix,len);
4438             }
4439             else
4440                 PerlIO_printf(Perl_error_log,
4441                               "Failed to unixify @INC element \"%s\"\n",
4442                               SvPV(libdir,len));
4443 #endif
4444             if (addsubdirs) {
4445 #ifdef MACOS_TRADITIONAL
4446 #define PERL_AV_SUFFIX_FMT      ""
4447 #define PERL_ARCH_FMT           "%s:"
4448 #define PERL_ARCH_FMT_PATH      PERL_FS_VER_FMT PERL_AV_SUFFIX_FMT
4449 #else
4450 #define PERL_AV_SUFFIX_FMT      "/"
4451 #define PERL_ARCH_FMT           "/%s"
4452 #define PERL_ARCH_FMT_PATH      PERL_AV_SUFFIX_FMT PERL_FS_VER_FMT
4453 #endif
4454                 /* .../version/archname if -d .../version/archname */
4455                 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT_PATH PERL_ARCH_FMT,
4456                                 libdir,
4457                                (int)PERL_REVISION, (int)PERL_VERSION,
4458                                (int)PERL_SUBVERSION, ARCHNAME);
4459                 subdir = S_incpush_if_exists(aTHX_ subdir);
4460
4461                 /* .../version if -d .../version */
4462                 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT_PATH, libdir,
4463                                (int)PERL_REVISION, (int)PERL_VERSION,
4464                                (int)PERL_SUBVERSION);
4465                 subdir = S_incpush_if_exists(aTHX_ subdir);
4466
4467                 /* .../archname if -d .../archname */
4468                 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT, libdir, ARCHNAME);
4469                 subdir = S_incpush_if_exists(aTHX_ subdir);
4470
4471             }
4472
4473 #ifdef PERL_INC_VERSION_LIST
4474             if (addoldvers) {
4475                 for (incver = incverlist; *incver; incver++) {
4476                     /* .../xxx if -d .../xxx */
4477                     Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT, libdir, *incver);
4478                     subdir = S_incpush_if_exists(aTHX_ subdir);
4479                 }
4480             }
4481 #endif
4482         }
4483
4484         /* finally push this lib directory on the end of @INC */
4485         av_push(GvAVn(PL_incgv), libdir);
4486     }
4487     if (subdir) {
4488         assert (SvREFCNT(subdir) == 1);
4489         SvREFCNT_dec(subdir);
4490     }
4491 }
4492
4493 #ifdef USE_5005THREADS
4494 STATIC struct perl_thread *
4495 S_init_main_thread(pTHX)
4496 {
4497 #if !defined(PERL_IMPLICIT_CONTEXT)
4498     struct perl_thread *thr;
4499 #endif
4500     XPV *xpv;
4501
4502     Newz(53, thr, 1, struct perl_thread);
4503     PL_curcop = &PL_compiling;
4504     thr->interp = PERL_GET_INTERP;
4505     thr->cvcache = newHV();
4506     thr->threadsv = newAV();
4507     /* thr->threadsvp is set when find_threadsv is called */
4508     thr->specific = newAV();
4509     thr->flags = THRf_R_JOINABLE;
4510     MUTEX_INIT(&thr->mutex);
4511     /* Handcraft thrsv similarly to mess_sv */
4512     New(53, PL_thrsv, 1, SV);
4513     Newz(53, xpv, 1, XPV);
4514     SvFLAGS(PL_thrsv) = SVt_PV;
4515     SvANY(PL_thrsv) = (void*)xpv;
4516     SvREFCNT(PL_thrsv) = 1 << 30;       /* practically infinite */
4517     SvPVX(PL_thrsv) = (char*)thr;
4518     SvCUR_set(PL_thrsv, sizeof(thr));
4519     SvLEN_set(PL_thrsv, sizeof(thr));
4520     *SvEND(PL_thrsv) = '\0';    /* in the trailing_nul field */
4521     thr->oursv = PL_thrsv;
4522     PL_chopset = " \n-";
4523     PL_dumpindent = 4;
4524
4525     MUTEX_LOCK(&PL_threads_mutex);
4526     PL_nthreads++;
4527     thr->tid = 0;
4528     thr->next = thr;
4529     thr->prev = thr;
4530     thr->thr_done = 0;
4531     MUTEX_UNLOCK(&PL_threads_mutex);
4532
4533 #ifdef HAVE_THREAD_INTERN
4534     Perl_init_thread_intern(thr);
4535 #endif
4536
4537 #ifdef SET_THREAD_SELF
4538     SET_THREAD_SELF(thr);
4539 #else
4540     thr->self = pthread_self();
4541 #endif /* SET_THREAD_SELF */
4542     PERL_SET_THX(thr);
4543
4544     /*
4545      * These must come after the thread self setting
4546      * because sv_setpvn does SvTAINT and the taint
4547      * fields thread selfness being set.
4548      */
4549     PL_toptarget = NEWSV(0,0);
4550     sv_upgrade(PL_toptarget, SVt_PVFM);
4551     sv_setpvn(PL_toptarget, "", 0);
4552     PL_bodytarget = NEWSV(0,0);
4553     sv_upgrade(PL_bodytarget, SVt_PVFM);
4554     sv_setpvn(PL_bodytarget, "", 0);
4555     PL_formtarget = PL_bodytarget;
4556     thr->errsv = newSVpvn("", 0);
4557     (void) find_threadsv("@");  /* Ensure $@ is initialised early */
4558
4559     PL_maxscream = -1;
4560     PL_peepp = MEMBER_TO_FPTR(Perl_peep);
4561     PL_regcompp = MEMBER_TO_FPTR(Perl_pregcomp);
4562     PL_regexecp = MEMBER_TO_FPTR(Perl_regexec_flags);
4563     PL_regint_start = MEMBER_TO_FPTR(Perl_re_intuit_start);
4564     PL_regint_string = MEMBER_TO_FPTR(Perl_re_intuit_string);
4565     PL_regfree = MEMBER_TO_FPTR(Perl_pregfree);
4566     PL_regindent = 0;
4567     PL_reginterp_cnt = 0;
4568
4569     return thr;
4570 }
4571 #endif /* USE_5005THREADS */
4572
4573 void
4574 Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
4575 {
4576     SV *atsv;
4577     line_t oldline = CopLINE(PL_curcop);
4578     CV *cv;
4579     STRLEN len;
4580     int ret;
4581     dJMPENV;
4582
4583     while (AvFILL(paramList) >= 0) {
4584         cv = (CV*)av_shift(paramList);
4585         if (PL_savebegin) {
4586             if (paramList == PL_beginav) {
4587                 /* save PL_beginav for compiler */
4588                 if (! PL_beginav_save)
4589                     PL_beginav_save = newAV();
4590                 av_push(PL_beginav_save, (SV*)cv);
4591             }
4592             else if (paramList == PL_checkav) {
4593                 /* save PL_checkav for compiler */
4594                 if (! PL_checkav_save)
4595                     PL_checkav_save = newAV();
4596                 av_push(PL_checkav_save, (SV*)cv);
4597             }
4598         } else {
4599             SAVEFREESV(cv);
4600         }
4601         JMPENV_PUSH(ret);
4602         switch (ret) {
4603         case 0:
4604             call_list_body(cv);
4605             atsv = ERRSV;
4606             (void)SvPV(atsv, len);
4607             if (len) {
4608                 PL_curcop = &PL_compiling;
4609                 CopLINE_set(PL_curcop, oldline);
4610                 if (paramList == PL_beginav)
4611                     sv_catpv(atsv, "BEGIN failed--compilation aborted");
4612                 else
4613                     Perl_sv_catpvf(aTHX_ atsv,
4614                                    "%s failed--call queue aborted",
4615                                    paramList == PL_checkav ? "CHECK"
4616                                    : paramList == PL_initav ? "INIT"
4617                                    : "END");
4618                 while (PL_scopestack_ix > oldscope)
4619                     LEAVE;
4620                 JMPENV_POP;
4621                 Perl_croak(aTHX_ "%"SVf"", atsv);
4622             }
4623             break;
4624         case 1:
4625             STATUS_ALL_FAILURE;
4626             /* FALL THROUGH */
4627         case 2:
4628             /* my_exit() was called */
4629             while (PL_scopestack_ix > oldscope)
4630                 LEAVE;
4631             FREETMPS;
4632             PL_curstash = PL_defstash;
4633             PL_curcop = &PL_compiling;
4634             CopLINE_set(PL_curcop, oldline);
4635             JMPENV_POP;
4636             if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED)) {
4637                 if (paramList == PL_beginav)
4638                     Perl_croak(aTHX_ "BEGIN failed--compilation aborted");
4639                 else
4640                     Perl_croak(aTHX_ "%s failed--call queue aborted",
4641                                paramList == PL_checkav ? "CHECK"
4642                                : paramList == PL_initav ? "INIT"
4643                                : "END");
4644             }
4645             my_exit_jump();
4646             /* NOTREACHED */
4647         case 3:
4648             if (PL_restartop) {
4649                 PL_curcop = &PL_compiling;
4650                 CopLINE_set(PL_curcop, oldline);
4651                 JMPENV_JUMP(3);
4652             }
4653             PerlIO_printf(Perl_error_log, "panic: restartop\n");
4654             FREETMPS;
4655             break;
4656         }
4657         JMPENV_POP;
4658     }
4659 }
4660
4661 STATIC void *
4662 S_call_list_body(pTHX_ CV *cv)
4663 {
4664     PUSHMARK(PL_stack_sp);
4665     call_sv((SV*)cv, G_EVAL|G_DISCARD);
4666     return NULL;
4667 }
4668
4669 void
4670 Perl_my_exit(pTHX_ U32 status)
4671 {
4672     DEBUG_S(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
4673                           thr, (unsigned long) status));
4674     switch (status) {
4675     case 0:
4676         STATUS_ALL_SUCCESS;
4677         break;
4678     case 1:
4679         STATUS_ALL_FAILURE;
4680         break;
4681     default:
4682         STATUS_NATIVE_SET(status);
4683         break;
4684     }
4685     my_exit_jump();
4686 }
4687
4688 void
4689 Perl_my_failure_exit(pTHX)
4690 {
4691 #ifdef VMS
4692     if (vaxc$errno & 1) {
4693         if (STATUS_NATIVE & 1)          /* fortuitiously includes "-1" */
4694             STATUS_NATIVE_SET(44);
4695     }
4696     else {
4697         if (!vaxc$errno)                /* unlikely */
4698             STATUS_NATIVE_SET(44);
4699         else
4700             STATUS_NATIVE_SET(vaxc$errno);
4701     }
4702 #else
4703     int exitstatus;
4704     if (errno & 255)
4705         STATUS_POSIX_SET(errno);
4706     else {
4707         exitstatus = STATUS_POSIX >> 8;
4708         if (exitstatus & 255)
4709             STATUS_POSIX_SET(exitstatus);
4710         else
4711             STATUS_POSIX_SET(255);
4712     }
4713 #endif
4714     my_exit_jump();
4715 }
4716
4717 STATIC void
4718 S_my_exit_jump(pTHX)
4719 {
4720     register PERL_CONTEXT *cx;
4721     I32 gimme;
4722     SV **newsp;
4723
4724     if (PL_e_script) {
4725         SvREFCNT_dec(PL_e_script);
4726         PL_e_script = Nullsv;
4727     }
4728
4729     POPSTACK_TO(PL_mainstack);
4730     if (cxstack_ix >= 0) {
4731         if (cxstack_ix > 0)
4732             dounwind(0);
4733         POPBLOCK(cx,PL_curpm);
4734         LEAVE;
4735     }
4736
4737     JMPENV_JUMP(2);
4738 }
4739
4740 static I32
4741 read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen)
4742 {
4743     char *p, *nl;
4744     p  = SvPVX(PL_e_script);
4745     nl = strchr(p, '\n');
4746     nl = (nl) ? nl+1 : SvEND(PL_e_script);
4747     if (nl-p == 0) {
4748         filter_del(read_e_script);
4749         return 0;
4750     }
4751     sv_catpvn(buf_sv, p, nl-p);
4752     sv_chop(PL_e_script, nl);
4753     return 1;
4754 }