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     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                     const char *space;
1416                     char *pv = SvPV_nolen(PL_Sv);
1417                     const char c = pv[opts+76];
1418                     pv[opts+76] = '\0';
1419                     space = strrchr(pv+opts+26, ' ');
1420                     pv[opts+76] = c;
1421                     if (!space) break; /* "Can't happen" */
1422
1423                     /* break the line before that space */
1424
1425                     opts = space - pv;
1426                     sv_insert(PL_Sv, opts, 0,
1427                               "\\n                       ", 25);
1428                 }
1429
1430                 sv_catpv(PL_Sv,"\\n\",");
1431
1432 #if defined(LOCAL_PATCH_COUNT)
1433                 if (LOCAL_PATCH_COUNT > 0) {
1434                     int i;
1435                     sv_catpv(PL_Sv,"\"  Locally applied patches:\\n\",");
1436                     for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
1437                         if (PL_localpatches[i])
1438                             Perl_sv_catpvf(aTHX_ PL_Sv,"q%c\t%s\n%c,",
1439                                     0, PL_localpatches[i], 0);
1440                     }
1441                 }
1442 #endif
1443                 Perl_sv_catpvf(aTHX_ PL_Sv,"\"  Built under %s\\n\"",OSNAME);
1444 #ifdef __DATE__
1445 #  ifdef __TIME__
1446                 Perl_sv_catpvf(aTHX_ PL_Sv,",\"  Compiled at %s %s\\n\"",__DATE__,__TIME__);
1447 #  else
1448                 Perl_sv_catpvf(aTHX_ PL_Sv,",\"  Compiled on %s\\n\"",__DATE__);
1449 #  endif
1450 #endif
1451                 sv_catpv(PL_Sv, "; \
1452 $\"=\"\\n    \"; \
1453 @env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; ");
1454 #ifdef __CYGWIN__
1455                 sv_catpv(PL_Sv,"\
1456 push @env, \"CYGWIN=\\\"$ENV{CYGWIN}\\\"\";");
1457 #endif
1458                 sv_catpv(PL_Sv, "\
1459 print \"  \\%ENV:\\n    @env\\n\" if @env; \
1460 print \"  \\@INC:\\n    @INC\\n\";");
1461             }
1462             else {
1463                 PL_Sv = newSVpv("config_vars(qw(",0);
1464                 sv_catpv(PL_Sv, ++s);
1465                 sv_catpv(PL_Sv, "))");
1466                 s += strlen(s);
1467             }
1468             av_push(PL_preambleav, PL_Sv);
1469             scriptname = BIT_BUCKET;    /* don't look for script or read stdin */
1470             goto reswitch;
1471         case 'x':
1472             PL_doextract = TRUE;
1473             s++;
1474             if (*s)
1475                 cddir = s;
1476             break;
1477         case 0:
1478             break;
1479         case '-':
1480             if (!*++s || isSPACE(*s)) {
1481                 argc--,argv++;
1482                 goto switch_end;
1483             }
1484             /* catch use of gnu style long options */
1485             if (strEQ(s, "version")) {
1486                 s = (char *)"v";
1487                 goto reswitch;
1488             }
1489             if (strEQ(s, "help")) {
1490                 s = (char *)"h";
1491                 goto reswitch;
1492             }
1493             s--;
1494             /* FALL THROUGH */
1495         default:
1496             Perl_croak(aTHX_ "Unrecognized switch: -%s  (-h will show valid options)",s);
1497         }
1498     }
1499   switch_end:
1500
1501     if (
1502 #ifndef SECURE_INTERNAL_GETENV
1503         !PL_tainting &&
1504 #endif
1505         (s = PerlEnv_getenv("PERL5OPT")))
1506     {
1507         const char *popt = s;
1508         while (isSPACE(*s))
1509             s++;
1510         if (*s == '-' && *(s+1) == 'T') {
1511             CHECK_MALLOC_TOO_LATE_FOR('T');
1512             PL_tainting = TRUE;
1513             PL_taint_warn = FALSE;
1514         }
1515         else {
1516             char *popt_copy = Nullch;
1517             while (s && *s) {
1518                 char *d;
1519                 while (isSPACE(*s))
1520                     s++;
1521                 if (*s == '-') {
1522                     s++;
1523                     if (isSPACE(*s))
1524                         continue;
1525                 }
1526                 d = s;
1527                 if (!*s)
1528                     break;
1529                 if (!strchr("DIMUdmtwA", *s))
1530                     Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s);
1531                 while (++s && *s) {
1532                     if (isSPACE(*s)) {
1533                         if (!popt_copy) {
1534                             popt_copy = SvPVX(sv_2mortal(newSVpv(popt,0)));
1535                             s = popt_copy + (s - popt);
1536                             d = popt_copy + (d - popt);
1537                         }
1538                         *s++ = '\0';
1539                         break;
1540                     }
1541                 }
1542                 if (*d == 't') {
1543                     if( !PL_tainting ) {
1544                         PL_taint_warn = TRUE;
1545                         PL_tainting = TRUE;
1546                     }
1547                 } else {
1548                     moreswitches(d);
1549                 }
1550             }
1551         }
1552     }
1553
1554 #ifdef USE_SITECUSTOMIZE
1555     if (!minus_f) {
1556         if (!PL_preambleav)
1557             PL_preambleav = newAV();
1558         av_unshift(PL_preambleav, 1);
1559         (void)av_store(PL_preambleav, 0, Perl_newSVpvf(aTHX_ "BEGIN { do '%s/sitecustomize.pl' }", SITELIB_EXP));
1560     }
1561 #endif
1562
1563     if (PL_taint_warn && PL_dowarn != G_WARN_ALL_OFF) {
1564        PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
1565     }
1566
1567     if (!scriptname)
1568         scriptname = argv[0];
1569     if (PL_e_script) {
1570         argc++,argv--;
1571         scriptname = BIT_BUCKET;        /* don't look for script or read stdin */
1572     }
1573     else if (scriptname == Nullch) {
1574 #ifdef MSDOS
1575         if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) )
1576             moreswitches("h");
1577 #endif
1578         scriptname = "-";
1579     }
1580
1581     /* Set $^X early so that it can be used for relocatable paths in @INC  */
1582     assert (!PL_tainted);
1583     TAINT;
1584     S_set_caret_X(aTHX);
1585     TAINT_NOT;
1586     init_perllib();
1587
1588     open_script(scriptname,dosearch,sv);
1589
1590     validate_suid(validarg, scriptname);
1591
1592 #ifndef PERL_MICRO
1593 #if defined(SIGCHLD) || defined(SIGCLD)
1594     {
1595 #ifndef SIGCHLD
1596 #  define SIGCHLD SIGCLD
1597 #endif
1598         Sighandler_t sigstate = rsignal_state(SIGCHLD);
1599         if (sigstate == SIG_IGN) {
1600             if (ckWARN(WARN_SIGNAL))
1601                 Perl_warner(aTHX_ packWARN(WARN_SIGNAL),
1602                             "Can't ignore signal CHLD, forcing to default");
1603             (void)rsignal(SIGCHLD, (Sighandler_t)SIG_DFL);
1604         }
1605     }
1606 #endif
1607 #endif
1608
1609 #ifdef MACOS_TRADITIONAL
1610     if (PL_doextract || gMacPerl_AlwaysExtract) {
1611 #else
1612     if (PL_doextract) {
1613 #endif
1614         find_beginning();
1615         if (cddir && PerlDir_chdir( (char *)cddir ) < 0)
1616             Perl_croak(aTHX_ "Can't chdir to %s",cddir);
1617
1618     }
1619
1620     PL_main_cv = PL_compcv = (CV*)NEWSV(1104,0);
1621     sv_upgrade((SV *)PL_compcv, SVt_PVCV);
1622     CvUNIQUE_on(PL_compcv);
1623
1624     CvPADLIST(PL_compcv) = pad_new(0);
1625 #ifdef USE_5005THREADS
1626     CvOWNER(PL_compcv) = 0;
1627     New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
1628     MUTEX_INIT(CvMUTEXP(PL_compcv));
1629 #endif /* USE_5005THREADS */
1630
1631     boot_core_PerlIO();
1632     boot_core_UNIVERSAL();
1633     boot_core_xsutils();
1634
1635     if (xsinit)
1636         (*xsinit)(aTHX);        /* in case linked C routines want magical variables */
1637 #ifndef PERL_MICRO
1638 #if defined(VMS) || defined(WIN32) || defined(DJGPP) || defined(__CYGWIN__) || defined(EPOC)
1639     init_os_extras();
1640 #endif
1641 #endif
1642
1643 #ifdef USE_SOCKS
1644 #   ifdef HAS_SOCKS5_INIT
1645     socks5_init(argv[0]);
1646 #   else
1647     SOCKSinit(argv[0]);
1648 #   endif
1649 #endif
1650
1651     init_predump_symbols();
1652     /* init_postdump_symbols not currently designed to be called */
1653     /* more than once (ENV isn't cleared first, for example)     */
1654     /* But running with -u leaves %ENV & @ARGV undefined!    XXX */
1655     if (!PL_do_undump)
1656         init_postdump_symbols(argc,argv,env);
1657
1658     /* PL_unicode is turned on by -C or by $ENV{PERL_UNICODE}.
1659      * PL_utf8locale is conditionally turned on by
1660      * locale.c:Perl_init_i18nl10n() if the environment
1661      * look like the user wants to use UTF-8. */
1662     if (PL_unicode) {
1663          /* Requires init_predump_symbols(). */
1664          if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) {
1665               IO* io;
1666               PerlIO* fp;
1667               SV* sv;
1668
1669               /* Turn on UTF-8-ness on STDIN, STDOUT, STDERR
1670                * and the default open disciplines. */
1671               if ((PL_unicode & PERL_UNICODE_STDIN_FLAG) &&
1672                   PL_stdingv  && (io = GvIO(PL_stdingv)) &&
1673                   (fp = IoIFP(io)))
1674                    PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
1675               if ((PL_unicode & PERL_UNICODE_STDOUT_FLAG) &&
1676                   PL_defoutgv && (io = GvIO(PL_defoutgv)) &&
1677                   (fp = IoOFP(io)))
1678                    PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
1679               if ((PL_unicode & PERL_UNICODE_STDERR_FLAG) &&
1680                   PL_stderrgv && (io = GvIO(PL_stderrgv)) &&
1681                   (fp = IoOFP(io)))
1682                    PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
1683               if ((PL_unicode & PERL_UNICODE_INOUT_FLAG) &&
1684                   (sv = GvSV(gv_fetchpv("\017PEN", TRUE, SVt_PV)))) {
1685                    U32 in  = PL_unicode & PERL_UNICODE_IN_FLAG;
1686                    U32 out = PL_unicode & PERL_UNICODE_OUT_FLAG;
1687                    if (in) {
1688                         if (out)
1689                              sv_setpvn(sv, ":utf8\0:utf8", 11);
1690                         else
1691                              sv_setpvn(sv, ":utf8\0", 6);
1692                    }
1693                    else if (out)
1694                         sv_setpvn(sv, "\0:utf8", 6);
1695                    SvSETMAGIC(sv);
1696               }
1697          }
1698     }
1699
1700     if ((s = PerlEnv_getenv("PERL_SIGNALS"))) {
1701          if (strEQ(s, "unsafe"))
1702               PL_signals |=  PERL_SIGNALS_UNSAFE_FLAG;
1703          else if (strEQ(s, "safe"))
1704               PL_signals &= ~PERL_SIGNALS_UNSAFE_FLAG;
1705          else
1706               Perl_croak(aTHX_ "PERL_SIGNALS illegal: \"%s\"", s);
1707     }
1708
1709     init_lexer();
1710
1711     /* now parse the script */
1712
1713     SETERRNO(0,SS_NORMAL);
1714     PL_error_count = 0;
1715 #ifdef MACOS_TRADITIONAL
1716     if (gMacPerl_SyntaxError = (yyparse() || PL_error_count)) {
1717         if (PL_minus_c)
1718             Perl_croak(aTHX_ "%s had compilation errors.\n", MacPerl_MPWFileName(PL_origfilename));
1719         else {
1720             Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
1721                        MacPerl_MPWFileName(PL_origfilename));
1722         }
1723     }
1724 #else
1725     if (yyparse() || PL_error_count) {
1726         if (PL_minus_c)
1727             Perl_croak(aTHX_ "%s had compilation errors.\n", PL_origfilename);
1728         else {
1729             Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
1730                        PL_origfilename);
1731         }
1732     }
1733 #endif
1734     CopLINE_set(PL_curcop, 0);
1735     PL_curstash = PL_defstash;
1736     PL_preprocess = FALSE;
1737     if (PL_e_script) {
1738         SvREFCNT_dec(PL_e_script);
1739         PL_e_script = Nullsv;
1740     }
1741
1742     if (PL_do_undump)
1743         my_unexec();
1744
1745     if (isWARN_ONCE) {
1746         SAVECOPFILE(PL_curcop);
1747         SAVECOPLINE(PL_curcop);
1748         gv_check(PL_defstash);
1749     }
1750
1751     LEAVE;
1752     FREETMPS;
1753
1754 #ifdef MYMALLOC
1755     if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
1756         dump_mstats("after compilation:");
1757 #endif
1758
1759     ENTER;
1760     PL_restartop = 0;
1761     return NULL;
1762 }
1763
1764 /*
1765 =for apidoc perl_run
1766
1767 Tells a Perl interpreter to run.  See L<perlembed>.
1768
1769 =cut
1770 */
1771
1772 int
1773 perl_run(pTHXx)
1774 {
1775     I32 oldscope;
1776     int ret = 0;
1777     dJMPENV;
1778
1779     oldscope = PL_scopestack_ix;
1780 #ifdef VMS
1781     VMSISH_HUSHED = 0;
1782 #endif
1783
1784     JMPENV_PUSH(ret);
1785     switch (ret) {
1786     case 1:
1787         cxstack_ix = -1;                /* start context stack again */
1788         goto redo_body;
1789     case 0:                             /* normal completion */
1790  redo_body:
1791         run_body(oldscope);
1792         /* FALL THROUGH */
1793     case 2:                             /* my_exit() */
1794         while (PL_scopestack_ix > oldscope)
1795             LEAVE;
1796         FREETMPS;
1797         PL_curstash = PL_defstash;
1798         if (!(PL_exit_flags & PERL_EXIT_DESTRUCT_END) &&
1799             PL_endav && !PL_minus_c)
1800             call_list(oldscope, PL_endav);
1801 #ifdef MYMALLOC
1802         if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
1803             dump_mstats("after execution:  ");
1804 #endif
1805         ret = STATUS_NATIVE_EXPORT;
1806         break;
1807     case 3:
1808         if (PL_restartop) {
1809             POPSTACK_TO(PL_mainstack);
1810             goto redo_body;
1811         }
1812         PerlIO_printf(Perl_error_log, "panic: restartop\n");
1813         FREETMPS;
1814         ret = 1;
1815         break;
1816     }
1817
1818     JMPENV_POP;
1819     return ret;
1820 }
1821
1822
1823 STATIC void
1824 S_run_body(pTHX_ I32 oldscope)
1825 {
1826     DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
1827                     PL_sawampersand ? "Enabling" : "Omitting"));
1828
1829     if (!PL_restartop) {
1830         DEBUG_x(dump_all());
1831         if (!DEBUG_q_TEST)
1832           PERL_DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
1833         DEBUG_S(PerlIO_printf(Perl_debug_log, "main thread is 0x%"UVxf"\n",
1834                               PTR2UV(thr)));
1835
1836         if (PL_minus_c) {
1837 #ifdef MACOS_TRADITIONAL
1838             PerlIO_printf(Perl_error_log, "%s%s syntax OK\n",
1839                 (gMacPerl_ErrorFormat ? "# " : ""),
1840                 MacPerl_MPWFileName(PL_origfilename));
1841 #else
1842             PerlIO_printf(Perl_error_log, "%s syntax OK\n", PL_origfilename);
1843 #endif
1844             my_exit(0);
1845         }
1846         if (PERLDB_SINGLE && PL_DBsingle)
1847             sv_setiv(PL_DBsingle, 1);
1848         if (PL_initav)
1849             call_list(oldscope, PL_initav);
1850     }
1851
1852     /* do it */
1853
1854     if (PL_restartop) {
1855         PL_op = PL_restartop;
1856         PL_restartop = 0;
1857         CALLRUNOPS(aTHX);
1858     }
1859     else if (PL_main_start) {
1860         CvDEPTH(PL_main_cv) = 1;
1861         PL_op = PL_main_start;
1862         CALLRUNOPS(aTHX);
1863     }
1864
1865     my_exit(0);
1866     /* NOTREACHED */
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 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, bool 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( (const char **)&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( (const char **)&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_ const 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         scriptname = PL_origfilename = 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 = (char *)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 = (char *)"";
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         const 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), (char *)"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     (void)validarg;
3716     (void)scriptname;
3717 }
3718
3719 STATIC void
3720 S_find_beginning(pTHX)
3721 {
3722     register char *s;
3723     register const char *s2;
3724 #ifdef MACOS_TRADITIONAL
3725     int maclines = 0;
3726 #endif
3727
3728     /* skip forward in input to the real script? */
3729
3730     forbid_setid("-x");
3731 #ifdef MACOS_TRADITIONAL
3732     /* Since the Mac OS does not honor #! arguments for us, we do it ourselves */
3733
3734     while (PL_doextract || gMacPerl_AlwaysExtract) {
3735         if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
3736             if (!gMacPerl_AlwaysExtract)
3737                 Perl_croak(aTHX_ "No Perl script found in input\n");
3738
3739             if (PL_doextract)                   /* require explicit override ? */
3740                 if (!OverrideExtract(PL_origfilename))
3741                     Perl_croak(aTHX_ "User aborted script\n");
3742                 else
3743                     PL_doextract = FALSE;
3744
3745             /* Pater peccavi, file does not have #! */
3746             PerlIO_rewind(PL_rsfp);
3747
3748             break;
3749         }
3750 #else
3751     while (PL_doextract) {
3752         if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch)
3753             Perl_croak(aTHX_ "No Perl script found in input\n");
3754 #endif
3755         s2 = s;
3756         if (*s == '#' && s[1] == '!' && ((s = instr(s,"perl")) || (s = instr(s2,"PERL")))) {
3757             PerlIO_ungetc(PL_rsfp, '\n');               /* to keep line count right */
3758             PL_doextract = FALSE;
3759             while (*s && !(isSPACE (*s) || *s == '#')) s++;
3760             s2 = s;
3761             while (*s == ' ' || *s == '\t') s++;
3762             if (*s++ == '-') {
3763                 while (isDIGIT(s2[-1]) || s2[-1] == '-' || s2[-1] == '.'
3764                        || s2[-1] == '_') s2--;
3765                 if (strnEQ(s2-4,"perl",4))
3766                     /*SUPPRESS 530*/
3767                     while ((s = moreswitches(s)))
3768                         ;
3769             }
3770 #ifdef MACOS_TRADITIONAL
3771             /* We are always searching for the #!perl line in MacPerl,
3772              * so if we find it, still keep the line count correct
3773              * by counting lines we already skipped over
3774              */
3775             for (; maclines > 0 ; maclines--)
3776                 PerlIO_ungetc(PL_rsfp, '\n');
3777
3778             break;
3779
3780         /* gMacPerl_AlwaysExtract is false in MPW tool */
3781         } else if (gMacPerl_AlwaysExtract) {
3782             ++maclines;
3783 #endif
3784         }
3785     }
3786 }
3787
3788
3789 STATIC void
3790 S_init_ids(pTHX)
3791 {
3792     PL_uid = PerlProc_getuid();
3793     PL_euid = PerlProc_geteuid();
3794     PL_gid = PerlProc_getgid();
3795     PL_egid = PerlProc_getegid();
3796 #ifdef VMS
3797     PL_uid |= PL_gid << 16;
3798     PL_euid |= PL_egid << 16;
3799 #endif
3800     /* Should not happen: */
3801     CHECK_MALLOC_TAINT(PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
3802     PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
3803     /* BUG */
3804     /* PSz 27 Feb 04
3805      * Should go by suidscript, not uid!=euid: why disallow
3806      * system("ls") in scripts run from setuid things?
3807      * Or, is this run before we check arguments and set suidscript?
3808      * What about SETUID_SCRIPTS_ARE_SECURE_NOW: could we use fdscript then?
3809      * (We never have suidscript, can we be sure to have fdscript?)
3810      * Or must then go by UID checks? See comments in forbid_setid also.
3811      */
3812 }
3813
3814 /* This is used very early in the lifetime of the program,
3815  * before even the options are parsed, so PL_tainting has
3816  * not been initialized properly.  */
3817 bool
3818 Perl_doing_taint(int argc, char *argv[], char *envp[])
3819 {
3820 #ifndef PERL_IMPLICIT_SYS
3821     /* If we have PERL_IMPLICIT_SYS we can't call getuid() et alia
3822      * before we have an interpreter-- and the whole point of this
3823      * function is to be called at such an early stage.  If you are on
3824      * a system with PERL_IMPLICIT_SYS but you do have a concept of
3825      * "tainted because running with altered effective ids', you'll
3826      * have to add your own checks somewhere in here.  The two most
3827      * known samples of 'implicitness' are Win32 and NetWare, neither
3828      * of which has much of concept of 'uids'. */
3829     int uid  = PerlProc_getuid();
3830     int euid = PerlProc_geteuid();
3831     int gid  = PerlProc_getgid();
3832     int egid = PerlProc_getegid();
3833
3834 #ifdef VMS
3835     uid  |=  gid << 16;
3836     euid |= egid << 16;
3837 #endif
3838     if (uid && (euid != uid || egid != gid))
3839         return 1;
3840 #endif /* !PERL_IMPLICIT_SYS */
3841     /* This is a really primitive check; environment gets ignored only
3842      * if -T are the first chars together; otherwise one gets
3843      *  "Too late" message. */
3844     if ( argc > 1 && argv[1][0] == '-'
3845          && (argv[1][1] == 't' || argv[1][1] == 'T') )
3846         return 1;
3847     return 0;
3848     (void)envp;
3849 }
3850
3851 STATIC void
3852 S_forbid_setid(pTHX_ const char *s)
3853 {
3854 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
3855     if (PL_euid != PL_uid)
3856         Perl_croak(aTHX_ "No %s allowed while running setuid", s);
3857     if (PL_egid != PL_gid)
3858         Perl_croak(aTHX_ "No %s allowed while running setgid", s);
3859 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
3860     /* PSz 29 Feb 04
3861      * Checks for UID/GID above "wrong": why disallow
3862      *   perl -e 'print "Hello\n"'
3863      * from within setuid things?? Simply drop them: replaced by
3864      * fdscript/suidscript and #ifdef IAMSUID checks below.
3865      *
3866      * This may be too late for command-line switches. Will catch those on
3867      * the #! line, after finding the script name and setting up
3868      * fdscript/suidscript. Note that suidperl does not get around to
3869      * parsing (and checking) the switches on the #! line, but checks that
3870      * the two sets are identical.
3871      *
3872      * With SETUID_SCRIPTS_ARE_SECURE_NOW, could we use fdscript, also or
3873      * instead, or would that be "too late"? (We never have suidscript, can
3874      * we be sure to have fdscript?)
3875      *
3876      * Catch things with suidscript (in descendant of suidperl), even with
3877      * right UID/GID. Was already checked in suidperl, with #ifdef IAMSUID,
3878      * below; but I am paranoid.
3879      *
3880      * Also see comments about root running a setuid script, elsewhere.
3881      */
3882     if (PL_suidscript >= 0)
3883         Perl_croak(aTHX_ "No %s allowed with (suid) fdscript", s);
3884 #ifdef IAMSUID
3885     /* PSz 11 Nov 03  Catch it in suidperl, always! */
3886     Perl_croak(aTHX_ "No %s allowed in suidperl", s);
3887 #endif /* IAMSUID */
3888 }
3889
3890 void
3891 Perl_init_debugger(pTHX)
3892 {
3893     HV *ostash = PL_curstash;
3894
3895     PL_curstash = PL_debstash;
3896     PL_dbargs = GvAV(gv_AVadd((gv_fetchpv("DB::args", GV_ADDMULTI, SVt_PVAV))));
3897     AvREAL_off(PL_dbargs);
3898     PL_DBgv = gv_fetchpv("DB::DB", GV_ADDMULTI, SVt_PVGV);
3899     PL_DBline = gv_fetchpv("DB::dbline", GV_ADDMULTI, SVt_PVAV);
3900     PL_DBsub = gv_HVadd(gv_fetchpv("DB::sub", GV_ADDMULTI, SVt_PVHV));
3901     sv_upgrade(GvSV(PL_DBsub), SVt_IV); /* IVX accessed if PERLDB_SUB_NN */
3902     PL_DBsingle = GvSV((gv_fetchpv("DB::single", GV_ADDMULTI, SVt_PV)));
3903     sv_setiv(PL_DBsingle, 0);
3904     PL_DBtrace = GvSV((gv_fetchpv("DB::trace", GV_ADDMULTI, SVt_PV)));
3905     sv_setiv(PL_DBtrace, 0);
3906     PL_DBsignal = GvSV((gv_fetchpv("DB::signal", GV_ADDMULTI, SVt_PV)));
3907     sv_setiv(PL_DBsignal, 0);
3908     PL_DBassertion = GvSV((gv_fetchpv("DB::assertion", GV_ADDMULTI, SVt_PV)));
3909     sv_setiv(PL_DBassertion, 0);
3910     PL_curstash = ostash;
3911 }
3912
3913 #ifndef STRESS_REALLOC
3914 #define REASONABLE(size) (size)
3915 #else
3916 #define REASONABLE(size) (1) /* unreasonable */
3917 #endif
3918
3919 void
3920 Perl_init_stacks(pTHX)
3921 {
3922     /* start with 128-item stack and 8K cxstack */
3923     PL_curstackinfo = new_stackinfo(REASONABLE(128),
3924                                  REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
3925     PL_curstackinfo->si_type = PERLSI_MAIN;
3926     PL_curstack = PL_curstackinfo->si_stack;
3927     PL_mainstack = PL_curstack;         /* remember in case we switch stacks */
3928
3929     PL_stack_base = AvARRAY(PL_curstack);
3930     PL_stack_sp = PL_stack_base;
3931     PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
3932
3933     New(50,PL_tmps_stack,REASONABLE(128),SV*);
3934     PL_tmps_floor = -1;
3935     PL_tmps_ix = -1;
3936     PL_tmps_max = REASONABLE(128);
3937
3938     New(54,PL_markstack,REASONABLE(32),I32);
3939     PL_markstack_ptr = PL_markstack;
3940     PL_markstack_max = PL_markstack + REASONABLE(32);
3941
3942     SET_MARK_OFFSET;
3943
3944     New(54,PL_scopestack,REASONABLE(32),I32);
3945     PL_scopestack_ix = 0;
3946     PL_scopestack_max = REASONABLE(32);
3947
3948     New(54,PL_savestack,REASONABLE(128),ANY);
3949     PL_savestack_ix = 0;
3950     PL_savestack_max = REASONABLE(128);
3951 }
3952
3953 #undef REASONABLE
3954
3955 STATIC void
3956 S_nuke_stacks(pTHX)
3957 {
3958     while (PL_curstackinfo->si_next)
3959         PL_curstackinfo = PL_curstackinfo->si_next;
3960     while (PL_curstackinfo) {
3961         PERL_SI *p = PL_curstackinfo->si_prev;
3962         /* curstackinfo->si_stack got nuked by sv_free_arenas() */
3963         Safefree(PL_curstackinfo->si_cxstack);
3964         Safefree(PL_curstackinfo);
3965         PL_curstackinfo = p;
3966     }
3967     Safefree(PL_tmps_stack);
3968     Safefree(PL_markstack);
3969     Safefree(PL_scopestack);
3970     Safefree(PL_savestack);
3971 }
3972
3973 STATIC void
3974 S_init_lexer(pTHX)
3975 {
3976     PerlIO *tmpfp;
3977     tmpfp = PL_rsfp;
3978     PL_rsfp = Nullfp;
3979     lex_start(PL_linestr);
3980     PL_rsfp = tmpfp;
3981     PL_subname = newSVpvn("main",4);
3982 }
3983
3984 STATIC void
3985 S_init_predump_symbols(pTHX)
3986 {
3987     GV *tmpgv;
3988     IO *io;
3989
3990     sv_setpvn(get_sv("\"", TRUE), " ", 1);
3991     PL_stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
3992     GvMULTI_on(PL_stdingv);
3993     io = GvIOp(PL_stdingv);
3994     IoTYPE(io) = IoTYPE_RDONLY;
3995     IoIFP(io) = PerlIO_stdin();
3996     tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
3997     GvMULTI_on(tmpgv);
3998     GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
3999
4000     tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
4001     GvMULTI_on(tmpgv);
4002     io = GvIOp(tmpgv);
4003     IoTYPE(io) = IoTYPE_WRONLY;
4004     IoOFP(io) = IoIFP(io) = PerlIO_stdout();
4005     setdefout(tmpgv);
4006     tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
4007     GvMULTI_on(tmpgv);
4008     GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
4009
4010     PL_stderrgv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
4011     GvMULTI_on(PL_stderrgv);
4012     io = GvIOp(PL_stderrgv);
4013     IoTYPE(io) = IoTYPE_WRONLY;
4014     IoOFP(io) = IoIFP(io) = PerlIO_stderr();
4015     tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
4016     GvMULTI_on(tmpgv);
4017     GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
4018
4019     PL_statname = NEWSV(66,0);          /* last filename we did stat on */
4020
4021     if (PL_osname)
4022         Safefree(PL_osname);
4023     PL_osname = savepv(OSNAME);
4024 }
4025
4026 void
4027 Perl_init_argv_symbols(pTHX_ register int argc, register char **argv)
4028 {
4029     char *s;
4030     argc--,argv++;      /* skip name of script */
4031     if (PL_doswitches) {
4032         for (; argc > 0 && **argv == '-'; argc--,argv++) {
4033             if (!argv[0][1])
4034                 break;
4035             if (argv[0][1] == '-' && !argv[0][2]) {
4036                 argc--,argv++;
4037                 break;
4038             }
4039             if ((s = strchr(argv[0], '='))) {
4040                 *s++ = '\0';
4041                 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
4042             }
4043             else
4044                 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
4045         }
4046     }
4047     if ((PL_argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV))) {
4048         GvMULTI_on(PL_argvgv);
4049         (void)gv_AVadd(PL_argvgv);
4050         av_clear(GvAVn(PL_argvgv));
4051         for (; argc > 0; argc--,argv++) {
4052             SV *sv = newSVpv(argv[0],0);
4053             av_push(GvAVn(PL_argvgv),sv);
4054             if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) {
4055                  if (PL_unicode & PERL_UNICODE_ARGV_FLAG)
4056                       SvUTF8_on(sv);
4057             }
4058             if (PL_unicode & PERL_UNICODE_WIDESYSCALLS_FLAG) /* Sarathy? */
4059                  (void)sv_utf8_decode(sv);
4060         }
4061     }
4062 }
4063
4064 STATIC void
4065 S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env)
4066 {
4067     char *s;
4068     SV *sv;
4069     GV* tmpgv;
4070
4071     PL_toptarget = NEWSV(0,0);
4072     sv_upgrade(PL_toptarget, SVt_PVFM);
4073     sv_setpvn(PL_toptarget, "", 0);
4074     PL_bodytarget = NEWSV(0,0);
4075     sv_upgrade(PL_bodytarget, SVt_PVFM);
4076     sv_setpvn(PL_bodytarget, "", 0);
4077     PL_formtarget = PL_bodytarget;
4078
4079     TAINT;
4080
4081     init_argv_symbols(argc,argv);
4082
4083     if ((tmpgv = gv_fetchpv("0",TRUE, SVt_PV))) {
4084 #ifdef MACOS_TRADITIONAL
4085         /* $0 is not majick on a Mac */
4086         sv_setpv(GvSV(tmpgv),MacPerl_MPWFileName(PL_origfilename));
4087 #else
4088         sv_setpv(GvSV(tmpgv),PL_origfilename);
4089         magicname("0", "0", 1);
4090 #endif
4091     }
4092     if ((PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV))) {
4093         HV *hv;
4094         GvMULTI_on(PL_envgv);
4095         hv = GvHVn(PL_envgv);
4096         hv_magic(hv, Nullgv, PERL_MAGIC_env);
4097 #ifndef PERL_MICRO
4098 #ifdef USE_ENVIRON_ARRAY
4099         /* Note that if the supplied env parameter is actually a copy
4100            of the global environ then it may now point to free'd memory
4101            if the environment has been modified since. To avoid this
4102            problem we treat env==NULL as meaning 'use the default'
4103         */
4104         if (!env)
4105             env = environ;
4106         if (env != environ
4107 #  ifdef USE_ITHREADS
4108             && PL_curinterp == aTHX
4109 #  endif
4110            )
4111         {
4112             environ[0] = Nullch;
4113         }
4114         if (env) {
4115           char** origenv = environ;
4116           for (; *env; env++) {
4117             if (!(s = strchr(*env,'=')) || s == *env)
4118                 continue;
4119 #if defined(MSDOS) && !defined(DJGPP)
4120             *s = '\0';
4121             (void)strupr(*env);
4122             *s = '=';
4123 #endif
4124             sv = newSVpv(s+1, 0);
4125             (void)hv_store(hv, *env, s - *env, sv, 0);
4126             if (env != environ)
4127                 mg_set(sv);
4128             if (origenv != environ) {
4129               /* realloc has shifted us */
4130               env = (env - origenv) + environ;
4131               origenv = environ;
4132             }
4133           }
4134       }
4135 #endif /* USE_ENVIRON_ARRAY */
4136 #endif /* !PERL_MICRO */
4137     }
4138     TAINT_NOT;
4139     if ((tmpgv = gv_fetchpv("$",TRUE, SVt_PV))) {
4140         SvREADONLY_off(GvSV(tmpgv));
4141         sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
4142         SvREADONLY_on(GvSV(tmpgv));
4143     }
4144 #ifdef THREADS_HAVE_PIDS
4145     PL_ppid = (IV)getppid();
4146 #endif
4147
4148     /* touch @F array to prevent spurious warnings 20020415 MJD */
4149     if (PL_minus_a) {
4150       (void) get_av("main::F", TRUE | GV_ADDMULTI);
4151     }
4152     /* touch @- and @+ arrays to prevent spurious warnings 20020415 MJD */
4153     (void) get_av("main::-", TRUE | GV_ADDMULTI);
4154     (void) get_av("main::+", TRUE | GV_ADDMULTI);
4155 }
4156
4157 STATIC void
4158 S_init_perllib(pTHX)
4159 {
4160     char *s;
4161     if (!PL_tainting) {
4162 #ifndef VMS
4163         s = PerlEnv_getenv("PERL5LIB");
4164         if (s)
4165             incpush(s, TRUE, TRUE, TRUE, FALSE);
4166         else
4167             incpush(PerlEnv_getenv("PERLLIB"), FALSE, FALSE, TRUE, FALSE);
4168 #else /* VMS */
4169         /* Treat PERL5?LIB as a possible search list logical name -- the
4170          * "natural" VMS idiom for a Unix path string.  We allow each
4171          * element to be a set of |-separated directories for compatibility.
4172          */
4173         char buf[256];
4174         int idx = 0;
4175         if (my_trnlnm("PERL5LIB",buf,0))
4176             do { incpush(buf,TRUE,TRUE,TRUE,FALSE); } while (my_trnlnm("PERL5LIB",buf,++idx));
4177         else
4178             while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE,FALSE,TRUE,FALSE);
4179 #endif /* VMS */
4180     }
4181
4182 /* Use the ~-expanded versions of APPLLIB (undocumented),
4183     ARCHLIB PRIVLIB SITEARCH SITELIB VENDORARCH and VENDORLIB
4184 */
4185 #ifdef APPLLIB_EXP
4186     incpush(APPLLIB_EXP, TRUE, TRUE, TRUE, TRUE);
4187 #endif
4188
4189 #ifdef ARCHLIB_EXP
4190     incpush(ARCHLIB_EXP, FALSE, FALSE, TRUE, TRUE);
4191 #endif
4192 #ifdef MACOS_TRADITIONAL
4193     {
4194         Stat_t tmpstatbuf;
4195         SV * privdir = NEWSV(55, 0);
4196         char * macperl = PerlEnv_getenv("MACPERL");
4197
4198         if (!macperl)
4199             macperl = "";
4200
4201         Perl_sv_setpvf(aTHX_ privdir, "%slib:", macperl);
4202         if (PerlLIO_stat(SvPVX(privdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode))
4203             incpush(SvPVX(privdir), TRUE, FALSE, TRUE, FALSE);
4204         Perl_sv_setpvf(aTHX_ privdir, "%ssite_perl:", macperl);
4205         if (PerlLIO_stat(SvPVX(privdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode))
4206             incpush(SvPVX(privdir), TRUE, FALSE, TRUE, FALSE);
4207
4208         SvREFCNT_dec(privdir);
4209     }
4210     if (!PL_tainting)
4211         incpush(":", FALSE, FALSE, TRUE, FALSE);
4212 #else
4213 #ifndef PRIVLIB_EXP
4214 #  define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
4215 #endif
4216 #if defined(WIN32)
4217     incpush(PRIVLIB_EXP, TRUE, FALSE, TRUE, TRUE);
4218 #else
4219     incpush(PRIVLIB_EXP, FALSE, FALSE, TRUE, TRUE);
4220 #endif
4221
4222 #ifdef SITEARCH_EXP
4223     /* sitearch is always relative to sitelib on Windows for
4224      * DLL-based path intuition to work correctly */
4225 #  if !defined(WIN32)
4226     incpush(SITEARCH_EXP, FALSE, FALSE, TRUE, TRUE);
4227 #  endif
4228 #endif
4229
4230 #ifdef SITELIB_EXP
4231 #  if defined(WIN32)
4232     /* this picks up sitearch as well */
4233     incpush(SITELIB_EXP, TRUE, FALSE, TRUE, TRUE);
4234 #  else
4235     incpush(SITELIB_EXP, FALSE, FALSE, TRUE, TRUE);
4236 #  endif
4237 #endif
4238
4239 #ifdef SITELIB_STEM /* Search for version-specific dirs below here */
4240     incpush(SITELIB_STEM, FALSE, TRUE, TRUE, TRUE);
4241 #endif
4242
4243 #ifdef PERL_VENDORARCH_EXP
4244     /* vendorarch is always relative to vendorlib on Windows for
4245      * DLL-based path intuition to work correctly */
4246 #  if !defined(WIN32)
4247     incpush(PERL_VENDORARCH_EXP, FALSE, FALSE, TRUE, TRUE);
4248 #  endif
4249 #endif
4250
4251 #ifdef PERL_VENDORLIB_EXP
4252 #  if defined(WIN32)
4253     incpush(PERL_VENDORLIB_EXP, TRUE, FALSE, TRUE, TRUE);       /* this picks up vendorarch as well */
4254 #  else
4255     incpush(PERL_VENDORLIB_EXP, FALSE, FALSE, TRUE, TRUE);
4256 #  endif
4257 #endif
4258
4259 #ifdef PERL_VENDORLIB_STEM /* Search for version-specific dirs below here */
4260     incpush(PERL_VENDORLIB_STEM, FALSE, TRUE, TRUE, TRUE);
4261 #endif
4262
4263 #ifdef PERL_OTHERLIBDIRS
4264     incpush(PERL_OTHERLIBDIRS, TRUE, TRUE, TRUE, TRUE);
4265 #endif
4266
4267     if (!PL_tainting)
4268         incpush(".", FALSE, FALSE, TRUE, FALSE);
4269 #endif /* MACOS_TRADITIONAL */
4270 }
4271
4272 #if defined(DOSISH) || defined(EPOC)
4273 #    define PERLLIB_SEP ';'
4274 #else
4275 #  if defined(VMS)
4276 #    define PERLLIB_SEP '|'
4277 #  else
4278 #    if defined(MACOS_TRADITIONAL)
4279 #      define PERLLIB_SEP ','
4280 #    else
4281 #      define PERLLIB_SEP ':'
4282 #    endif
4283 #  endif
4284 #endif
4285 #ifndef PERLLIB_MANGLE
4286 #  define PERLLIB_MANGLE(s,n) (s)
4287 #endif
4288
4289 /* Push a directory onto @INC if it exists.
4290    Generate a new SV if we do this, to save needing to copy the SV we push
4291    onto @INC  */
4292 STATIC SV *
4293 S_incpush_if_exists(pTHX_ SV *dir)
4294 {
4295     Stat_t tmpstatbuf;
4296     if (PerlLIO_stat(SvPVX(dir), &tmpstatbuf) >= 0 &&
4297         S_ISDIR(tmpstatbuf.st_mode)) {
4298         av_push(GvAVn(PL_incgv), dir);
4299         dir = NEWSV(0,0);
4300     }
4301     return dir;
4302 }
4303
4304 STATIC void
4305 S_incpush(pTHX_ const char *dir, bool addsubdirs, bool addoldvers, bool usesep,
4306           bool canrelocate)
4307 {
4308     SV *subdir = Nullsv;
4309     const char *p = dir;
4310
4311     if (!p || !*p)
4312         return;
4313
4314     if (addsubdirs || addoldvers) {
4315         subdir = NEWSV(0,0);
4316     }
4317
4318     /* Break at all separators */
4319     while (p && *p) {
4320         SV *libdir = NEWSV(55,0);
4321         const char *s;
4322
4323         /* skip any consecutive separators */
4324         if (usesep) {
4325             while ( *p == PERLLIB_SEP ) {
4326                 /* Uncomment the next line for PATH semantics */
4327                 /* av_push(GvAVn(PL_incgv), newSVpvn(".", 1)); */
4328                 p++;
4329             }
4330         }
4331
4332         if ( usesep && (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
4333             sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
4334                       (STRLEN)(s - p));
4335             p = s + 1;
4336         }
4337         else {
4338             sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
4339             p = Nullch; /* break out */
4340         }
4341 #ifdef MACOS_TRADITIONAL
4342         if (!strchr(SvPVX(libdir), ':')) {
4343             char buf[256];
4344
4345             sv_setpv(libdir, MacPerl_CanonDir(SvPVX(libdir), buf, 0));
4346         }
4347         if (SvPVX(libdir)[SvCUR(libdir)-1] != ':')
4348             sv_catpv(libdir, ":");
4349 #endif
4350
4351         /* Do the if() outside the #ifdef to avoid warnings about an unused
4352            parameter.  */
4353         if (canrelocate) {
4354 #ifdef PERL_RELOCATABLE_INC
4355         /*
4356          * Relocatable include entries are marked with a leading .../
4357          *
4358          * The algorithm is
4359          * 0: Remove that leading ".../"
4360          * 1: Remove trailing executable name (anything after the last '/')
4361          *    from the perl path to give a perl prefix
4362          * Then
4363          * While the @INC element starts "../" and the prefix ends with a real
4364          * directory (ie not . or ..) chop that real directory off the prefix
4365          * and the leading "../" from the @INC element. ie a logical "../"
4366          * cleanup
4367          * Finally concatenate the prefix and the remainder of the @INC element
4368          * The intent is that /usr/local/bin/perl and .../../lib/perl5
4369          * generates /usr/local/lib/perl5
4370          */
4371             char *libpath = SvPVX(libdir);
4372             STRLEN libpath_len = SvCUR(libdir);
4373             if (libpath_len >= 4 && memEQ (libpath, ".../", 4)) {
4374                 /* Game on!  */
4375                 SV *caret_X = get_sv("\030", 0);
4376                 /* Going to use the SV just as a scratch buffer holding a C
4377                    string:  */
4378                 SV *prefix_sv;
4379                 char *prefix;
4380                 char *lastslash;
4381
4382                 /* $^X is *the* source of taint if tainting is on, hence
4383                    SvPOK() won't be true.  */
4384                 assert(caret_X);
4385                 assert(SvPOKp(caret_X));
4386                 prefix_sv = newSVpvn(SvPVX(caret_X), SvCUR(caret_X));
4387                 /* Firstly take off the leading .../
4388                    If all else fail we'll do the paths relative to the current
4389                    directory.  */
4390                 sv_chop(libdir, libpath + 4);
4391                 /* Don't use SvPV as we're intentionally bypassing taining,
4392                    mortal copies that the mg_get of tainting creates, and
4393                    corruption that seems to come via the save stack.
4394                    I guess that the save stack isn't correctly set up yet.  */
4395                 libpath = SvPVX(libdir);
4396                 libpath_len = SvCUR(libdir);
4397
4398                 /* This would work more efficiently with memrchr, but as it's
4399                    only a GNU extension we'd need to probe for it and
4400                    implement our own. Not hard, but maybe not worth it?  */
4401
4402                 prefix = SvPVX(prefix_sv);
4403                 lastslash = strrchr(prefix, '/');
4404
4405                 /* First time in with the *lastslash = '\0' we just wipe off
4406                    the trailing /perl from (say) /usr/foo/bin/perl
4407                 */
4408                 if (lastslash) {
4409                     SV *tempsv;
4410                     while ((*lastslash = '\0'), /* Do that, come what may.  */
4411                            (libpath_len >= 3 && memEQ(libpath, "../", 3)
4412                             && (lastslash = strrchr(prefix, '/')))) {
4413                         if (lastslash[1] == '\0'
4414                             || (lastslash[1] == '.'
4415                                 && (lastslash[2] == '/' /* ends "/."  */
4416                                     || (lastslash[2] == '/'
4417                                         && lastslash[3] == '/' /* or "/.."  */
4418                                         )))) {
4419                             /* Prefix ends "/" or "/." or "/..", any of which
4420                                are fishy, so don't do any more logical cleanup.
4421                             */
4422                             break;
4423                         }
4424                         /* Remove leading "../" from path  */
4425                         libpath += 3;
4426                         libpath_len -= 3;
4427                         /* Next iteration round the loop removes the last
4428                            directory name from prefix by writing a '\0' in
4429                            the while clause.  */
4430                     }
4431                     /* prefix has been terminated with a '\0' to the correct
4432                        length. libpath points somewhere into the libdir SV.
4433                        We need to join the 2 with '/' and drop the result into
4434                        libdir.  */
4435                     tempsv = Perl_newSVpvf(aTHX_ "%s/%s", prefix, libpath);
4436                     SvREFCNT_dec(libdir);
4437                     /* And this is the new libdir.  */
4438                     libdir = tempsv;
4439                     if (PL_tainting &&
4440                         (PL_uid != PL_euid || PL_gid != PL_egid)) {
4441                         /* Need to taint reloccated paths if running set ID  */
4442                         SvTAINTED_on(libdir);
4443                     }
4444                 }
4445                 SvREFCNT_dec(prefix_sv);
4446             }
4447 #endif
4448         }
4449         /*
4450          * BEFORE pushing libdir onto @INC we may first push version- and
4451          * archname-specific sub-directories.
4452          */
4453         if (addsubdirs || addoldvers) {
4454 #ifdef PERL_INC_VERSION_LIST
4455             /* Configure terminates PERL_INC_VERSION_LIST with a NULL */
4456             const char *incverlist[] = { PERL_INC_VERSION_LIST };
4457             const char **incver;
4458 #endif
4459 #ifdef VMS
4460             char *unix;
4461             STRLEN len;
4462
4463             if ((unix = tounixspec_ts(SvPV(libdir,len),Nullch)) != Nullch) {
4464                 len = strlen(unix);
4465                 while (unix[len-1] == '/') len--;  /* Cosmetic */
4466                 sv_usepvn(libdir,unix,len);
4467             }
4468             else
4469                 PerlIO_printf(Perl_error_log,
4470                               "Failed to unixify @INC element \"%s\"\n",
4471                               SvPV(libdir,len));
4472 #endif
4473             if (addsubdirs) {
4474 #ifdef MACOS_TRADITIONAL
4475 #define PERL_AV_SUFFIX_FMT      ""
4476 #define PERL_ARCH_FMT           "%s:"
4477 #define PERL_ARCH_FMT_PATH      PERL_FS_VER_FMT PERL_AV_SUFFIX_FMT
4478 #else
4479 #define PERL_AV_SUFFIX_FMT      "/"
4480 #define PERL_ARCH_FMT           "/%s"
4481 #define PERL_ARCH_FMT_PATH      PERL_AV_SUFFIX_FMT PERL_FS_VER_FMT
4482 #endif
4483                 /* .../version/archname if -d .../version/archname */
4484                 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT_PATH PERL_ARCH_FMT,
4485                                 libdir,
4486                                (int)PERL_REVISION, (int)PERL_VERSION,
4487                                (int)PERL_SUBVERSION, ARCHNAME);
4488                 subdir = S_incpush_if_exists(aTHX_ subdir);
4489
4490                 /* .../version if -d .../version */
4491                 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT_PATH, libdir,
4492                                (int)PERL_REVISION, (int)PERL_VERSION,
4493                                (int)PERL_SUBVERSION);
4494                 subdir = S_incpush_if_exists(aTHX_ subdir);
4495
4496                 /* .../archname if -d .../archname */
4497                 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT, libdir, ARCHNAME);
4498                 subdir = S_incpush_if_exists(aTHX_ subdir);
4499
4500             }
4501
4502 #ifdef PERL_INC_VERSION_LIST
4503             if (addoldvers) {
4504                 for (incver = incverlist; *incver; incver++) {
4505                     /* .../xxx if -d .../xxx */
4506                     Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT, libdir, *incver);
4507                     subdir = S_incpush_if_exists(aTHX_ subdir);
4508                 }
4509             }
4510 #endif
4511         }
4512
4513         /* finally push this lib directory on the end of @INC */
4514         av_push(GvAVn(PL_incgv), libdir);
4515     }
4516     if (subdir) {
4517         assert (SvREFCNT(subdir) == 1);
4518         SvREFCNT_dec(subdir);
4519     }
4520 }
4521
4522 #ifdef USE_5005THREADS
4523 STATIC struct perl_thread *
4524 S_init_main_thread(pTHX)
4525 {
4526 #if !defined(PERL_IMPLICIT_CONTEXT)
4527     struct perl_thread *thr;
4528 #endif
4529     XPV *xpv;
4530
4531     Newz(53, thr, 1, struct perl_thread);
4532     PL_curcop = &PL_compiling;
4533     thr->interp = PERL_GET_INTERP;
4534     thr->cvcache = newHV();
4535     thr->threadsv = newAV();
4536     /* thr->threadsvp is set when find_threadsv is called */
4537     thr->specific = newAV();
4538     thr->flags = THRf_R_JOINABLE;
4539     MUTEX_INIT(&thr->mutex);
4540     /* Handcraft thrsv similarly to mess_sv */
4541     New(53, PL_thrsv, 1, SV);
4542     Newz(53, xpv, 1, XPV);
4543     SvFLAGS(PL_thrsv) = SVt_PV;
4544     SvANY(PL_thrsv) = (void*)xpv;
4545     SvREFCNT(PL_thrsv) = 1 << 30;       /* practically infinite */
4546     SvPVX(PL_thrsv) = (char*)thr;
4547     SvCUR_set(PL_thrsv, sizeof(thr));
4548     SvLEN_set(PL_thrsv, sizeof(thr));
4549     *SvEND(PL_thrsv) = '\0';    /* in the trailing_nul field */
4550     thr->oursv = PL_thrsv;
4551     PL_chopset = " \n-";
4552     PL_dumpindent = 4;
4553
4554     MUTEX_LOCK(&PL_threads_mutex);
4555     PL_nthreads++;
4556     thr->tid = 0;
4557     thr->next = thr;
4558     thr->prev = thr;
4559     thr->thr_done = 0;
4560     MUTEX_UNLOCK(&PL_threads_mutex);
4561
4562 #ifdef HAVE_THREAD_INTERN
4563     Perl_init_thread_intern(thr);
4564 #endif
4565
4566 #ifdef SET_THREAD_SELF
4567     SET_THREAD_SELF(thr);
4568 #else
4569     thr->self = pthread_self();
4570 #endif /* SET_THREAD_SELF */
4571     PERL_SET_THX(thr);
4572
4573     /*
4574      * These must come after the thread self setting
4575      * because sv_setpvn does SvTAINT and the taint
4576      * fields thread selfness being set.
4577      */
4578     PL_toptarget = NEWSV(0,0);
4579     sv_upgrade(PL_toptarget, SVt_PVFM);
4580     sv_setpvn(PL_toptarget, "", 0);
4581     PL_bodytarget = NEWSV(0,0);
4582     sv_upgrade(PL_bodytarget, SVt_PVFM);
4583     sv_setpvn(PL_bodytarget, "", 0);
4584     PL_formtarget = PL_bodytarget;
4585     thr->errsv = newSVpvn("", 0);
4586     (void) find_threadsv("@");  /* Ensure $@ is initialised early */
4587
4588     PL_maxscream = -1;
4589     PL_peepp = MEMBER_TO_FPTR(Perl_peep);
4590     PL_regcompp = MEMBER_TO_FPTR(Perl_pregcomp);
4591     PL_regexecp = MEMBER_TO_FPTR(Perl_regexec_flags);
4592     PL_regint_start = MEMBER_TO_FPTR(Perl_re_intuit_start);
4593     PL_regint_string = MEMBER_TO_FPTR(Perl_re_intuit_string);
4594     PL_regfree = MEMBER_TO_FPTR(Perl_pregfree);
4595     PL_regindent = 0;
4596     PL_reginterp_cnt = 0;
4597
4598     return thr;
4599 }
4600 #endif /* USE_5005THREADS */
4601
4602 void
4603 Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
4604 {
4605     SV *atsv;
4606     const line_t oldline = CopLINE(PL_curcop);
4607     CV *cv;
4608     STRLEN len;
4609     int ret;
4610     dJMPENV;
4611
4612     while (av_len(paramList) >= 0) {
4613         cv = (CV*)av_shift(paramList);
4614         if (PL_savebegin) {
4615             if (paramList == PL_beginav) {
4616                 /* save PL_beginav for compiler */
4617                 if (! PL_beginav_save)
4618                     PL_beginav_save = newAV();
4619                 av_push(PL_beginav_save, (SV*)cv);
4620             }
4621             else if (paramList == PL_checkav) {
4622                 /* save PL_checkav for compiler */
4623                 if (! PL_checkav_save)
4624                     PL_checkav_save = newAV();
4625                 av_push(PL_checkav_save, (SV*)cv);
4626             }
4627         } else {
4628             SAVEFREESV(cv);
4629         }
4630         JMPENV_PUSH(ret);
4631         switch (ret) {
4632         case 0:
4633             call_list_body(cv);
4634             atsv = ERRSV;
4635             (void)SvPV(atsv, len);
4636             if (len) {
4637                 PL_curcop = &PL_compiling;
4638                 CopLINE_set(PL_curcop, oldline);
4639                 if (paramList == PL_beginav)
4640                     sv_catpv(atsv, "BEGIN failed--compilation aborted");
4641                 else
4642                     Perl_sv_catpvf(aTHX_ atsv,
4643                                    "%s failed--call queue aborted",
4644                                    paramList == PL_checkav ? "CHECK"
4645                                    : paramList == PL_initav ? "INIT"
4646                                    : "END");
4647                 while (PL_scopestack_ix > oldscope)
4648                     LEAVE;
4649                 JMPENV_POP;
4650                 Perl_croak(aTHX_ "%"SVf"", atsv);
4651             }
4652             break;
4653         case 1:
4654             STATUS_ALL_FAILURE;
4655             /* FALL THROUGH */
4656         case 2:
4657             /* my_exit() was called */
4658             while (PL_scopestack_ix > oldscope)
4659                 LEAVE;
4660             FREETMPS;
4661             PL_curstash = PL_defstash;
4662             PL_curcop = &PL_compiling;
4663             CopLINE_set(PL_curcop, oldline);
4664             JMPENV_POP;
4665             if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED)) {
4666                 if (paramList == PL_beginav)
4667                     Perl_croak(aTHX_ "BEGIN failed--compilation aborted");
4668                 else
4669                     Perl_croak(aTHX_ "%s failed--call queue aborted",
4670                                paramList == PL_checkav ? "CHECK"
4671                                : paramList == PL_initav ? "INIT"
4672                                : "END");
4673             }
4674             my_exit_jump();
4675             /* NOTREACHED */
4676         case 3:
4677             if (PL_restartop) {
4678                 PL_curcop = &PL_compiling;
4679                 CopLINE_set(PL_curcop, oldline);
4680                 JMPENV_JUMP(3);
4681             }
4682             PerlIO_printf(Perl_error_log, "panic: restartop\n");
4683             FREETMPS;
4684             break;
4685         }
4686         JMPENV_POP;
4687     }
4688 }
4689
4690 STATIC void *
4691 S_call_list_body(pTHX_ CV *cv)
4692 {
4693     PUSHMARK(PL_stack_sp);
4694     call_sv((SV*)cv, G_EVAL|G_DISCARD);
4695     return NULL;
4696 }
4697
4698 void
4699 Perl_my_exit(pTHX_ U32 status)
4700 {
4701     DEBUG_S(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
4702                           thr, (unsigned long) status));
4703     switch (status) {
4704     case 0:
4705         STATUS_ALL_SUCCESS;
4706         break;
4707     case 1:
4708         STATUS_ALL_FAILURE;
4709         break;
4710     default:
4711         STATUS_NATIVE_SET(status);
4712         break;
4713     }
4714     my_exit_jump();
4715 }
4716
4717 void
4718 Perl_my_failure_exit(pTHX)
4719 {
4720 #ifdef VMS
4721     if (vaxc$errno & 1) {
4722         if (STATUS_NATIVE & 1)          /* fortuitiously includes "-1" */
4723             STATUS_NATIVE_SET(44);
4724     }
4725     else {
4726         if (!vaxc$errno)                /* unlikely */
4727             STATUS_NATIVE_SET(44);
4728         else
4729             STATUS_NATIVE_SET(vaxc$errno);
4730     }
4731 #else
4732     int exitstatus;
4733     if (errno & 255)
4734         STATUS_POSIX_SET(errno);
4735     else {
4736         exitstatus = STATUS_POSIX >> 8;
4737         if (exitstatus & 255)
4738             STATUS_POSIX_SET(exitstatus);
4739         else
4740             STATUS_POSIX_SET(255);
4741     }
4742 #endif
4743     my_exit_jump();
4744 }
4745
4746 STATIC void
4747 S_my_exit_jump(pTHX)
4748 {
4749     register PERL_CONTEXT *cx;
4750     I32 gimme;
4751     SV **newsp;
4752
4753     if (PL_e_script) {
4754         SvREFCNT_dec(PL_e_script);
4755         PL_e_script = Nullsv;
4756     }
4757
4758     POPSTACK_TO(PL_mainstack);
4759     if (cxstack_ix >= 0) {
4760         if (cxstack_ix > 0)
4761             dounwind(0);
4762         POPBLOCK(cx,PL_curpm);
4763         LEAVE;
4764     }
4765
4766     JMPENV_JUMP(2);
4767 }
4768
4769 static I32
4770 read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen)
4771 {
4772     char *p, *nl;
4773     (void)idx;
4774     (void)maxlen;
4775
4776     p  = SvPVX(PL_e_script);
4777     nl = strchr(p, '\n');
4778     nl = (nl) ? nl+1 : SvEND(PL_e_script);
4779     if (nl-p == 0) {
4780         filter_del(read_e_script);
4781         return 0;
4782     }
4783     sv_catpvn(buf_sv, p, nl-p);
4784     sv_chop(PL_e_script, nl);
4785     return 1;
4786 }