perl.c

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