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