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