perl.c

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