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