perl.c

   1 #line 2 "perl.c"
   2 /*    perl.c
   3  *
   4  *    Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001
   5  *    2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012
   6  *     by Larry Wall and others
   7  *
   8  *    You may distribute under the terms of either the GNU General Public
   9  *    License or the Artistic License, as specified in the README file.
  10  *
  11  */
  12
  13 /*
  14  *      A ship then new they built for him
  15  *      of mithril and of elven-glass
  16  *              --from Bilbo's song of Eärendil
  17  *
  18  *     [p.236 of _The Lord of the Rings_, II/i: "Many Meetings"]
  19  */
  20
  21 /* This file contains the top-level functions that are used to create, use
  22  * and destroy a perl interpreter, plus the functions used by XS code to
  23  * call back into perl. Note that it does not contain the actual main()
  24  * function of the interpreter; that can be found in perlmain.c
  25  */
  26
  27 #if defined(PERL_IS_MINIPERL) && !defined(USE_SITECUSTOMIZE)
  28 #  define USE_SITECUSTOMIZE
  29 #endif
  30
  31 #include "EXTERN.h"
  32 #define PERL_IN_PERL_C
  33 #include "perl.h"
  34 #include "patchlevel.h"                 /* for local_patches */
  35 #include "XSUB.h"
  36 #include "charclass_invlists.h"
  37
  38 #ifdef NETWARE
  39 #include "nwutil.h"
  40 #endif
  41
  42 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
  43 #  ifdef I_SYSUIO
  44 #    include <sys/uio.h>
  45 #  endif
  46
  47 union control_un {
  48   struct cmsghdr cm;
  49   char control[CMSG_SPACE(sizeof(int))];
  50 };
  51
  52 #endif
  53
  54 #ifndef HZ
  55 #  ifdef CLK_TCK
  56 #    define HZ CLK_TCK
  57 #  else
  58 #    define HZ 60
  59 #  endif
  60 #endif
  61
  62 #if !defined(STANDARD_C) && !defined(HAS_GETENV_PROTOTYPE) && !defined(PERL_MICRO)
  63 char *getenv (char *); /* Usually in <stdlib.h> */
  64 #endif
  65
  66 static I32 read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen);
  67
  68 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
  69 #  define validate_suid(rsfp) NOOP
  70 #else
  71 #  define validate_suid(rsfp) S_validate_suid(aTHX_ rsfp)
  72 #endif
  73
  74 #define CALL_BODY_SUB(myop) \
  75     if (PL_op == (myop)) \
  76         PL_op = PL_ppaddr[OP_ENTERSUB](aTHX); \
  77     if (PL_op) \
  78         CALLRUNOPS(aTHX);
  79
  80 #define CALL_LIST_BODY(cv) \
  81     PUSHMARK(PL_stack_sp); \
  82     call_sv(MUTABLE_SV((cv)), G_EVAL|G_DISCARD|G_VOID);
  83
  84 static void
  85 S_init_tls_and_interp(PerlInterpreter *my_perl)
  86 {
  87     dVAR;
  88     if (!PL_curinterp) {
  89         PERL_SET_INTERP(my_perl);
  90 #if defined(USE_ITHREADS)
  91         INIT_THREADS;
  92         ALLOC_THREAD_KEY;
  93         PERL_SET_THX(my_perl);
  94         OP_REFCNT_INIT;
  95         OP_CHECK_MUTEX_INIT;
  96         HINTS_REFCNT_INIT;
  97         MUTEX_INIT(&PL_dollarzero_mutex);
  98         MUTEX_INIT(&PL_my_ctx_mutex);
  99 #  endif
 100     }
 101 #if defined(USE_ITHREADS)
 102     else
 103 #else
 104     /* This always happens for non-ithreads  */
 105 #endif
 106     {
 107         PERL_SET_THX(my_perl);
 108     }
 109 }
 110
 111
 112 /* these implement the PERL_SYS_INIT, PERL_SYS_INIT3, PERL_SYS_TERM macros */
 113
 114 void
 115 Perl_sys_init(int* argc, char*** argv)
 116 {
 117     dVAR;
 118
 119     PERL_ARGS_ASSERT_SYS_INIT;
 120
 121     PERL_UNUSED_ARG(argc); /* may not be used depending on _BODY macro */
 122     PERL_UNUSED_ARG(argv);
 123     PERL_SYS_INIT_BODY(argc, argv);
 124 }
 125
 126 void
 127 Perl_sys_init3(int* argc, char*** argv, char*** env)
 128 {
 129     dVAR;
 130
 131     PERL_ARGS_ASSERT_SYS_INIT3;
 132
 133     PERL_UNUSED_ARG(argc); /* may not be used depending on _BODY macro */
 134     PERL_UNUSED_ARG(argv);
 135     PERL_UNUSED_ARG(env);
 136     PERL_SYS_INIT3_BODY(argc, argv, env);
 137 }
 138
 139 void
 140 Perl_sys_term(void)
 141 {
 142     dVAR;
 143     if (!PL_veto_cleanup) {
 144         PERL_SYS_TERM_BODY();
 145     }
 146 }
 147
 148
 149 #ifdef PERL_IMPLICIT_SYS
 150 PerlInterpreter *
 151 perl_alloc_using(struct IPerlMem* ipM, struct IPerlMem* ipMS,
 152                  struct IPerlMem* ipMP, struct IPerlEnv* ipE,
 153                  struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
 154                  struct IPerlDir* ipD, struct IPerlSock* ipS,
 155                  struct IPerlProc* ipP)
 156 {
 157     PerlInterpreter *my_perl;
 158
 159     PERL_ARGS_ASSERT_PERL_ALLOC_USING;
 160
 161     /* Newx() needs interpreter, so call malloc() instead */
 162     my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
 163     S_init_tls_and_interp(my_perl);
 164     Zero(my_perl, 1, PerlInterpreter);
 165     PL_Mem = ipM;
 166     PL_MemShared = ipMS;
 167     PL_MemParse = ipMP;
 168     PL_Env = ipE;
 169     PL_StdIO = ipStd;
 170     PL_LIO = ipLIO;
 171     PL_Dir = ipD;
 172     PL_Sock = ipS;
 173     PL_Proc = ipP;
 174     INIT_TRACK_MEMPOOL(PL_memory_debug_header, my_perl);
 175
 176     return my_perl;
 177 }
 178 #else
 179
 180 /*
 181 =head1 Embedding Functions
 182
 183 =for apidoc perl_alloc
 184
 185 Allocates a new Perl interpreter.  See L<perlembed>.
 186
 187 =cut
 188 */
 189
 190 PerlInterpreter *
 191 perl_alloc(void)
 192 {
 193     PerlInterpreter *my_perl;
 194
 195     /* Newx() needs interpreter, so call malloc() instead */
 196     my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
 197
 198     S_init_tls_and_interp(my_perl);
 199 #ifndef PERL_TRACK_MEMPOOL
 200     return (PerlInterpreter *) ZeroD(my_perl, 1, PerlInterpreter);
 201 #else
 202     Zero(my_perl, 1, PerlInterpreter);
 203     INIT_TRACK_MEMPOOL(PL_memory_debug_header, my_perl);
 204     return my_perl;
 205 #endif
 206 }
 207 #endif /* PERL_IMPLICIT_SYS */
 208
 209 /*
 210 =for apidoc perl_construct
 211
 212 Initializes a new Perl interpreter.  See L<perlembed>.
 213
 214 =cut
 215 */
 216
 217 void
 218 perl_construct(pTHXx)
 219 {
 220     dVAR;
 221
 222     PERL_ARGS_ASSERT_PERL_CONSTRUCT;
 223
 224 #ifdef MULTIPLICITY
 225     init_interp();
 226     PL_perl_destruct_level = 1;
 227 #else
 228     PERL_UNUSED_ARG(my_perl);
 229    if (PL_perl_destruct_level > 0)
 230        init_interp();
 231 #endif
 232     PL_curcop = &PL_compiling;  /* needed by ckWARN, right away */
 233
 234 #ifdef PERL_TRACE_OPS
 235     Zero(PL_op_exec_cnt, OP_max+2, UV);
 236 #endif
 237
 238     init_constants();
 239
 240     SvREADONLY_on(&PL_sv_placeholder);
 241     SvREFCNT(&PL_sv_placeholder) = SvREFCNT_IMMORTAL;
 242
 243     PL_sighandlerp = (Sighandler_t) Perl_sighandler;
 244 #ifdef PERL_USES_PL_PIDSTATUS
 245     PL_pidstatus = newHV();
 246 #endif
 247
 248     PL_rs = newSVpvs("\n");
 249
 250     init_stacks();
 251
 252     init_ids();
 253
 254     JMPENV_BOOTSTRAP;
 255     STATUS_ALL_SUCCESS;
 256
 257     init_i18nl10n(1);
 258
 259 #if defined(LOCAL_PATCH_COUNT)
 260     PL_localpatches = local_patches;    /* For possible -v */
 261 #endif
 262
 263 #ifdef HAVE_INTERP_INTERN
 264     sys_intern_init();
 265 #endif
 266
 267     PerlIO_init(aTHX);                  /* Hook to IO system */
 268
 269     PL_fdpid = newAV();                 /* for remembering popen pids by fd */
 270     PL_modglobal = newHV();             /* pointers to per-interpreter module globals */
 271     PL_errors = newSVpvs("");
 272     sv_setpvs(PERL_DEBUG_PAD(0), "");   /* For regex debugging. */
 273     sv_setpvs(PERL_DEBUG_PAD(1), "");   /* ext/re needs these */
 274     sv_setpvs(PERL_DEBUG_PAD(2), "");   /* even without DEBUGGING. */
 275 #ifdef USE_ITHREADS
 276     /* First entry is a list of empty elements. It needs to be initialised
 277        else all hell breaks loose in S_find_uninit_var().  */
 278     Perl_av_create_and_push(aTHX_ &PL_regex_padav, newSVpvs(""));
 279     PL_regex_pad = AvARRAY(PL_regex_padav);
 280     Newxz(PL_stashpad, PL_stashpadmax, HV *);
 281 #endif
 282 #ifdef USE_REENTRANT_API
 283     Perl_reentrant_init(aTHX);
 284 #endif
 285 #if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT)
 286         /* [perl #22371] Algorimic Complexity Attack on Perl 5.6.1, 5.8.0
 287          * This MUST be done before any hash stores or fetches take place.
 288          * If you set PL_hash_seed (and presumably also PL_hash_seed_set)
 289          * yourself, it is your responsibility to provide a good random seed!
 290          * You can also define PERL_HASH_SEED in compile time, see hv.h.
 291          *
 292          * XXX: fix this comment */
 293     if (PL_hash_seed_set == FALSE) {
 294         Perl_get_hash_seed(aTHX_ PL_hash_seed);
 295         PL_hash_seed_set= TRUE;
 296     }
 297 #endif /* #if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT) */
 298
 299     /* Note that strtab is a rather special HV.  Assumptions are made
 300        about not iterating on it, and not adding tie magic to it.
 301        It is properly deallocated in perl_destruct() */
 302     PL_strtab = newHV();
 303
 304     HvSHAREKEYS_off(PL_strtab);                 /* mandatory */
 305     hv_ksplit(PL_strtab, 512);
 306
 307     Zero(PL_sv_consts, SV_CONSTS_COUNT, SV*);
 308
 309 #ifndef PERL_MICRO
 310 #   ifdef  USE_ENVIRON_ARRAY
 311     PL_origenviron = environ;
 312 #   endif
 313 #endif
 314
 315     /* Use sysconf(_SC_CLK_TCK) if available, if not
 316      * available or if the sysconf() fails, use the HZ.
 317      * The HZ if not originally defined has been by now
 318      * been defined as CLK_TCK, if available. */
 319 #if defined(HAS_SYSCONF) && defined(_SC_CLK_TCK)
 320     PL_clocktick = sysconf(_SC_CLK_TCK);
 321     if (PL_clocktick <= 0)
 322 #endif
 323          PL_clocktick = HZ;
 324
 325     PL_stashcache = newHV();
 326
 327     PL_patchlevel = newSVpvs("v" PERL_VERSION_STRING);
 328     PL_apiversion = newSVpvs("v" PERL_API_VERSION_STRING);
 329
 330 #ifdef HAS_MMAP
 331     if (!PL_mmap_page_size) {
 332 #if defined(HAS_SYSCONF) && (defined(_SC_PAGESIZE) || defined(_SC_MMAP_PAGE_SIZE))
 333       {
 334         SETERRNO(0, SS_NORMAL);
 335 #   ifdef _SC_PAGESIZE
 336         PL_mmap_page_size = sysconf(_SC_PAGESIZE);
 337 #   else
 338         PL_mmap_page_size = sysconf(_SC_MMAP_PAGE_SIZE);
 339 #   endif
 340         if ((long) PL_mmap_page_size < 0) {
 341           if (errno) {
 342             SV * const error = ERRSV;
 343             SvUPGRADE(error, SVt_PV);
 344             Perl_croak(aTHX_ "panic: sysconf: %s", SvPV_nolen_const(error));
 345           }
 346           else
 347             Perl_croak(aTHX_ "panic: sysconf: pagesize unknown");
 348         }
 349       }
 350 #else
 351 #   ifdef HAS_GETPAGESIZE
 352       PL_mmap_page_size = getpagesize();
 353 #   else
 354 #       if defined(I_SYS_PARAM) && defined(PAGESIZE)
 355       PL_mmap_page_size = PAGESIZE;       /* compiletime, bad */
 356 #       endif
 357 #   endif
 358 #endif
 359       if (PL_mmap_page_size <= 0)
 360         Perl_croak(aTHX_ "panic: bad pagesize %" IVdf,
 361                    (IV) PL_mmap_page_size);
 362     }
 363 #endif /* HAS_MMAP */
 364
 365 #if defined(HAS_TIMES) && defined(PERL_NEED_TIMESBASE)
 366     PL_timesbase.tms_utime  = 0;
 367     PL_timesbase.tms_stime  = 0;
 368     PL_timesbase.tms_cutime = 0;
 369     PL_timesbase.tms_cstime = 0;
 370 #endif
 371
 372     PL_osname = Perl_savepvn(aTHX_ STR_WITH_LEN(OSNAME));
 373
 374     PL_registered_mros = newHV();
 375     /* Start with 1 bucket, for DFS.  It's unlikely we'll need more.  */
 376     HvMAX(PL_registered_mros) = 0;
 377
 378     PL_XPosix_ptrs[_CC_ASCII] = _new_invlist_C_array(ASCII_invlist);
 379     PL_XPosix_ptrs[_CC_ALPHANUMERIC] = _new_invlist_C_array(XPosixAlnum_invlist);
 380     PL_XPosix_ptrs[_CC_ALPHA] = _new_invlist_C_array(XPosixAlpha_invlist);
 381     PL_XPosix_ptrs[_CC_BLANK] = _new_invlist_C_array(XPosixBlank_invlist);
 382     PL_XPosix_ptrs[_CC_CASED] =  _new_invlist_C_array(Cased_invlist);
 383     PL_XPosix_ptrs[_CC_CNTRL] = _new_invlist_C_array(XPosixCntrl_invlist);
 384     PL_XPosix_ptrs[_CC_DIGIT] = _new_invlist_C_array(XPosixDigit_invlist);
 385     PL_XPosix_ptrs[_CC_GRAPH] = _new_invlist_C_array(XPosixGraph_invlist);
 386     PL_XPosix_ptrs[_CC_LOWER] = _new_invlist_C_array(XPosixLower_invlist);
 387     PL_XPosix_ptrs[_CC_PRINT] = _new_invlist_C_array(XPosixPrint_invlist);
 388     PL_XPosix_ptrs[_CC_PUNCT] = _new_invlist_C_array(XPosixPunct_invlist);
 389     PL_XPosix_ptrs[_CC_SPACE] = _new_invlist_C_array(XPerlSpace_invlist);
 390     PL_XPosix_ptrs[_CC_PSXSPC] = _new_invlist_C_array(XPosixSpace_invlist);
 391     PL_XPosix_ptrs[_CC_UPPER] = _new_invlist_C_array(XPosixUpper_invlist);
 392     PL_XPosix_ptrs[_CC_VERTSPACE] = _new_invlist_C_array(VertSpace_invlist);
 393     PL_XPosix_ptrs[_CC_WORDCHAR] = _new_invlist_C_array(XPosixWord_invlist);
 394     PL_XPosix_ptrs[_CC_XDIGIT] = _new_invlist_C_array(XPosixXDigit_invlist);
 395
 396     ENTER;
 397 }
 398
 399 /*
 400 =for apidoc nothreadhook
 401
 402 Stub that provides thread hook for perl_destruct when there are
 403 no threads.
 404
 405 =cut
 406 */
 407
 408 int
 409 Perl_nothreadhook(pTHX)
 410 {
 411     PERL_UNUSED_CONTEXT;
 412     return 0;
 413 }
 414
 415 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
 416 void
 417 Perl_dump_sv_child(pTHX_ SV *sv)
 418 {
 419     ssize_t got;
 420     const int sock = PL_dumper_fd;
 421     const int debug_fd = PerlIO_fileno(Perl_debug_log);
 422     union control_un control;
 423     struct msghdr msg;
 424     struct iovec vec[2];
 425     struct cmsghdr *cmptr;
 426     int returned_errno;
 427     unsigned char buffer[256];
 428
 429     PERL_ARGS_ASSERT_DUMP_SV_CHILD;
 430
 431     if(sock == -1 || debug_fd == -1)
 432         return;
 433
 434     PerlIO_flush(Perl_debug_log);
 435
 436     /* All these shenanigans are to pass a file descriptor over to our child for
 437        it to dump out to.  We can't let it hold open the file descriptor when it
 438        forks, as the file descriptor it will dump to can turn out to be one end
 439        of pipe that some other process will wait on for EOF. (So as it would
 440        be open, the wait would be forever.)  */
 441
 442     msg.msg_control = control.control;
 443     msg.msg_controllen = sizeof(control.control);
 444     /* We're a connected socket so we don't need a destination  */
 445     msg.msg_name = NULL;
 446     msg.msg_namelen = 0;
 447     msg.msg_iov = vec;
 448     msg.msg_iovlen = 1;
 449
 450     cmptr = CMSG_FIRSTHDR(&msg);
 451     cmptr->cmsg_len = CMSG_LEN(sizeof(int));
 452     cmptr->cmsg_level = SOL_SOCKET;
 453     cmptr->cmsg_type = SCM_RIGHTS;
 454     *((int *)CMSG_DATA(cmptr)) = 1;
 455
 456     vec[0].iov_base = (void*)&sv;
 457     vec[0].iov_len = sizeof(sv);
 458     got = sendmsg(sock, &msg, 0);
 459
 460     if(got < 0) {
 461         perror("Debug leaking scalars parent sendmsg failed");
 462         abort();
 463     }
 464     if(got < sizeof(sv)) {
 465         perror("Debug leaking scalars parent short sendmsg");
 466         abort();
 467     }
 468
 469     /* Return protocol is
 470        int:             errno value
 471        unsigned char:   length of location string (0 for empty)
 472        unsigned char*:  string (not terminated)
 473     */
 474     vec[0].iov_base = (void*)&returned_errno;
 475     vec[0].iov_len = sizeof(returned_errno);
 476     vec[1].iov_base = buffer;
 477     vec[1].iov_len = 1;
 478
 479     got = readv(sock, vec, 2);
 480
 481     if(got < 0) {
 482         perror("Debug leaking scalars parent read failed");
 483         PerlIO_flush(PerlIO_stderr());
 484         abort();
 485     }
 486     if(got < sizeof(returned_errno) + 1) {
 487         perror("Debug leaking scalars parent short read");
 488         PerlIO_flush(PerlIO_stderr());
 489         abort();
 490     }
 491
 492     if (*buffer) {
 493         got = read(sock, buffer + 1, *buffer);
 494         if(got < 0) {
 495             perror("Debug leaking scalars parent read 2 failed");
 496             PerlIO_flush(PerlIO_stderr());
 497             abort();
 498         }
 499
 500         if(got < *buffer) {
 501             perror("Debug leaking scalars parent short read 2");
 502             PerlIO_flush(PerlIO_stderr());
 503             abort();
 504         }
 505     }
 506
 507     if (returned_errno || *buffer) {
 508         Perl_warn(aTHX_ "Debug leaking scalars child failed%s%.*s with errno"
 509                   " %d: %s", (*buffer ? " at " : ""), (int) *buffer, buffer + 1,
 510                   returned_errno, Strerror(returned_errno));
 511     }
 512 }
 513 #endif
 514
 515 /*
 516 =for apidoc perl_destruct
 517
 518 Shuts down a Perl interpreter.  See L<perlembed>.
 519
 520 =cut
 521 */
 522
 523 int
 524 perl_destruct(pTHXx)
 525 {
 526     dVAR;
 527     VOL signed char destruct_level;  /* see possible values in intrpvar.h */
 528     HV *hv;
 529 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
 530     pid_t child;
 531 #endif
 532     int i;
 533
 534     PERL_ARGS_ASSERT_PERL_DESTRUCT;
 535 #ifndef MULTIPLICITY
 536     PERL_UNUSED_ARG(my_perl);
 537 #endif
 538
 539     assert(PL_scopestack_ix == 1);
 540
 541     /* wait for all pseudo-forked children to finish */
 542     PERL_WAIT_FOR_CHILDREN;
 543
 544     destruct_level = PL_perl_destruct_level;
 545 #if defined(DEBUGGING) || defined(PERL_TRACK_MEMPOOL)
 546     {
 547         const char * const s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL");
 548         if (s) {
 549             int i;
 550             if (strEQ(s, "-1")) { /* Special case: modperl folklore. */
 551                 i = -1;
 552             } else {
 553                 i = grok_atou(s, NULL);
 554             }
 555 #ifdef DEBUGGING
 556             if (destruct_level < i) destruct_level = i;
 557 #endif
 558 #ifdef PERL_TRACK_MEMPOOL
 559             /* RT #114496, for perl_free */
 560             PL_perl_destruct_level = i;
 561 #endif
 562         }
 563     }
 564 #endif
 565
 566     if (PL_exit_flags & PERL_EXIT_DESTRUCT_END) {
 567         dJMPENV;
 568         int x = 0;
 569
 570         JMPENV_PUSH(x);
 571         PERL_UNUSED_VAR(x);
 572         if (PL_endav && !PL_minus_c) {
 573             PERL_SET_PHASE(PERL_PHASE_END);
 574             call_list(PL_scopestack_ix, PL_endav);
 575         }
 576         JMPENV_POP;
 577     }
 578     LEAVE;
 579     FREETMPS;
 580     assert(PL_scopestack_ix == 0);
 581
 582     /* Need to flush since END blocks can produce output */
 583     my_fflush_all();
 584
 585 #ifdef PERL_TRACE_OPS
 586     /* If we traced all Perl OP usage, report and clean up */
 587     PerlIO_printf(Perl_debug_log, "Trace of all OPs executed:\n");
 588     for (i = 0; i <= OP_max; ++i) {
 589         PerlIO_printf(Perl_debug_log, "  %s: %"UVuf"\n", PL_op_name[i], PL_op_exec_cnt[i]);
 590         PL_op_exec_cnt[i] = 0;
 591     }
 592     /* Utility slot for easily doing little tracing experiments in the runloop: */
 593     if (PL_op_exec_cnt[OP_max+1] != 0)
 594         PerlIO_printf(Perl_debug_log, "  SPECIAL: %"UVuf"\n", PL_op_exec_cnt[OP_max+1]);
 595     PerlIO_printf(Perl_debug_log, "\n");
 596 #endif
 597
 598
 599     if (PL_threadhook(aTHX)) {
 600         /* Threads hook has vetoed further cleanup */
 601         PL_veto_cleanup = TRUE;
 602         return STATUS_EXIT;
 603     }
 604
 605 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
 606     if (destruct_level != 0) {
 607         /* Fork here to create a child. Our child's job is to preserve the
 608            state of scalars prior to destruction, so that we can instruct it
 609            to dump any scalars that we later find have leaked.
 610            There's no subtlety in this code - it assumes POSIX, and it doesn't
 611            fail gracefully  */
 612         int fd[2];
 613
 614         if(socketpair(AF_UNIX, SOCK_STREAM, 0, fd)) {
 615             perror("Debug leaking scalars socketpair failed");
 616             abort();
 617         }
 618
 619         child = fork();
 620         if(child == -1) {
 621             perror("Debug leaking scalars fork failed");
 622             abort();
 623         }
 624         if (!child) {
 625             /* We are the child */
 626             const int sock = fd[1];
 627             const int debug_fd = PerlIO_fileno(Perl_debug_log);
 628             int f;
 629             const char *where;
 630             /* Our success message is an integer 0, and a char 0  */
 631             static const char success[sizeof(int) + 1] = {0};
 632
 633             close(fd[0]);
 634
 635             /* We need to close all other file descriptors otherwise we end up
 636                with interesting hangs, where the parent closes its end of a
 637                pipe, and sits waiting for (another) child to terminate. Only
 638                that child never terminates, because it never gets EOF, because
 639                we also have the far end of the pipe open.  We even need to
 640                close the debugging fd, because sometimes it happens to be one
 641                end of a pipe, and a process is waiting on the other end for
 642                EOF. Normally it would be closed at some point earlier in
 643                destruction, but if we happen to cause the pipe to remain open,
 644                EOF never occurs, and we get an infinite hang. Hence all the
 645                games to pass in a file descriptor if it's actually needed.  */
 646
 647             f = sysconf(_SC_OPEN_MAX);
 648             if(f < 0) {
 649                 where = "sysconf failed";
 650                 goto abort;
 651             }
 652             while (f--) {
 653                 if (f == sock)
 654                     continue;
 655                 close(f);
 656             }
 657
 658             while (1) {
 659                 SV *target;
 660                 union control_un control;
 661                 struct msghdr msg;
 662                 struct iovec vec[1];
 663                 struct cmsghdr *cmptr;
 664                 ssize_t got;
 665                 int got_fd;
 666
 667                 msg.msg_control = control.control;
 668                 msg.msg_controllen = sizeof(control.control);
 669                 /* We're a connected socket so we don't need a source  */
 670                 msg.msg_name = NULL;
 671                 msg.msg_namelen = 0;
 672                 msg.msg_iov = vec;
 673                 msg.msg_iovlen = C_ARRAY_LENGTH(vec);
 674
 675                 vec[0].iov_base = (void*)&target;
 676                 vec[0].iov_len = sizeof(target);
 677
 678                 got = recvmsg(sock, &msg, 0);
 679
 680                 if(got == 0)
 681                     break;
 682                 if(got < 0) {
 683                     where = "recv failed";
 684                     goto abort;
 685                 }
 686                 if(got < sizeof(target)) {
 687                     where = "short recv";
 688                     goto abort;
 689                 }
 690
 691                 if(!(cmptr = CMSG_FIRSTHDR(&msg))) {
 692                     where = "no cmsg";
 693                     goto abort;
 694                 }
 695                 if(cmptr->cmsg_len != CMSG_LEN(sizeof(int))) {
 696                     where = "wrong cmsg_len";
 697                     goto abort;
 698                 }
 699                 if(cmptr->cmsg_level != SOL_SOCKET) {
 700                     where = "wrong cmsg_level";
 701                     goto abort;
 702                 }
 703                 if(cmptr->cmsg_type != SCM_RIGHTS) {
 704                     where = "wrong cmsg_type";
 705                     goto abort;
 706                 }
 707
 708                 got_fd = *(int*)CMSG_DATA(cmptr);
 709                 /* For our last little bit of trickery, put the file descriptor
 710                    back into Perl_debug_log, as if we never actually closed it
 711                 */
 712                 if(got_fd != debug_fd) {
 713                     if (dup2(got_fd, debug_fd) == -1) {
 714                         where = "dup2";
 715                         goto abort;
 716                     }
 717                 }
 718                 sv_dump(target);
 719
 720                 PerlIO_flush(Perl_debug_log);
 721
 722                 got = write(sock, &success, sizeof(success));
 723
 724                 if(got < 0) {
 725                     where = "write failed";
 726                     goto abort;
 727                 }
 728                 if(got < sizeof(success)) {
 729                     where = "short write";
 730                     goto abort;
 731                 }
 732             }
 733             _exit(0);
 734         abort:
 735             {
 736                 int send_errno = errno;
 737                 unsigned char length = (unsigned char) strlen(where);
 738                 struct iovec failure[3] = {
 739                     {(void*)&send_errno, sizeof(send_errno)},
 740                     {&length, 1},
 741                     {(void*)where, length}
 742                 };
 743                 int got = writev(sock, failure, 3);
 744                 /* Bad news travels fast. Faster than data. We'll get a SIGPIPE
 745                    in the parent if we try to read from the socketpair after the
 746                    child has exited, even if there was data to read.
 747                    So sleep a bit to give the parent a fighting chance of
 748                    reading the data.  */
 749                 sleep(2);
 750                 _exit((got == -1) ? errno : 0);
 751             }
 752             /* End of child.  */
 753         }
 754         PL_dumper_fd = fd[0];
 755         close(fd[1]);
 756     }
 757 #endif
 758
 759     /* We must account for everything.  */
 760
 761     /* Destroy the main CV and syntax tree */
 762     /* Set PL_curcop now, because destroying ops can cause new SVs
 763        to be generated in Perl_pad_swipe, and when running with
 764       -DDEBUG_LEAKING_SCALARS they expect PL_curcop to point to a valid
 765        op from which the filename structure member is copied.  */
 766     PL_curcop = &PL_compiling;
 767     if (PL_main_root) {
 768         /* ensure comppad/curpad to refer to main's pad */
 769         if (CvPADLIST(PL_main_cv)) {
 770             PAD_SET_CUR_NOSAVE(CvPADLIST(PL_main_cv), 1);
 771             PL_comppad_name = PadlistNAMES(CvPADLIST(PL_main_cv));
 772         }
 773         op_free(PL_main_root);
 774         PL_main_root = NULL;
 775     }
 776     PL_main_start = NULL;
 777     /* note that  PL_main_cv isn't usually actually freed at this point,
 778      * due to the CvOUTSIDE refs from subs compiled within it. It will
 779      * get freed once all the subs are freed in sv_clean_all(), for
 780      * destruct_level > 0 */
 781     SvREFCNT_dec(PL_main_cv);
 782     PL_main_cv = NULL;
 783     PERL_SET_PHASE(PERL_PHASE_DESTRUCT);
 784
 785     /* Tell PerlIO we are about to tear things apart in case
 786        we have layers which are using resources that should
 787        be cleaned up now.
 788      */
 789
 790     PerlIO_destruct(aTHX);
 791
 792     /*
 793      * Try to destruct global references.  We do this first so that the
 794      * destructors and destructees still exist.  Some sv's might remain.
 795      * Non-referenced objects are on their own.
 796      */
 797     sv_clean_objs();
 798
 799     /* unhook hooks which will soon be, or use, destroyed data */
 800     SvREFCNT_dec(PL_warnhook);
 801     PL_warnhook = NULL;
 802     SvREFCNT_dec(PL_diehook);
 803     PL_diehook = NULL;
 804
 805     /* call exit list functions */
 806     while (PL_exitlistlen-- > 0)
 807         PL_exitlist[PL_exitlistlen].fn(aTHX_ PL_exitlist[PL_exitlistlen].ptr);
 808
 809     Safefree(PL_exitlist);
 810
 811     PL_exitlist = NULL;
 812     PL_exitlistlen = 0;
 813
 814     SvREFCNT_dec(PL_registered_mros);
 815
 816     /* jettison our possibly duplicated environment */
 817     /* if PERL_USE_SAFE_PUTENV is defined environ will not have been copied
 818      * so we certainly shouldn't free it here
 819      */
 820 #ifndef PERL_MICRO
 821 #if defined(USE_ENVIRON_ARRAY) && !defined(PERL_USE_SAFE_PUTENV)
 822     if (environ != PL_origenviron && !PL_use_safe_putenv
 823 #ifdef USE_ITHREADS
 824         /* only main thread can free environ[0] contents */
 825         && PL_curinterp == aTHX
 826 #endif
 827         )
 828     {
 829         I32 i;
 830
 831         for (i = 0; environ[i]; i++)
 832             safesysfree(environ[i]);
 833
 834         /* Must use safesysfree() when working with environ. */
 835         safesysfree(environ);
 836
 837         environ = PL_origenviron;
 838     }
 839 #endif
 840 #endif /* !PERL_MICRO */
 841
 842     if (destruct_level == 0) {
 843
 844         DEBUG_P(debprofdump());
 845
 846 #if defined(PERLIO_LAYERS)
 847         /* No more IO - including error messages ! */
 848         PerlIO_cleanup(aTHX);
 849 #endif
 850
 851         CopFILE_free(&PL_compiling);
 852
 853         /* The exit() function will do everything that needs doing. */
 854         return STATUS_EXIT;
 855     }
 856
 857     /* Below, do clean up for when PERL_DESTRUCT_LEVEL is not 0 */
 858
 859 #ifdef USE_ITHREADS
 860     /* the syntax tree is shared between clones
 861      * so op_free(PL_main_root) only ReREFCNT_dec's
 862      * REGEXPs in the parent interpreter
 863      * we need to manually ReREFCNT_dec for the clones
 864      */
 865     {
 866         I32 i = AvFILLp(PL_regex_padav);
 867         SV **ary = AvARRAY(PL_regex_padav);
 868
 869         for (; i; i--) {
 870             SvREFCNT_dec(ary[i]);
 871             ary[i] = &PL_sv_undef;
 872         }
 873     }
 874 #endif
 875
 876
 877     SvREFCNT_dec(MUTABLE_SV(PL_stashcache));
 878     PL_stashcache = NULL;
 879
 880     /* loosen bonds of global variables */
 881
 882     /* XXX can PL_parser still be non-null here? */
 883     if(PL_parser && PL_parser->rsfp) {
 884         (void)PerlIO_close(PL_parser->rsfp);
 885         PL_parser->rsfp = NULL;
 886     }
 887
 888     if (PL_minus_F) {
 889         Safefree(PL_splitstr);
 890         PL_splitstr = NULL;
 891     }
 892
 893     /* switches */
 894     PL_minus_n      = FALSE;
 895     PL_minus_p      = FALSE;
 896     PL_minus_l      = FALSE;
 897     PL_minus_a      = FALSE;
 898     PL_minus_F      = FALSE;
 899     PL_doswitches   = FALSE;
 900     PL_dowarn       = G_WARN_OFF;
 901 #ifdef PERL_SAWAMPERSAND
 902     PL_sawampersand = 0;        /* must save all match strings */
 903 #endif
 904     PL_unsafe       = FALSE;
 905
 906     Safefree(PL_inplace);
 907     PL_inplace = NULL;
 908     SvREFCNT_dec(PL_patchlevel);
 909     SvREFCNT_dec(PL_apiversion);
 910
 911     if (PL_e_script) {
 912         SvREFCNT_dec(PL_e_script);
 913         PL_e_script = NULL;
 914     }
 915
 916     PL_perldb = 0;
 917
 918     /* magical thingies */
 919
 920     SvREFCNT_dec(PL_ofsgv);     /* *, */
 921     PL_ofsgv = NULL;
 922
 923     SvREFCNT_dec(PL_ors_sv);    /* $\ */
 924     PL_ors_sv = NULL;
 925
 926     SvREFCNT_dec(PL_rs);        /* $/ */
 927     PL_rs = NULL;
 928
 929     Safefree(PL_osname);        /* $^O */
 930     PL_osname = NULL;
 931
 932     SvREFCNT_dec(PL_statname);
 933     PL_statname = NULL;
 934     PL_statgv = NULL;
 935
 936     /* defgv, aka *_ should be taken care of elsewhere */
 937
 938     /* float buffer */
 939     Safefree(PL_efloatbuf);
 940     PL_efloatbuf = NULL;
 941     PL_efloatsize = 0;
 942
 943     /* startup and shutdown function lists */
 944     SvREFCNT_dec(PL_beginav);
 945     SvREFCNT_dec(PL_beginav_save);
 946     SvREFCNT_dec(PL_endav);
 947     SvREFCNT_dec(PL_checkav);
 948     SvREFCNT_dec(PL_checkav_save);
 949     SvREFCNT_dec(PL_unitcheckav);
 950     SvREFCNT_dec(PL_unitcheckav_save);
 951     SvREFCNT_dec(PL_initav);
 952     PL_beginav = NULL;
 953     PL_beginav_save = NULL;
 954     PL_endav = NULL;
 955     PL_checkav = NULL;
 956     PL_checkav_save = NULL;
 957     PL_unitcheckav = NULL;
 958     PL_unitcheckav_save = NULL;
 959     PL_initav = NULL;
 960
 961     /* shortcuts just get cleared */
 962     PL_hintgv = NULL;
 963     PL_errgv = NULL;
 964     PL_argvoutgv = NULL;
 965     PL_stdingv = NULL;
 966     PL_stderrgv = NULL;
 967     PL_last_in_gv = NULL;
 968     PL_DBsingle = NULL;
 969     PL_DBtrace = NULL;
 970     PL_DBsignal = NULL;
 971     PL_DBcv = NULL;
 972     PL_dbargs = NULL;
 973     PL_debstash = NULL;
 974
 975     SvREFCNT_dec(PL_envgv);
 976     SvREFCNT_dec(PL_incgv);
 977     SvREFCNT_dec(PL_argvgv);
 978     SvREFCNT_dec(PL_replgv);
 979     SvREFCNT_dec(PL_DBgv);
 980     SvREFCNT_dec(PL_DBline);
 981     SvREFCNT_dec(PL_DBsub);
 982     PL_envgv = NULL;
 983     PL_incgv = NULL;
 984     PL_argvgv = NULL;
 985     PL_replgv = NULL;
 986     PL_DBgv = NULL;
 987     PL_DBline = NULL;
 988     PL_DBsub = NULL;
 989
 990     SvREFCNT_dec(PL_argvout_stack);
 991     PL_argvout_stack = NULL;
 992
 993     SvREFCNT_dec(PL_modglobal);
 994     PL_modglobal = NULL;
 995     SvREFCNT_dec(PL_preambleav);
 996     PL_preambleav = NULL;
 997     SvREFCNT_dec(PL_subname);
 998     PL_subname = NULL;
 999 #ifdef PERL_USES_PL_PIDSTATUS
1000     SvREFCNT_dec(PL_pidstatus);
1001     PL_pidstatus = NULL;
1002 #endif
1003     SvREFCNT_dec(PL_toptarget);
1004     PL_toptarget = NULL;
1005     SvREFCNT_dec(PL_bodytarget);
1006     PL_bodytarget = NULL;
1007     PL_formtarget = NULL;
1008
1009     /* free locale stuff */
1010 #ifdef USE_LOCALE_COLLATE
1011     Safefree(PL_collation_name);
1012     PL_collation_name = NULL;
1013 #endif
1014
1015 #ifdef USE_LOCALE_NUMERIC
1016     Safefree(PL_numeric_name);
1017     PL_numeric_name = NULL;
1018     SvREFCNT_dec(PL_numeric_radix_sv);
1019     PL_numeric_radix_sv = NULL;
1020 #endif
1021
1022     /* clear character classes  */
1023     for (i = 0; i < POSIX_SWASH_COUNT; i++) {
1024         SvREFCNT_dec(PL_utf8_swash_ptrs[i]);
1025         PL_utf8_swash_ptrs[i] = NULL;
1026     }
1027     SvREFCNT_dec(PL_utf8_mark);
1028     SvREFCNT_dec(PL_utf8_toupper);
1029     SvREFCNT_dec(PL_utf8_totitle);
1030     SvREFCNT_dec(PL_utf8_tolower);
1031     SvREFCNT_dec(PL_utf8_tofold);
1032     SvREFCNT_dec(PL_utf8_idstart);
1033     SvREFCNT_dec(PL_utf8_idcont);
1034     SvREFCNT_dec(PL_utf8_foldable);
1035     SvREFCNT_dec(PL_utf8_foldclosures);
1036     SvREFCNT_dec(PL_AboveLatin1);
1037     SvREFCNT_dec(PL_InBitmap);
1038     SvREFCNT_dec(PL_UpperLatin1);
1039     SvREFCNT_dec(PL_Latin1);
1040     SvREFCNT_dec(PL_NonL1NonFinalFold);
1041     SvREFCNT_dec(PL_HasMultiCharFold);
1042     PL_utf8_mark        = NULL;
1043     PL_utf8_toupper     = NULL;
1044     PL_utf8_totitle     = NULL;
1045     PL_utf8_tolower     = NULL;
1046     PL_utf8_tofold      = NULL;
1047     PL_utf8_idstart     = NULL;
1048     PL_utf8_idcont      = NULL;
1049     PL_utf8_foldclosures = NULL;
1050     PL_AboveLatin1       = NULL;
1051     PL_InBitmap          = NULL;
1052     PL_HasMultiCharFold  = NULL;
1053     PL_Latin1            = NULL;
1054     PL_NonL1NonFinalFold = NULL;
1055     PL_UpperLatin1       = NULL;
1056     for (i = 0; i < POSIX_CC_COUNT; i++) {
1057         SvREFCNT_dec(PL_XPosix_ptrs[i]);
1058         PL_XPosix_ptrs[i] = NULL;
1059     }
1060
1061     if (!specialWARN(PL_compiling.cop_warnings))
1062         PerlMemShared_free(PL_compiling.cop_warnings);
1063     PL_compiling.cop_warnings = NULL;
1064     cophh_free(CopHINTHASH_get(&PL_compiling));
1065     CopHINTHASH_set(&PL_compiling, cophh_new_empty());
1066     CopFILE_free(&PL_compiling);
1067
1068     /* Prepare to destruct main symbol table.  */
1069
1070     hv = PL_defstash;
1071     /* break ref loop  *:: <=> %:: */
1072     (void)hv_delete(hv, "main::", 6, G_DISCARD);
1073     PL_defstash = 0;
1074     SvREFCNT_dec(hv);
1075     SvREFCNT_dec(PL_curstname);
1076     PL_curstname = NULL;
1077
1078     /* clear queued errors */
1079     SvREFCNT_dec(PL_errors);
1080     PL_errors = NULL;
1081
1082     SvREFCNT_dec(PL_isarev);
1083
1084     FREETMPS;
1085     if (destruct_level >= 2) {
1086         if (PL_scopestack_ix != 0)
1087             Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
1088                              "Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
1089                              (long)PL_scopestack_ix);
1090         if (PL_savestack_ix != 0)
1091             Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
1092                              "Unbalanced saves: %ld more saves than restores\n",
1093                              (long)PL_savestack_ix);
1094         if (PL_tmps_floor != -1)
1095             Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),"Unbalanced tmps: %ld more allocs than frees\n",
1096                              (long)PL_tmps_floor + 1);
1097         if (cxstack_ix != -1)
1098             Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),"Unbalanced context: %ld more PUSHes than POPs\n",
1099                              (long)cxstack_ix + 1);
1100     }
1101
1102 #ifdef USE_ITHREADS
1103     SvREFCNT_dec(PL_regex_padav);
1104     PL_regex_padav = NULL;
1105     PL_regex_pad = NULL;
1106 #endif
1107
1108 #ifdef PERL_IMPLICIT_CONTEXT
1109     /* the entries in this list are allocated via SV PVX's, so get freed
1110      * in sv_clean_all */
1111     Safefree(PL_my_cxt_list);
1112 #endif
1113
1114     /* Now absolutely destruct everything, somehow or other, loops or no. */
1115
1116     /* the 2 is for PL_fdpid and PL_strtab */
1117     while (sv_clean_all() > 2)
1118         ;
1119
1120 #ifdef USE_ITHREADS
1121     Safefree(PL_stashpad); /* must come after sv_clean_all */
1122 #endif
1123
1124     AvREAL_off(PL_fdpid);               /* no surviving entries */
1125     SvREFCNT_dec(PL_fdpid);             /* needed in io_close() */
1126     PL_fdpid = NULL;
1127
1128 #ifdef HAVE_INTERP_INTERN
1129     sys_intern_clear();
1130 #endif
1131
1132     /* constant strings */
1133     for (i = 0; i < SV_CONSTS_COUNT; i++) {
1134         SvREFCNT_dec(PL_sv_consts[i]);
1135         PL_sv_consts[i] = NULL;
1136     }
1137
1138     /* Destruct the global string table. */
1139     {
1140         /* Yell and reset the HeVAL() slots that are still holding refcounts,
1141          * so that sv_free() won't fail on them.
1142          * Now that the global string table is using a single hunk of memory
1143          * for both HE and HEK, we either need to explicitly unshare it the
1144          * correct way, or actually free things here.
1145          */
1146         I32 riter = 0;
1147         const I32 max = HvMAX(PL_strtab);
1148         HE * const * const array = HvARRAY(PL_strtab);
1149         HE *hent = array[0];
1150
1151         for (;;) {
1152             if (hent && ckWARN_d(WARN_INTERNAL)) {
1153                 HE * const next = HeNEXT(hent);
1154                 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
1155                      "Unbalanced string table refcount: (%ld) for \"%s\"",
1156                      (long)hent->he_valu.hent_refcount, HeKEY(hent));
1157                 Safefree(hent);
1158                 hent = next;
1159             }
1160             if (!hent) {
1161                 if (++riter > max)
1162                     break;
1163                 hent = array[riter];
1164             }
1165         }
1166
1167         Safefree(array);
1168         HvARRAY(PL_strtab) = 0;
1169         HvTOTALKEYS(PL_strtab) = 0;
1170     }
1171     SvREFCNT_dec(PL_strtab);
1172
1173 #ifdef USE_ITHREADS
1174     /* free the pointer tables used for cloning */
1175     ptr_table_free(PL_ptr_table);
1176     PL_ptr_table = (PTR_TBL_t*)NULL;
1177 #endif
1178
1179     /* free special SVs */
1180
1181     SvREFCNT(&PL_sv_yes) = 0;
1182     sv_clear(&PL_sv_yes);
1183     SvANY(&PL_sv_yes) = NULL;
1184     SvFLAGS(&PL_sv_yes) = 0;
1185
1186     SvREFCNT(&PL_sv_no) = 0;
1187     sv_clear(&PL_sv_no);
1188     SvANY(&PL_sv_no) = NULL;
1189     SvFLAGS(&PL_sv_no) = 0;
1190
1191     {
1192         int i;
1193         for (i=0; i<=2; i++) {
1194             SvREFCNT(PERL_DEBUG_PAD(i)) = 0;
1195             sv_clear(PERL_DEBUG_PAD(i));
1196             SvANY(PERL_DEBUG_PAD(i)) = NULL;
1197             SvFLAGS(PERL_DEBUG_PAD(i)) = 0;
1198         }
1199     }
1200
1201     if (PL_sv_count != 0 && ckWARN_d(WARN_INTERNAL))
1202         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Scalars leaked: %ld\n", (long)PL_sv_count);
1203
1204 #ifdef DEBUG_LEAKING_SCALARS
1205     if (PL_sv_count != 0) {
1206         SV* sva;
1207         SV* sv;
1208         SV* svend;
1209
1210         for (sva = PL_sv_arenaroot; sva; sva = MUTABLE_SV(SvANY(sva))) {
1211             svend = &sva[SvREFCNT(sva)];
1212             for (sv = sva + 1; sv < svend; ++sv) {
1213                 if (SvTYPE(sv) != (svtype)SVTYPEMASK) {
1214                     PerlIO_printf(Perl_debug_log, "leaked: sv=0x%p"
1215                         " flags=0x%"UVxf
1216                         " refcnt=%"UVuf pTHX__FORMAT "\n"
1217                         "\tallocated at %s:%d %s %s (parent 0x%"UVxf");"
1218                         "serial %"UVuf"\n",
1219                         (void*)sv, (UV)sv->sv_flags, (UV)sv->sv_refcnt
1220                         pTHX__VALUE,
1221                         sv->sv_debug_file ? sv->sv_debug_file : "(unknown)",
1222                         sv->sv_debug_line,
1223                         sv->sv_debug_inpad ? "for" : "by",
1224                         sv->sv_debug_optype ?
1225                             PL_op_name[sv->sv_debug_optype]: "(none)",
1226                         PTR2UV(sv->sv_debug_parent),
1227                         sv->sv_debug_serial
1228                     );
1229 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
1230                     Perl_dump_sv_child(aTHX_ sv);
1231 #endif
1232                 }
1233             }
1234         }
1235     }
1236 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
1237     {
1238         int status;
1239         fd_set rset;
1240         /* Wait for up to 4 seconds for child to terminate.
1241            This seems to be the least effort way of timing out on reaping
1242            its exit status.  */
1243         struct timeval waitfor = {4, 0};
1244         int sock = PL_dumper_fd;
1245
1246         shutdown(sock, 1);
1247         FD_ZERO(&rset);
1248         FD_SET(sock, &rset);
1249         select(sock + 1, &rset, NULL, NULL, &waitfor);
1250         waitpid(child, &status, WNOHANG);
1251         close(sock);
1252     }
1253 #endif
1254 #endif
1255 #ifdef DEBUG_LEAKING_SCALARS_ABORT
1256     if (PL_sv_count)
1257         abort();
1258 #endif
1259     PL_sv_count = 0;
1260
1261 #if defined(PERLIO_LAYERS)
1262     /* No more IO - including error messages ! */
1263     PerlIO_cleanup(aTHX);
1264 #endif
1265
1266     /* sv_undef needs to stay immortal until after PerlIO_cleanup
1267        as currently layers use it rather than NULL as a marker
1268        for no arg - and will try and SvREFCNT_dec it.
1269      */
1270     SvREFCNT(&PL_sv_undef) = 0;
1271     SvREADONLY_off(&PL_sv_undef);
1272
1273     Safefree(PL_origfilename);
1274     PL_origfilename = NULL;
1275     Safefree(PL_reg_curpm);
1276     free_tied_hv_pool();
1277     Safefree(PL_op_mask);
1278     Safefree(PL_psig_name);
1279     PL_psig_name = (SV**)NULL;
1280     PL_psig_ptr = (SV**)NULL;
1281     {
1282         /* We need to NULL PL_psig_pend first, so that
1283            signal handlers know not to use it */
1284         int *psig_save = PL_psig_pend;
1285         PL_psig_pend = (int*)NULL;
1286         Safefree(psig_save);
1287     }
1288     nuke_stacks();
1289     TAINTING_set(FALSE);
1290     TAINT_WARN_set(FALSE);
1291     PL_hints = 0;               /* Reset hints. Should hints be per-interpreter ? */
1292     PL_debug = 0;
1293
1294     DEBUG_P(debprofdump());
1295
1296 #ifdef USE_REENTRANT_API
1297     Perl_reentrant_free(aTHX);
1298 #endif
1299
1300     sv_free_arenas();
1301
1302     while (PL_regmatch_slab) {
1303         regmatch_slab  *s = PL_regmatch_slab;
1304         PL_regmatch_slab = PL_regmatch_slab->next;
1305         Safefree(s);
1306     }
1307
1308     /* As the absolutely last thing, free the non-arena SV for mess() */
1309
1310     if (PL_mess_sv) {
1311         /* we know that type == SVt_PVMG */
1312
1313         /* it could have accumulated taint magic */
1314         MAGIC* mg;
1315         MAGIC* moremagic;
1316         for (mg = SvMAGIC(PL_mess_sv); mg; mg = moremagic) {
1317             moremagic = mg->mg_moremagic;
1318             if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global
1319                 && mg->mg_len >= 0)
1320                 Safefree(mg->mg_ptr);
1321             Safefree(mg);
1322         }
1323
1324         /* we know that type >= SVt_PV */
1325         SvPV_free(PL_mess_sv);
1326         Safefree(SvANY(PL_mess_sv));
1327         Safefree(PL_mess_sv);
1328         PL_mess_sv = NULL;
1329     }
1330     return STATUS_EXIT;
1331 }
1332
1333 /*
1334 =for apidoc perl_free
1335
1336 Releases a Perl interpreter.  See L<perlembed>.
1337
1338 =cut
1339 */
1340
1341 void
1342 perl_free(pTHXx)
1343 {
1344     dVAR;
1345
1346     PERL_ARGS_ASSERT_PERL_FREE;
1347
1348     if (PL_veto_cleanup)
1349         return;
1350
1351 #ifdef PERL_TRACK_MEMPOOL
1352     {
1353         /*
1354          * Don't free thread memory if PERL_DESTRUCT_LEVEL is set to a non-zero
1355          * value as we're probably hunting memory leaks then
1356          */
1357         if (PL_perl_destruct_level == 0) {
1358             const U32 old_debug = PL_debug;
1359             /* Emulate the PerlHost behaviour of free()ing all memory allocated in this
1360                thread at thread exit.  */
1361             if (DEBUG_m_TEST) {
1362                 PerlIO_puts(Perl_debug_log, "Disabling memory debugging as we "
1363                             "free this thread's memory\n");
1364                 PL_debug &= ~ DEBUG_m_FLAG;
1365             }
1366             while(aTHXx->Imemory_debug_header.next != &(aTHXx->Imemory_debug_header))
1367                 safesysfree(PERL_MEMORY_DEBUG_HEADER_SIZE + (char *)(aTHXx->Imemory_debug_header.next));
1368             PL_debug = old_debug;
1369         }
1370     }
1371 #endif
1372
1373 #if defined(WIN32) || defined(NETWARE)
1374 #  if defined(PERL_IMPLICIT_SYS)
1375     {
1376 #    ifdef NETWARE
1377         void *host = nw_internal_host;
1378         PerlMem_free(aTHXx);
1379         nw_delete_internal_host(host);
1380 #    else
1381         void *host = w32_internal_host;
1382         PerlMem_free(aTHXx);
1383         win32_delete_internal_host(host);
1384 #    endif
1385     }
1386 #  else
1387     PerlMem_free(aTHXx);
1388 #  endif
1389 #else
1390     PerlMem_free(aTHXx);
1391 #endif
1392 }
1393
1394 #if defined(USE_ITHREADS)
1395 /* provide destructors to clean up the thread key when libperl is unloaded */
1396 #ifndef WIN32 /* handled during DLL_PROCESS_DETACH in win32/perllib.c */
1397
1398 #if defined(__hpux) && !(defined(__ux_version) && __ux_version <= 1020) && !defined(__GNUC__)
1399 #pragma fini "perl_fini"
1400 #elif defined(__sun) && !defined(__GNUC__)
1401 #pragma fini (perl_fini)
1402 #endif
1403
1404 static void
1405 #if defined(__GNUC__)
1406 __attribute__((destructor))
1407 #endif
1408 perl_fini(void)
1409 {
1410     dVAR;
1411     if (
1412 #ifdef PERL_GLOBAL_STRUCT_PRIVATE
1413         my_vars &&
1414 #endif
1415         PL_curinterp && !PL_veto_cleanup)
1416         FREE_THREAD_KEY;
1417 }
1418
1419 #endif /* WIN32 */
1420 #endif /* THREADS */
1421
1422 void
1423 Perl_call_atexit(pTHX_ ATEXIT_t fn, void *ptr)
1424 {
1425     Renew(PL_exitlist, PL_exitlistlen+1, PerlExitListEntry);
1426     PL_exitlist[PL_exitlistlen].fn = fn;
1427     PL_exitlist[PL_exitlistlen].ptr = ptr;
1428     ++PL_exitlistlen;
1429 }
1430
1431 /*
1432 =for apidoc perl_parse
1433
1434 Tells a Perl interpreter to parse a Perl script.  See L<perlembed>.
1435
1436 =cut
1437 */
1438
1439 #define SET_CURSTASH(newstash)                       \
1440         if (PL_curstash != newstash) {                \
1441             SvREFCNT_dec(PL_curstash);                 \
1442             PL_curstash = (HV *)SvREFCNT_inc(newstash); \
1443         }
1444
1445 int
1446 perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env)
1447 {
1448     dVAR;
1449     I32 oldscope;
1450     int ret;
1451     dJMPENV;
1452
1453     PERL_ARGS_ASSERT_PERL_PARSE;
1454 #ifndef MULTIPLICITY
1455     PERL_UNUSED_ARG(my_perl);
1456 #endif
1457 #if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT) || defined(USE_HASH_SEED_DEBUG)
1458     {
1459         const char * const s = PerlEnv_getenv("PERL_HASH_SEED_DEBUG");
1460
1461         if (s && (grok_atou(s, NULL) == 1)) {
1462             unsigned char *seed= PERL_HASH_SEED;
1463             unsigned char *seed_end= PERL_HASH_SEED + PERL_HASH_SEED_BYTES;
1464             PerlIO_printf(Perl_debug_log, "HASH_FUNCTION = %s HASH_SEED = 0x", PERL_HASH_FUNC);
1465             while (seed < seed_end) {
1466                 PerlIO_printf(Perl_debug_log, "%02x", *seed++);
1467             }
1468 #ifdef PERL_HASH_RANDOMIZE_KEYS
1469             PerlIO_printf(Perl_debug_log, " PERTURB_KEYS = %d (%s)",
1470                     PL_HASH_RAND_BITS_ENABLED,
1471                     PL_HASH_RAND_BITS_ENABLED == 0 ? "NO" : PL_HASH_RAND_BITS_ENABLED == 1 ? "RANDOM" : "DETERMINISTIC");
1472 #endif
1473             PerlIO_printf(Perl_debug_log, "\n");
1474         }
1475     }
1476 #endif /* #if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT) */
1477     PL_origargc = argc;
1478     PL_origargv = argv;
1479
1480     if (PL_origalen != 0) {
1481         PL_origalen = 1; /* don't use old PL_origalen if perl_parse() is called again */
1482     }
1483     else {
1484         /* Set PL_origalen be the sum of the contiguous argv[]
1485          * elements plus the size of the env in case that it is
1486          * contiguous with the argv[].  This is used in mg.c:Perl_magic_set()
1487          * as the maximum modifiable length of $0.  In the worst case
1488          * the area we are able to modify is limited to the size of
1489          * the original argv[0].  (See below for 'contiguous', though.)
1490          * --jhi */
1491          const char *s = NULL;
1492          int i;
1493          const UV mask = ~(UV)(PTRSIZE-1);
1494          /* Do the mask check only if the args seem like aligned. */
1495          const UV aligned =
1496            (mask < ~(UV)0) && ((PTR2UV(argv[0]) & mask) == PTR2UV(argv[0]));
1497
1498          /* See if all the arguments are contiguous in memory.  Note
1499           * that 'contiguous' is a loose term because some platforms
1500           * align the argv[] and the envp[].  If the arguments look
1501           * like non-aligned, assume that they are 'strictly' or
1502           * 'traditionally' contiguous.  If the arguments look like
1503           * aligned, we just check that they are within aligned
1504           * PTRSIZE bytes.  As long as no system has something bizarre
1505           * like the argv[] interleaved with some other data, we are
1506           * fine.  (Did I just evoke Murphy's Law?)  --jhi */
1507          if (PL_origargv && PL_origargc >= 1 && (s = PL_origargv[0])) {
1508               while (*s) s++;
1509               for (i = 1; i < PL_origargc; i++) {
1510                    if ((PL_origargv[i] == s + 1
1511 #ifdef OS2
1512                         || PL_origargv[i] == s + 2
1513 #endif
1514                             )
1515                        ||
1516                        (aligned &&
1517                         (PL_origargv[i] >  s &&
1518                          PL_origargv[i] <=
1519                          INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask)))
1520                         )
1521                    {
1522                         s = PL_origargv[i];
1523                         while (*s) s++;
1524                    }
1525                    else
1526                         break;
1527               }
1528          }
1529
1530 #ifndef PERL_USE_SAFE_PUTENV
1531          /* Can we grab env area too to be used as the area for $0? */
1532          if (s && PL_origenviron && !PL_use_safe_putenv) {
1533               if ((PL_origenviron[0] == s + 1)
1534                   ||
1535                   (aligned &&
1536                    (PL_origenviron[0] >  s &&
1537                     PL_origenviron[0] <=
1538                     INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask)))
1539                  )
1540               {
1541 #ifndef OS2             /* ENVIRON is read by the kernel too. */
1542                    s = PL_origenviron[0];
1543                    while (*s) s++;
1544 #endif
1545                    my_setenv("NoNe  SuCh", NULL);
1546                    /* Force copy of environment. */
1547                    for (i = 1; PL_origenviron[i]; i++) {
1548                         if (PL_origenviron[i] == s + 1
1549                             ||
1550                             (aligned &&
1551                              (PL_origenviron[i] >  s &&
1552                               PL_origenviron[i] <=
1553                               INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask)))
1554                            )
1555                         {
1556                              s = PL_origenviron[i];
1557                              while (*s) s++;
1558                         }
1559                         else
1560                              break;
1561                    }
1562               }
1563          }
1564 #endif /* !defined(PERL_USE_SAFE_PUTENV) */
1565
1566          PL_origalen = s ? s - PL_origargv[0] + 1 : 0;
1567     }
1568
1569     if (PL_do_undump) {
1570
1571         /* Come here if running an undumped a.out. */
1572
1573         PL_origfilename = savepv(argv[0]);
1574         PL_do_undump = FALSE;
1575         cxstack_ix = -1;                /* start label stack again */
1576         init_ids();
1577         assert (!TAINT_get);
1578         TAINT;
1579         set_caret_X();
1580         TAINT_NOT;
1581         init_postdump_symbols(argc,argv,env);
1582         return 0;
1583     }
1584
1585     if (PL_main_root) {
1586         op_free(PL_main_root);
1587         PL_main_root = NULL;
1588     }
1589     PL_main_start = NULL;
1590     SvREFCNT_dec(PL_main_cv);
1591     PL_main_cv = NULL;
1592
1593     time(&PL_basetime);
1594     oldscope = PL_scopestack_ix;
1595     PL_dowarn = G_WARN_OFF;
1596
1597     JMPENV_PUSH(ret);
1598     switch (ret) {
1599     case 0:
1600         parse_body(env,xsinit);
1601         if (PL_unitcheckav) {
1602             call_list(oldscope, PL_unitcheckav);
1603         }
1604         if (PL_checkav) {
1605             PERL_SET_PHASE(PERL_PHASE_CHECK);
1606             call_list(oldscope, PL_checkav);
1607         }
1608         ret = 0;
1609         break;
1610     case 1:
1611         STATUS_ALL_FAILURE;
1612         /* FALLTHROUGH */
1613     case 2:
1614         /* my_exit() was called */
1615         while (PL_scopestack_ix > oldscope)
1616             LEAVE;
1617         FREETMPS;
1618         SET_CURSTASH(PL_defstash);
1619         if (PL_unitcheckav) {
1620             call_list(oldscope, PL_unitcheckav);
1621         }
1622         if (PL_checkav) {
1623             PERL_SET_PHASE(PERL_PHASE_CHECK);
1624             call_list(oldscope, PL_checkav);
1625         }
1626         ret = STATUS_EXIT;
1627         break;
1628     case 3:
1629         PerlIO_printf(Perl_error_log, "panic: top_env\n");
1630         ret = 1;
1631         break;
1632     }
1633     JMPENV_POP;
1634     return ret;
1635 }
1636
1637 /* This needs to stay in perl.c, as perl.c is compiled with different flags for
1638    miniperl, and we need to see those flags reflected in the values here.  */
1639
1640 /* What this returns is subject to change.  Use the public interface in Config.
1641  */
1642 static void
1643 S_Internals_V(pTHX_ CV *cv)
1644 {
1645     dXSARGS;
1646 #ifdef LOCAL_PATCH_COUNT
1647     const int local_patch_count = LOCAL_PATCH_COUNT;
1648 #else
1649     const int local_patch_count = 0;
1650 #endif
1651     const int entries = 3 + local_patch_count;
1652     int i;
1653     static const char non_bincompat_options[] =
1654 #  ifdef DEBUGGING
1655                              " DEBUGGING"
1656 #  endif
1657 #  ifdef NO_MATHOMS
1658                              " NO_MATHOMS"
1659 #  endif
1660 #  ifdef NO_HASH_SEED
1661                              " NO_HASH_SEED"
1662 #  endif
1663 #  ifdef NO_TAINT_SUPPORT
1664                              " NO_TAINT_SUPPORT"
1665 #  endif
1666 #  ifdef PERL_BOOL_AS_CHAR
1667                              " PERL_BOOL_AS_CHAR"
1668 #  endif
1669 #  ifdef PERL_DISABLE_PMC
1670                              " PERL_DISABLE_PMC"
1671 #  endif
1672 #  ifdef PERL_DONT_CREATE_GVSV
1673                              " PERL_DONT_CREATE_GVSV"
1674 #  endif
1675 #  ifdef PERL_EXTERNAL_GLOB
1676                              " PERL_EXTERNAL_GLOB"
1677 #  endif
1678 #  ifdef PERL_HASH_FUNC_SIPHASH
1679                              " PERL_HASH_FUNC_SIPHASH"
1680 #  endif
1681 #  ifdef PERL_HASH_FUNC_SDBM
1682                              " PERL_HASH_FUNC_SDBM"
1683 #  endif
1684 #  ifdef PERL_HASH_FUNC_DJB2
1685                              " PERL_HASH_FUNC_DJB2"
1686 #  endif
1687 #  ifdef PERL_HASH_FUNC_SUPERFAST
1688                              " PERL_HASH_FUNC_SUPERFAST"
1689 #  endif
1690 #  ifdef PERL_HASH_FUNC_MURMUR3
1691                              " PERL_HASH_FUNC_MURMUR3"
1692 #  endif
1693 #  ifdef PERL_HASH_FUNC_ONE_AT_A_TIME
1694                              " PERL_HASH_FUNC_ONE_AT_A_TIME"
1695 #  endif
1696 #  ifdef PERL_HASH_FUNC_ONE_AT_A_TIME_HARD
1697                              " PERL_HASH_FUNC_ONE_AT_A_TIME_HARD"
1698 #  endif
1699 #  ifdef PERL_HASH_FUNC_ONE_AT_A_TIME_OLD
1700                              " PERL_HASH_FUNC_ONE_AT_A_TIME_OLD"
1701 #  endif
1702 #  ifdef PERL_IS_MINIPERL
1703                              " PERL_IS_MINIPERL"
1704 #  endif
1705 #  ifdef PERL_MALLOC_WRAP
1706                              " PERL_MALLOC_WRAP"
1707 #  endif
1708 #  ifdef PERL_MEM_LOG
1709                              " PERL_MEM_LOG"
1710 #  endif
1711 #  ifdef PERL_MEM_LOG_NOIMPL
1712                              " PERL_MEM_LOG_NOIMPL"
1713 #  endif
1714 #  ifdef PERL_NEW_COPY_ON_WRITE
1715                              " PERL_NEW_COPY_ON_WRITE"
1716 #  endif
1717 #  ifdef PERL_PERTURB_KEYS_DETERMINISTIC
1718                              " PERL_PERTURB_KEYS_DETERMINISTIC"
1719 #  endif
1720 #  ifdef PERL_PERTURB_KEYS_DISABLED
1721                              " PERL_PERTURB_KEYS_DISABLED"
1722 #  endif
1723 #  ifdef PERL_PERTURB_KEYS_RANDOM
1724                              " PERL_PERTURB_KEYS_RANDOM"
1725 #  endif
1726 #  ifdef PERL_PRESERVE_IVUV
1727                              " PERL_PRESERVE_IVUV"
1728 #  endif
1729 #  ifdef PERL_RELOCATABLE_INCPUSH
1730                              " PERL_RELOCATABLE_INCPUSH"
1731 #  endif
1732 #  ifdef PERL_USE_DEVEL
1733                              " PERL_USE_DEVEL"
1734 #  endif
1735 #  ifdef PERL_USE_SAFE_PUTENV
1736                              " PERL_USE_SAFE_PUTENV"
1737 #  endif
1738 #  ifdef UNLINK_ALL_VERSIONS
1739                              " UNLINK_ALL_VERSIONS"
1740 #  endif
1741 #  ifdef USE_ATTRIBUTES_FOR_PERLIO
1742                              " USE_ATTRIBUTES_FOR_PERLIO"
1743 #  endif
1744 #  ifdef USE_FAST_STDIO
1745                              " USE_FAST_STDIO"
1746 #  endif
1747 #  ifdef USE_HASH_SEED_EXPLICIT
1748                              " USE_HASH_SEED_EXPLICIT"
1749 #  endif
1750 #  ifdef USE_LOCALE
1751                              " USE_LOCALE"
1752 #  endif
1753 #  ifdef USE_LOCALE_CTYPE
1754                              " USE_LOCALE_CTYPE"
1755 #  endif
1756 #  ifdef USE_PERL_ATOF
1757                              " USE_PERL_ATOF"
1758 #  endif
1759 #  ifdef USE_SITECUSTOMIZE
1760                              " USE_SITECUSTOMIZE"
1761 #  endif
1762         ;
1763     PERL_UNUSED_ARG(cv);
1764     PERL_UNUSED_ARG(items);
1765
1766     EXTEND(SP, entries);
1767
1768     PUSHs(sv_2mortal(newSVpv(PL_bincompat_options, 0)));
1769     PUSHs(Perl_newSVpvn_flags(aTHX_ non_bincompat_options,
1770                               sizeof(non_bincompat_options) - 1, SVs_TEMP));
1771
1772 #ifdef __DATE__
1773 #  ifdef __TIME__
1774     PUSHs(Perl_newSVpvn_flags(aTHX_
1775                               STR_WITH_LEN("Compiled at " __DATE__ " " __TIME__),
1776                               SVs_TEMP));
1777 #  else
1778     PUSHs(Perl_newSVpvn_flags(aTHX_ STR_WITH_LEN("Compiled on " __DATE__),
1779                               SVs_TEMP));
1780 #  endif
1781 #else
1782     PUSHs(&PL_sv_undef);
1783 #endif
1784
1785     for (i = 1; i <= local_patch_count; i++) {
1786         /* This will be an undef, if PL_localpatches[i] is NULL.  */
1787         PUSHs(sv_2mortal(newSVpv(PL_localpatches[i], 0)));
1788     }
1789
1790     XSRETURN(entries);
1791 }
1792
1793 #define INCPUSH_UNSHIFT                 0x01
1794 #define INCPUSH_ADD_OLD_VERS            0x02
1795 #define INCPUSH_ADD_VERSIONED_SUB_DIRS  0x04
1796 #define INCPUSH_ADD_ARCHONLY_SUB_DIRS   0x08
1797 #define INCPUSH_NOT_BASEDIR             0x10
1798 #define INCPUSH_CAN_RELOCATE            0x20
1799 #define INCPUSH_ADD_SUB_DIRS    \
1800     (INCPUSH_ADD_VERSIONED_SUB_DIRS|INCPUSH_ADD_ARCHONLY_SUB_DIRS)
1801
1802 STATIC void *
1803 S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
1804 {
1805     dVAR;
1806     PerlIO *rsfp;
1807     int argc = PL_origargc;
1808     char **argv = PL_origargv;
1809     const char *scriptname = NULL;
1810     VOL bool dosearch = FALSE;
1811     char c;
1812     bool doextract = FALSE;
1813     const char *cddir = NULL;
1814 #ifdef USE_SITECUSTOMIZE
1815     bool minus_f = FALSE;
1816 #endif
1817     SV *linestr_sv = NULL;
1818     bool add_read_e_script = FALSE;
1819     U32 lex_start_flags = 0;
1820
1821     PERL_SET_PHASE(PERL_PHASE_START);
1822
1823     init_main_stash();
1824
1825     {
1826         const char *s;
1827     for (argc--,argv++; argc > 0; argc--,argv++) {
1828         if (argv[0][0] != '-' || !argv[0][1])
1829             break;
1830         s = argv[0]+1;
1831       reswitch:
1832         switch ((c = *s)) {
1833         case 'C':
1834 #ifndef PERL_STRICT_CR
1835         case '\r':
1836 #endif
1837         case ' ':
1838         case '0':
1839         case 'F':
1840         case 'a':
1841         case 'c':
1842         case 'd':
1843         case 'D':
1844         case 'h':
1845         case 'i':
1846         case 'l':
1847         case 'M':
1848         case 'm':
1849         case 'n':
1850         case 'p':
1851         case 's':
1852         case 'u':
1853         case 'U':
1854         case 'v':
1855         case 'W':
1856         case 'X':
1857         case 'w':
1858             if ((s = moreswitches(s)))
1859                 goto reswitch;
1860             break;
1861
1862         case 't':
1863 #if defined(SILENT_NO_TAINT_SUPPORT)
1864             /* silently ignore */
1865 #elif defined(NO_TAINT_SUPPORT)
1866             Perl_croak_nocontext("This perl was compiled without taint support. "
1867                        "Cowardly refusing to run with -t or -T flags");
1868 #else
1869             CHECK_MALLOC_TOO_LATE_FOR('t');
1870             if( !TAINTING_get ) {
1871                  TAINT_WARN_set(TRUE);
1872                  TAINTING_set(TRUE);
1873             }
1874 #endif
1875             s++;
1876             goto reswitch;
1877         case 'T':
1878 #if defined(SILENT_NO_TAINT_SUPPORT)
1879             /* silently ignore */
1880 #elif defined(NO_TAINT_SUPPORT)
1881             Perl_croak_nocontext("This perl was compiled without taint support. "
1882                        "Cowardly refusing to run with -t or -T flags");
1883 #else
1884             CHECK_MALLOC_TOO_LATE_FOR('T');
1885             TAINTING_set(TRUE);
1886             TAINT_WARN_set(FALSE);
1887 #endif
1888             s++;
1889             goto reswitch;
1890
1891         case 'E':
1892             PL_minus_E = TRUE;
1893             /* FALLTHROUGH */
1894         case 'e':
1895             forbid_setid('e', FALSE);
1896             if (!PL_e_script) {
1897                 PL_e_script = newSVpvs("");
1898                 add_read_e_script = TRUE;
1899             }
1900             if (*++s)
1901                 sv_catpv(PL_e_script, s);
1902             else if (argv[1]) {
1903                 sv_catpv(PL_e_script, argv[1]);
1904                 argc--,argv++;
1905             }
1906             else
1907                 Perl_croak(aTHX_ "No code specified for -%c", c);
1908             sv_catpvs(PL_e_script, "\n");
1909             break;
1910
1911         case 'f':
1912 #ifdef USE_SITECUSTOMIZE
1913             minus_f = TRUE;
1914 #endif
1915             s++;
1916             goto reswitch;
1917
1918         case 'I':       /* -I handled both here and in moreswitches() */
1919             forbid_setid('I', FALSE);
1920             if (!*++s && (s=argv[1]) != NULL) {
1921                 argc--,argv++;
1922             }
1923             if (s && *s) {
1924                 STRLEN len = strlen(s);
1925                 incpush(s, len, INCPUSH_ADD_SUB_DIRS|INCPUSH_ADD_OLD_VERS);
1926             }
1927             else
1928                 Perl_croak(aTHX_ "No directory specified for -I");
1929             break;
1930         case 'S':
1931             forbid_setid('S', FALSE);
1932             dosearch = TRUE;
1933             s++;
1934             goto reswitch;
1935         case 'V':
1936             {
1937                 SV *opts_prog;
1938
1939                 if (*++s != ':')  {
1940                     opts_prog = newSVpvs("use Config; Config::_V()");
1941                 }
1942                 else {
1943                     ++s;
1944                     opts_prog = Perl_newSVpvf(aTHX_
1945                                               "use Config; Config::config_vars(qw%c%s%c)",
1946                                               0, s, 0);
1947                     s += strlen(s);
1948                 }
1949                 Perl_av_create_and_push(aTHX_ &PL_preambleav, opts_prog);
1950                 /* don't look for script or read stdin */
1951                 scriptname = BIT_BUCKET;
1952                 goto reswitch;
1953             }
1954         case 'x':
1955             doextract = TRUE;
1956             s++;
1957             if (*s)
1958                 cddir = s;
1959             break;
1960         case 0:
1961             break;
1962         case '-':
1963             if (!*++s || isSPACE(*s)) {
1964                 argc--,argv++;
1965                 goto switch_end;
1966             }
1967             /* catch use of gnu style long options.
1968                Both of these exit immediately.  */
1969             if (strEQ(s, "version"))
1970                 minus_v();
1971             if (strEQ(s, "help"))
1972                 usage();
1973             s--;
1974             /* FALLTHROUGH */
1975         default:
1976             Perl_croak(aTHX_ "Unrecognized switch: -%s  (-h will show valid options)",s);
1977         }
1978     }
1979     }
1980
1981   switch_end:
1982
1983     {
1984         char *s;
1985
1986     if (
1987 #ifndef SECURE_INTERNAL_GETENV
1988         !TAINTING_get &&
1989 #endif
1990         (s = PerlEnv_getenv("PERL5OPT")))
1991     {
1992         while (isSPACE(*s))
1993             s++;
1994         if (*s == '-' && *(s+1) == 'T') {
1995 #if defined(SILENT_NO_TAINT_SUPPORT)
1996             /* silently ignore */
1997 #elif defined(NO_TAINT_SUPPORT)
1998             Perl_croak_nocontext("This perl was compiled without taint support. "
1999                        "Cowardly refusing to run with -t or -T flags");
2000 #else
2001             CHECK_MALLOC_TOO_LATE_FOR('T');
2002             TAINTING_set(TRUE);
2003             TAINT_WARN_set(FALSE);
2004 #endif
2005         }
2006         else {
2007             char *popt_copy = NULL;
2008             while (s && *s) {
2009                 const char *d;
2010                 while (isSPACE(*s))
2011                     s++;
2012                 if (*s == '-') {
2013                     s++;
2014                     if (isSPACE(*s))
2015                         continue;
2016                 }
2017                 d = s;
2018                 if (!*s)
2019                     break;
2020                 if (!strchr("CDIMUdmtwW", *s))
2021                     Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s);
2022                 while (++s && *s) {
2023                     if (isSPACE(*s)) {
2024                         if (!popt_copy) {
2025                             popt_copy = SvPVX(sv_2mortal(newSVpv(d,0)));
2026                             s = popt_copy + (s - d);
2027                             d = popt_copy;
2028                         }
2029                         *s++ = '\0';
2030                         break;
2031                     }
2032                 }
2033                 if (*d == 't') {
2034 #if defined(SILENT_NO_TAINT_SUPPORT)
2035             /* silently ignore */
2036 #elif defined(NO_TAINT_SUPPORT)
2037                     Perl_croak_nocontext("This perl was compiled without taint support. "
2038                                "Cowardly refusing to run with -t or -T flags");
2039 #else
2040                     if( !TAINTING_get) {
2041                         TAINT_WARN_set(TRUE);
2042                         TAINTING_set(TRUE);
2043                     }
2044 #endif
2045                 } else {
2046                     moreswitches(d);
2047                 }
2048             }
2049         }
2050     }
2051     }
2052
2053     /* Set $^X early so that it can be used for relocatable paths in @INC  */
2054     /* and for SITELIB_EXP in USE_SITECUSTOMIZE                            */
2055     assert (!TAINT_get);
2056     TAINT;
2057     set_caret_X();
2058     TAINT_NOT;
2059
2060 #if defined(USE_SITECUSTOMIZE)
2061     if (!minus_f) {
2062         /* The games with local $! are to avoid setting errno if there is no
2063            sitecustomize script.  "q%c...%c", 0, ..., 0 becomes "q\0...\0",
2064            ie a q() operator with a NUL byte as a the delimiter. This avoids
2065            problems with pathnames containing (say) '  */
2066 #  ifdef PERL_IS_MINIPERL
2067         AV *const inc = GvAV(PL_incgv);
2068         SV **const inc0 = inc ? av_fetch(inc, 0, FALSE) : NULL;
2069
2070         if (inc0) {
2071             /* if lib/buildcustomize.pl exists, it should not fail. If it does,
2072                it should be reported immediately as a build failure.  */
2073             (void)Perl_av_create_and_unshift_one(aTHX_ &PL_preambleav,
2074                                                  Perl_newSVpvf(aTHX_
2075                 "BEGIN { my $f = q%c%s%"SVf"/buildcustomize.pl%c; "
2076                         "do {local $!; -f $f }"
2077                         " and do $f || die $@ || qq '$f: $!' }",
2078                                 0, (TAINTING_get ? "./" : ""), SVfARG(*inc0), 0));
2079         }
2080 #  else
2081         /* SITELIB_EXP is a function call on Win32.  */
2082         const char *const raw_sitelib = SITELIB_EXP;
2083         if (raw_sitelib) {
2084             /* process .../.. if PERL_RELOCATABLE_INC is defined */
2085             SV *sitelib_sv = mayberelocate(raw_sitelib, strlen(raw_sitelib),
2086                                            INCPUSH_CAN_RELOCATE);
2087             const char *const sitelib = SvPVX(sitelib_sv);
2088             (void)Perl_av_create_and_unshift_one(aTHX_ &PL_preambleav,
2089                                                  Perl_newSVpvf(aTHX_
2090                                                                "BEGIN { do {local $!; -f q%c%s/sitecustomize.pl%c} && do q%c%s/sitecustomize.pl%c }",
2091                                                                0, SVfARG(sitelib), 0,
2092                                                                0, SVfARG(sitelib), 0));
2093             assert (SvREFCNT(sitelib_sv) == 1);
2094             SvREFCNT_dec(sitelib_sv);
2095         }
2096 #  endif
2097     }
2098 #endif
2099
2100     if (!scriptname)
2101         scriptname = argv[0];
2102     if (PL_e_script) {
2103         argc++,argv--;
2104         scriptname = BIT_BUCKET;        /* don't look for script or read stdin */
2105     }
2106     else if (scriptname == NULL) {
2107 #ifdef MSDOS
2108         if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) )
2109             moreswitches("h");
2110 #endif
2111         scriptname = "-";
2112     }
2113
2114     assert (!TAINT_get);
2115     init_perllib();
2116
2117     {
2118         bool suidscript = FALSE;
2119
2120         rsfp = open_script(scriptname, dosearch, &suidscript);
2121         if (!rsfp) {
2122             rsfp = PerlIO_stdin();
2123             lex_start_flags = LEX_DONT_CLOSE_RSFP;
2124         }
2125
2126         validate_suid(rsfp);
2127
2128 #ifndef PERL_MICRO
2129 #  if defined(SIGCHLD) || defined(SIGCLD)
2130         {
2131 #  ifndef SIGCHLD
2132 #    define SIGCHLD SIGCLD
2133 #  endif
2134             Sighandler_t sigstate = rsignal_state(SIGCHLD);
2135             if (sigstate == (Sighandler_t) SIG_IGN) {
2136                 Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL),
2137                                "Can't ignore signal CHLD, forcing to default");
2138                 (void)rsignal(SIGCHLD, (Sighandler_t)SIG_DFL);
2139             }
2140         }
2141 #  endif
2142 #endif
2143
2144         if (doextract) {
2145
2146             /* This will croak if suidscript is true, as -x cannot be used with
2147                setuid scripts.  */
2148             forbid_setid('x', suidscript);
2149             /* Hence you can't get here if suidscript is true */
2150
2151             linestr_sv = newSV_type(SVt_PV);
2152             lex_start_flags |= LEX_START_COPIED;
2153             find_beginning(linestr_sv, rsfp);
2154             if (cddir && PerlDir_chdir( (char *)cddir ) < 0)
2155                 Perl_croak(aTHX_ "Can't chdir to %s",cddir);
2156         }
2157     }
2158
2159     PL_main_cv = PL_compcv = MUTABLE_CV(newSV_type(SVt_PVCV));
2160     CvUNIQUE_on(PL_compcv);
2161
2162     CvPADLIST(PL_compcv) = pad_new(0);
2163
2164     PL_isarev = newHV();
2165
2166     boot_core_PerlIO();
2167     boot_core_UNIVERSAL();
2168     boot_core_mro();
2169     newXS("Internals::V", S_Internals_V, __FILE__);
2170
2171     if (xsinit)
2172         (*xsinit)(aTHX);        /* in case linked C routines want magical variables */
2173 #ifndef PERL_MICRO
2174 #if defined(VMS) || defined(WIN32) || defined(DJGPP) || defined(__CYGWIN__) || defined(SYMBIAN)
2175     init_os_extras();
2176 #endif
2177 #endif
2178
2179 #ifdef USE_SOCKS
2180 #   ifdef HAS_SOCKS5_INIT
2181     socks5_init(argv[0]);
2182 #   else
2183     SOCKSinit(argv[0]);
2184 #   endif
2185 #endif
2186
2187     init_predump_symbols();
2188     /* init_postdump_symbols not currently designed to be called */
2189     /* more than once (ENV isn't cleared first, for example)     */
2190     /* But running with -u leaves %ENV & @ARGV undefined!    XXX */
2191     if (!PL_do_undump)
2192         init_postdump_symbols(argc,argv,env);
2193
2194     /* PL_unicode is turned on by -C, or by $ENV{PERL_UNICODE},
2195      * or explicitly in some platforms.
2196      * locale.c:Perl_init_i18nl10n() if the environment
2197      * look like the user wants to use UTF-8. */
2198 #if defined(__SYMBIAN32__)
2199     PL_unicode = PERL_UNICODE_STD_FLAG; /* See PERL_SYMBIAN_CONSOLE_UTF8. */
2200 #endif
2201 #  ifndef PERL_IS_MINIPERL
2202     if (PL_unicode) {
2203          /* Requires init_predump_symbols(). */
2204          if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) {
2205               IO* io;
2206               PerlIO* fp;
2207               SV* sv;
2208
2209               /* Turn on UTF-8-ness on STDIN, STDOUT, STDERR
2210                * and the default open disciplines. */
2211               if ((PL_unicode & PERL_UNICODE_STDIN_FLAG) &&
2212                   PL_stdingv  && (io = GvIO(PL_stdingv)) &&
2213                   (fp = IoIFP(io)))
2214                    PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
2215               if ((PL_unicode & PERL_UNICODE_STDOUT_FLAG) &&
2216                   PL_defoutgv && (io = GvIO(PL_defoutgv)) &&
2217                   (fp = IoOFP(io)))
2218                    PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
2219               if ((PL_unicode & PERL_UNICODE_STDERR_FLAG) &&
2220                   PL_stderrgv && (io = GvIO(PL_stderrgv)) &&
2221                   (fp = IoOFP(io)))
2222                    PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
2223               if ((PL_unicode & PERL_UNICODE_INOUT_FLAG) &&
2224                   (sv = GvSV(gv_fetchpvs("\017PEN", GV_ADD|GV_NOTQUAL,
2225                                          SVt_PV)))) {
2226                    U32 in  = PL_unicode & PERL_UNICODE_IN_FLAG;
2227                    U32 out = PL_unicode & PERL_UNICODE_OUT_FLAG;
2228                    if (in) {
2229                         if (out)
2230                              sv_setpvs(sv, ":utf8\0:utf8");
2231                         else
2232                              sv_setpvs(sv, ":utf8\0");
2233                    }
2234                    else if (out)
2235                         sv_setpvs(sv, "\0:utf8");
2236                    SvSETMAGIC(sv);
2237               }
2238          }
2239     }
2240 #endif
2241
2242     {
2243         const char *s;
2244     if ((s = PerlEnv_getenv("PERL_SIGNALS"))) {
2245          if (strEQ(s, "unsafe"))
2246               PL_signals |=  PERL_SIGNALS_UNSAFE_FLAG;
2247          else if (strEQ(s, "safe"))
2248               PL_signals &= ~PERL_SIGNALS_UNSAFE_FLAG;
2249          else
2250               Perl_croak(aTHX_ "PERL_SIGNALS illegal: \"%s\"", s);
2251     }
2252     }
2253
2254
2255     lex_start(linestr_sv, rsfp, lex_start_flags);
2256     SvREFCNT_dec(linestr_sv);
2257
2258     PL_subname = newSVpvs("main");
2259
2260     if (add_read_e_script)
2261         filter_add(read_e_script, NULL);
2262
2263     /* now parse the script */
2264
2265     SETERRNO(0,SS_NORMAL);
2266     if (yyparse(GRAMPROG) || PL_parser->error_count) {
2267         if (PL_minus_c)
2268             Perl_croak(aTHX_ "%s had compilation errors.\n", PL_origfilename);
2269         else {
2270             Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
2271                        PL_origfilename);
2272         }
2273     }
2274     CopLINE_set(PL_curcop, 0);
2275     SET_CURSTASH(PL_defstash);
2276     if (PL_e_script) {
2277         SvREFCNT_dec(PL_e_script);
2278         PL_e_script = NULL;
2279     }
2280
2281     if (PL_do_undump)
2282         my_unexec();
2283
2284     if (isWARN_ONCE) {
2285         SAVECOPFILE(PL_curcop);
2286         SAVECOPLINE(PL_curcop);
2287         gv_check(PL_defstash);
2288     }
2289
2290     LEAVE;
2291     FREETMPS;
2292
2293 #ifdef MYMALLOC
2294     {
2295         const char *s;
2296         if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && grok_atou(s, NULL) >= 2)
2297             dump_mstats("after compilation:");
2298     }
2299 #endif
2300
2301     ENTER;
2302     PL_restartjmpenv = NULL;
2303     PL_restartop = 0;
2304     return NULL;
2305 }
2306
2307 /*
2308 =for apidoc perl_run
2309
2310 Tells a Perl interpreter to run.  See L<perlembed>.
2311
2312 =cut
2313 */
2314
2315 int
2316 perl_run(pTHXx)
2317 {
2318     I32 oldscope;
2319     int ret = 0;
2320     dJMPENV;
2321
2322     PERL_ARGS_ASSERT_PERL_RUN;
2323 #ifndef MULTIPLICITY
2324     PERL_UNUSED_ARG(my_perl);
2325 #endif
2326
2327     oldscope = PL_scopestack_ix;
2328 #ifdef VMS
2329     VMSISH_HUSHED = 0;
2330 #endif
2331
2332     JMPENV_PUSH(ret);
2333     switch (ret) {
2334     case 1:
2335         cxstack_ix = -1;                /* start context stack again */
2336         goto redo_body;
2337     case 0:                             /* normal completion */
2338  redo_body:
2339         run_body(oldscope);
2340         /* FALLTHROUGH */
2341     case 2:                             /* my_exit() */
2342         while (PL_scopestack_ix > oldscope)
2343             LEAVE;
2344         FREETMPS;
2345         SET_CURSTASH(PL_defstash);
2346         if (!(PL_exit_flags & PERL_EXIT_DESTRUCT_END) &&
2347             PL_endav && !PL_minus_c) {
2348             PERL_SET_PHASE(PERL_PHASE_END);
2349             call_list(oldscope, PL_endav);
2350         }
2351 #ifdef MYMALLOC
2352         if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
2353             dump_mstats("after execution:  ");
2354 #endif
2355         ret = STATUS_EXIT;
2356         break;
2357     case 3:
2358         if (PL_restartop) {
2359             POPSTACK_TO(PL_mainstack);
2360             goto redo_body;
2361         }
2362         PerlIO_printf(Perl_error_log, "panic: restartop in perl_run\n");
2363         FREETMPS;
2364         ret = 1;
2365         break;
2366     }
2367
2368     JMPENV_POP;
2369     return ret;
2370 }
2371
2372 STATIC void
2373 S_run_body(pTHX_ I32 oldscope)
2374 {
2375     DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support (0x%x).\n",
2376                     PL_sawampersand ? "Enabling" : "Omitting",
2377                     (unsigned int)(PL_sawampersand)));
2378
2379     if (!PL_restartop) {
2380 #ifdef DEBUGGING
2381         if (DEBUG_x_TEST || DEBUG_B_TEST)
2382             dump_all_perl(!DEBUG_B_TEST);
2383         if (!DEBUG_q_TEST)
2384           PERL_DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
2385 #endif
2386
2387         if (PL_minus_c) {
2388             PerlIO_printf(Perl_error_log, "%s syntax OK\n", PL_origfilename);
2389             my_exit(0);
2390         }
2391         if (PERLDB_SINGLE && PL_DBsingle)
2392             sv_setiv(PL_DBsingle, 1);
2393         if (PL_initav) {
2394             PERL_SET_PHASE(PERL_PHASE_INIT);
2395             call_list(oldscope, PL_initav);
2396         }
2397 #ifdef PERL_DEBUG_READONLY_OPS
2398         if (PL_main_root && PL_main_root->op_slabbed)
2399             Slab_to_ro(OpSLAB(PL_main_root));
2400 #endif
2401     }
2402
2403     /* do it */
2404
2405     PERL_SET_PHASE(PERL_PHASE_RUN);
2406
2407     if (PL_restartop) {
2408         PL_restartjmpenv = NULL;
2409         PL_op = PL_restartop;
2410         PL_restartop = 0;
2411         CALLRUNOPS(aTHX);
2412     }
2413     else if (PL_main_start) {
2414         CvDEPTH(PL_main_cv) = 1;
2415         PL_op = PL_main_start;
2416         CALLRUNOPS(aTHX);
2417     }
2418     my_exit(0);
2419     assert(0); /* NOTREACHED */
2420 }
2421
2422 /*
2423 =head1 SV Manipulation Functions
2424
2425 =for apidoc p||get_sv
2426
2427 Returns the SV of the specified Perl scalar.  C<flags> are passed to
2428 C<gv_fetchpv>.  If C<GV_ADD> is set and the
2429 Perl variable does not exist then it will be created.  If C<flags> is zero
2430 and the variable does not exist then NULL is returned.
2431
2432 =cut
2433 */
2434
2435 SV*
2436 Perl_get_sv(pTHX_ const char *name, I32 flags)
2437 {
2438     GV *gv;
2439
2440     PERL_ARGS_ASSERT_GET_SV;
2441
2442     gv = gv_fetchpv(name, flags, SVt_PV);
2443     if (gv)
2444         return GvSV(gv);
2445     return NULL;
2446 }
2447
2448 /*
2449 =head1 Array Manipulation Functions
2450
2451 =for apidoc p||get_av
2452
2453 Returns the AV of the specified Perl global or package array with the given
2454 name (so it won't work on lexical variables).  C<flags> are passed
2455 to C<gv_fetchpv>.  If C<GV_ADD> is set and the
2456 Perl variable does not exist then it will be created.  If C<flags> is zero
2457 and the variable does not exist then NULL is returned.
2458
2459 Perl equivalent: C<@{"$name"}>.
2460
2461 =cut
2462 */
2463
2464 AV*
2465 Perl_get_av(pTHX_ const char *name, I32 flags)
2466 {
2467     GV* const gv = gv_fetchpv(name, flags, SVt_PVAV);
2468
2469     PERL_ARGS_ASSERT_GET_AV;
2470
2471     if (flags)
2472         return GvAVn(gv);
2473     if (gv)
2474         return GvAV(gv);
2475     return NULL;
2476 }
2477
2478 /*
2479 =head1 Hash Manipulation Functions
2480
2481 =for apidoc p||get_hv
2482
2483 Returns the HV of the specified Perl hash.  C<flags> are passed to
2484 C<gv_fetchpv>.  If C<GV_ADD> is set and the
2485 Perl variable does not exist then it will be created.  If C<flags> is zero
2486 and the variable does not exist then NULL is returned.
2487
2488 =cut
2489 */
2490
2491 HV*
2492 Perl_get_hv(pTHX_ const char *name, I32 flags)
2493 {
2494     GV* const gv = gv_fetchpv(name, flags, SVt_PVHV);
2495
2496     PERL_ARGS_ASSERT_GET_HV;
2497
2498     if (flags)
2499         return GvHVn(gv);
2500     if (gv)
2501         return GvHV(gv);
2502     return NULL;
2503 }
2504
2505 /*
2506 =head1 CV Manipulation Functions
2507
2508 =for apidoc p||get_cvn_flags
2509
2510 Returns the CV of the specified Perl subroutine.  C<flags> are passed to
2511 C<gv_fetchpvn_flags>.  If C<GV_ADD> is set and the Perl subroutine does not
2512 exist then it will be declared (which has the same effect as saying
2513 C<sub name;>).  If C<GV_ADD> is not set and the subroutine does not exist
2514 then NULL is returned.
2515
2516 =for apidoc p||get_cv
2517
2518 Uses C<strlen> to get the length of C<name>, then calls C<get_cvn_flags>.
2519
2520 =cut
2521 */
2522
2523 CV*
2524 Perl_get_cvn_flags(pTHX_ const char *name, STRLEN len, I32 flags)
2525 {
2526     GV* const gv = gv_fetchpvn_flags(name, len, flags, SVt_PVCV);
2527
2528     PERL_ARGS_ASSERT_GET_CVN_FLAGS;
2529
2530     /* XXX this is probably not what they think they're getting.
2531      * It has the same effect as "sub name;", i.e. just a forward
2532      * declaration! */
2533     if ((flags & ~GV_NOADD_MASK) && !GvCVu(gv)) {
2534         return newSTUB(gv,0);
2535     }
2536     if (gv)
2537         return GvCVu(gv);
2538     return NULL;
2539 }
2540
2541 /* Nothing in core calls this now, but we can't replace it with a macro and
2542    move it to mathoms.c as a macro would evaluate name twice.  */
2543 CV*
2544 Perl_get_cv(pTHX_ const char *name, I32 flags)
2545 {
2546     PERL_ARGS_ASSERT_GET_CV;
2547
2548     return get_cvn_flags(name, strlen(name), flags);
2549 }
2550
2551 /* Be sure to refetch the stack pointer after calling these routines. */
2552
2553 /*
2554
2555 =head1 Callback Functions
2556
2557 =for apidoc p||call_argv
2558
2559 Performs a callback to the specified named and package-scoped Perl subroutine
2560 with C<argv> (a NULL-terminated array of strings) as arguments.  See
2561 L<perlcall>.
2562
2563 Approximate Perl equivalent: C<&{"$sub_name"}(@$argv)>.
2564
2565 =cut
2566 */
2567
2568 I32
2569 Perl_call_argv(pTHX_ const char *sub_name, I32 flags, char **argv)
2570
2571                         /* See G_* flags in cop.h */
2572                         /* null terminated arg list */
2573 {
2574     dSP;
2575
2576     PERL_ARGS_ASSERT_CALL_ARGV;
2577
2578     PUSHMARK(SP);
2579     if (argv) {
2580         while (*argv) {
2581             mXPUSHs(newSVpv(*argv,0));
2582             argv++;
2583         }
2584         PUTBACK;
2585     }
2586     return call_pv(sub_name, flags);
2587 }
2588
2589 /*
2590 =for apidoc p||call_pv
2591
2592 Performs a callback to the specified Perl sub.  See L<perlcall>.
2593
2594 =cut
2595 */
2596
2597 I32
2598 Perl_call_pv(pTHX_ const char *sub_name, I32 flags)
2599                         /* name of the subroutine */
2600                         /* See G_* flags in cop.h */
2601 {
2602     PERL_ARGS_ASSERT_CALL_PV;
2603
2604     return call_sv(MUTABLE_SV(get_cv(sub_name, GV_ADD)), flags);
2605 }
2606
2607 /*
2608 =for apidoc p||call_method
2609
2610 Performs a callback to the specified Perl method.  The blessed object must
2611 be on the stack.  See L<perlcall>.
2612
2613 =cut
2614 */
2615
2616 I32
2617 Perl_call_method(pTHX_ const char *methname, I32 flags)
2618                         /* name of the subroutine */
2619                         /* See G_* flags in cop.h */
2620 {
2621     STRLEN len;
2622     SV* sv;
2623     PERL_ARGS_ASSERT_CALL_METHOD;
2624
2625     len = strlen(methname);
2626     sv = flags & G_METHOD_NAMED
2627         ? sv_2mortal(newSVpvn_share(methname, len,0))
2628         : newSVpvn_flags(methname, len, SVs_TEMP);
2629
2630     return call_sv(sv, flags | G_METHOD);
2631 }
2632
2633 /* May be called with any of a CV, a GV, or an SV containing the name. */
2634 /*
2635 =for apidoc p||call_sv
2636
2637 Performs a callback to the Perl sub whose name is in the SV.  See
2638 L<perlcall>.
2639
2640 =cut
2641 */
2642
2643 I32
2644 Perl_call_sv(pTHX_ SV *sv, VOL I32 flags)
2645                         /* See G_* flags in cop.h */
2646 {
2647     dVAR; dSP;
2648     LOGOP myop;         /* fake syntax tree node */
2649     UNOP method_unop;
2650     SVOP method_svop;
2651     I32 oldmark;
2652     VOL I32 retval = 0;
2653     I32 oldscope;
2654     bool oldcatch = CATCH_GET;
2655     int ret;
2656     OP* const oldop = PL_op;
2657     dJMPENV;
2658
2659     PERL_ARGS_ASSERT_CALL_SV;
2660
2661     if (flags & G_DISCARD) {
2662         ENTER;
2663         SAVETMPS;
2664     }
2665     if (!(flags & G_WANT)) {
2666         /* Backwards compatibility - as G_SCALAR was 0, it could be omitted.
2667          */
2668         flags |= G_SCALAR;
2669     }
2670
2671     Zero(&myop, 1, LOGOP);
2672     if (!(flags & G_NOARGS))
2673         myop.op_flags |= OPf_STACKED;
2674     myop.op_flags |= OP_GIMME_REVERSE(flags);
2675     SAVEOP();
2676     PL_op = (OP*)&myop;
2677
2678     EXTEND(PL_stack_sp, 1);
2679     if (!(flags & G_METHOD_NAMED))
2680         *++PL_stack_sp = sv;
2681     oldmark = TOPMARK;
2682     oldscope = PL_scopestack_ix;
2683
2684     if (PERLDB_SUB && PL_curstash != PL_debstash
2685            /* Handle first BEGIN of -d. */
2686           && (PL_DBcv || (PL_DBcv = GvCV(PL_DBsub)))
2687            /* Try harder, since this may have been a sighandler, thus
2688             * curstash may be meaningless. */
2689           && (SvTYPE(sv) != SVt_PVCV || CvSTASH((const CV *)sv) != PL_debstash)
2690           && !(flags & G_NODEBUG))
2691         myop.op_private |= OPpENTERSUB_DB;
2692
2693     if (flags & (G_METHOD|G_METHOD_NAMED)) {
2694         if ( flags & G_METHOD_NAMED ) {
2695             Zero(&method_svop, 1, SVOP);
2696             method_svop.op_next = (OP*)&myop;
2697             method_svop.op_ppaddr = PL_ppaddr[OP_METHOD_NAMED];
2698             method_svop.op_type = OP_METHOD_NAMED;
2699             method_svop.op_sv = sv;
2700             PL_op = (OP*)&method_svop;
2701         } else {
2702             Zero(&method_unop, 1, UNOP);
2703             method_unop.op_next = (OP*)&myop;
2704             method_unop.op_ppaddr = PL_ppaddr[OP_METHOD];
2705             method_unop.op_type = OP_METHOD;
2706             PL_op = (OP*)&method_unop;
2707         }
2708         myop.op_ppaddr = PL_ppaddr[OP_ENTERSUB];
2709         myop.op_type = OP_ENTERSUB;
2710
2711     }
2712
2713     if (!(flags & G_EVAL)) {
2714         CATCH_SET(TRUE);
2715         CALL_BODY_SUB((OP*)&myop);
2716         retval = PL_stack_sp - (PL_stack_base + oldmark);
2717         CATCH_SET(oldcatch);
2718     }
2719     else {
2720         myop.op_other = (OP*)&myop;
2721         PL_markstack_ptr--;
2722         create_eval_scope(flags|G_FAKINGEVAL);
2723         PL_markstack_ptr++;
2724
2725         JMPENV_PUSH(ret);
2726
2727         switch (ret) {
2728         case 0:
2729  redo_body:
2730             CALL_BODY_SUB((OP*)&myop);
2731             retval = PL_stack_sp - (PL_stack_base + oldmark);
2732             if (!(flags & G_KEEPERR)) {
2733                 CLEAR_ERRSV();
2734             }
2735             break;
2736         case 1:
2737             STATUS_ALL_FAILURE;
2738             /* FALLTHROUGH */
2739         case 2:
2740             /* my_exit() was called */
2741             SET_CURSTASH(PL_defstash);
2742             FREETMPS;
2743             JMPENV_POP;
2744             my_exit_jump();
2745             assert(0); /* NOTREACHED */
2746         case 3:
2747             if (PL_restartop) {
2748                 PL_restartjmpenv = NULL;
2749                 PL_op = PL_restartop;
2750                 PL_restartop = 0;
2751                 goto redo_body;
2752             }
2753             PL_stack_sp = PL_stack_base + oldmark;
2754             if ((flags & G_WANT) == G_ARRAY)
2755                 retval = 0;
2756             else {
2757                 retval = 1;
2758                 *++PL_stack_sp = &PL_sv_undef;
2759             }
2760             break;
2761         }
2762
2763         if (PL_scopestack_ix > oldscope)
2764             delete_eval_scope();
2765         JMPENV_POP;
2766     }
2767
2768     if (flags & G_DISCARD) {
2769         PL_stack_sp = PL_stack_base + oldmark;
2770         retval = 0;
2771         FREETMPS;
2772         LEAVE;
2773     }
2774     PL_op = oldop;
2775     return retval;
2776 }
2777
2778 /* Eval a string. The G_EVAL flag is always assumed. */
2779
2780 /*
2781 =for apidoc p||eval_sv
2782
2783 Tells Perl to C<eval> the string in the SV.  It supports the same flags
2784 as C<call_sv>, with the obvious exception of G_EVAL.  See L<perlcall>.
2785
2786 =cut
2787 */
2788
2789 I32
2790 Perl_eval_sv(pTHX_ SV *sv, I32 flags)
2791
2792                         /* See G_* flags in cop.h */
2793 {
2794     dVAR;
2795     dSP;
2796     UNOP myop;          /* fake syntax tree node */
2797     VOL I32 oldmark = SP - PL_stack_base;
2798     VOL I32 retval = 0;
2799     int ret;
2800     OP* const oldop = PL_op;
2801     dJMPENV;
2802
2803     PERL_ARGS_ASSERT_EVAL_SV;
2804
2805     if (flags & G_DISCARD) {
2806         ENTER;
2807         SAVETMPS;
2808     }
2809
2810     SAVEOP();
2811     PL_op = (OP*)&myop;
2812     Zero(&myop, 1, UNOP);
2813     EXTEND(PL_stack_sp, 1);
2814     *++PL_stack_sp = sv;
2815
2816     if (!(flags & G_NOARGS))
2817         myop.op_flags = OPf_STACKED;
2818     myop.op_type = OP_ENTEREVAL;
2819     myop.op_flags |= OP_GIMME_REVERSE(flags);
2820     if (flags & G_KEEPERR)
2821         myop.op_flags |= OPf_SPECIAL;
2822
2823     if (flags & G_RE_REPARSING)
2824         myop.op_private = (OPpEVAL_COPHH | OPpEVAL_RE_REPARSING);
2825
2826     /* fail now; otherwise we could fail after the JMPENV_PUSH but
2827      * before a PUSHEVAL, which corrupts the stack after a croak */
2828     TAINT_PROPER("eval_sv()");
2829
2830     JMPENV_PUSH(ret);
2831     switch (ret) {
2832     case 0:
2833  redo_body:
2834         if (PL_op == (OP*)(&myop)) {
2835             PL_op = PL_ppaddr[OP_ENTEREVAL](aTHX);
2836             if (!PL_op)
2837                 goto fail; /* failed in compilation */
2838         }
2839         CALLRUNOPS(aTHX);
2840         retval = PL_stack_sp - (PL_stack_base + oldmark);
2841         if (!(flags & G_KEEPERR)) {
2842             CLEAR_ERRSV();
2843         }
2844         break;
2845     case 1:
2846         STATUS_ALL_FAILURE;
2847         /* FALLTHROUGH */
2848     case 2:
2849         /* my_exit() was called */
2850         SET_CURSTASH(PL_defstash);
2851         FREETMPS;
2852         JMPENV_POP;
2853         my_exit_jump();
2854         assert(0); /* NOTREACHED */
2855     case 3:
2856         if (PL_restartop) {
2857             PL_restartjmpenv = NULL;
2858             PL_op = PL_restartop;
2859             PL_restartop = 0;
2860             goto redo_body;
2861         }
2862       fail:
2863         PL_stack_sp = PL_stack_base + oldmark;
2864         if ((flags & G_WANT) == G_ARRAY)
2865             retval = 0;
2866         else {
2867             retval = 1;
2868             *++PL_stack_sp = &PL_sv_undef;
2869         }
2870         break;
2871     }
2872
2873     JMPENV_POP;
2874     if (flags & G_DISCARD) {
2875         PL_stack_sp = PL_stack_base + oldmark;
2876         retval = 0;
2877         FREETMPS;
2878         LEAVE;
2879     }
2880     PL_op = oldop;
2881     return retval;
2882 }
2883
2884 /*
2885 =for apidoc p||eval_pv
2886
2887 Tells Perl to C<eval> the given string in scalar context and return an SV* result.
2888
2889 =cut
2890 */
2891
2892 SV*
2893 Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error)
2894 {
2895     SV* sv = newSVpv(p, 0);
2896
2897     PERL_ARGS_ASSERT_EVAL_PV;
2898
2899     eval_sv(sv, G_SCALAR);
2900     SvREFCNT_dec(sv);
2901
2902     {
2903         dSP;
2904         sv = POPs;
2905         PUTBACK;
2906     }
2907
2908     /* just check empty string or undef? */
2909     if (croak_on_error) {
2910         SV * const errsv = ERRSV;
2911         if(SvTRUE_NN(errsv))
2912             /* replace with croak_sv? */
2913             Perl_croak_nocontext("%s", SvPV_nolen_const(errsv));
2914     }
2915
2916     return sv;
2917 }
2918
2919 /* Require a module. */
2920
2921 /*
2922 =head1 Embedding Functions
2923
2924 =for apidoc p||require_pv
2925
2926 Tells Perl to C<require> the file named by the string argument.  It is
2927 analogous to the Perl code C<eval "require '$file'">.  It's even
2928 implemented that way; consider using load_module instead.
2929
2930 =cut */
2931
2932 void
2933 Perl_require_pv(pTHX_ const char *pv)
2934 {
2935     dSP;
2936     SV* sv;
2937
2938     PERL_ARGS_ASSERT_REQUIRE_PV;
2939
2940     PUSHSTACKi(PERLSI_REQUIRE);
2941     sv = Perl_newSVpvf(aTHX_ "require q%c%s%c", 0, pv, 0);
2942     eval_sv(sv_2mortal(sv), G_DISCARD);
2943     POPSTACK;
2944 }
2945
2946 STATIC void
2947 S_usage(pTHX)           /* XXX move this out into a module ? */
2948 {
2949     /* This message really ought to be max 23 lines.
2950      * Removed -h because the user already knows that option. Others? */
2951
2952     /* Grouped as 6 lines per C string literal, to keep under the ANSI C 89
2953        minimum of 509 character string literals.  */
2954     static const char * const usage_msg[] = {
2955 "  -0[octal]         specify record separator (\\0, if no argument)\n"
2956 "  -a                autosplit mode with -n or -p (splits $_ into @F)\n"
2957 "  -C[number/list]   enables the listed Unicode features\n"
2958 "  -c                check syntax only (runs BEGIN and CHECK blocks)\n"
2959 "  -d[:debugger]     run program under debugger\n"
2960 "  -D[number/list]   set debugging flags (argument is a bit mask or alphabets)\n",
2961 "  -e program        one line of program (several -e's allowed, omit programfile)\n"
2962 "  -E program        like -e, but enables all optional features\n"
2963 "  -f                don't do $sitelib/sitecustomize.pl at startup\n"
2964 "  -F/pattern/       split() pattern for -a switch (//'s are optional)\n"
2965 "  -i[extension]     edit <> files in place (makes backup if extension supplied)\n"
2966 "  -Idirectory       specify @INC/#include directory (several -I's allowed)\n",
2967 "  -l[octal]         enable line ending processing, specifies line terminator\n"
2968 "  -[mM][-]module    execute \"use/no module...\" before executing program\n"
2969 "  -n                assume \"while (<>) { ... }\" loop around program\n"
2970 "  -p                assume loop like -n but print line also, like sed\n"
2971 "  -s                enable rudimentary parsing for switches after programfile\n"
2972 "  -S                look for programfile using PATH environment variable\n",
2973 "  -t                enable tainting warnings\n"
2974 "  -T                enable tainting checks\n"
2975 "  -u                dump core after parsing program\n"
2976 "  -U                allow unsafe operations\n"
2977 "  -v                print version, patchlevel and license\n"
2978 "  -V[:variable]     print configuration summary (or a single Config.pm variable)\n",
2979 "  -w                enable many useful warnings\n"
2980 "  -W                enable all warnings\n"
2981 "  -x[directory]     ignore text before #!perl line (optionally cd to directory)\n"
2982 "  -X                disable all warnings\n"
2983 "  \n"
2984 "Run 'perldoc perl' for more help with Perl.\n\n",
2985 NULL
2986 };
2987     const char * const *p = usage_msg;
2988     PerlIO *out = PerlIO_stdout();
2989
2990     PerlIO_printf(out,
2991                   "\nUsage: %s [switches] [--] [programfile] [arguments]\n",
2992                   PL_origargv[0]);
2993     while (*p)
2994         PerlIO_puts(out, *p++);
2995     my_exit(0);
2996 }
2997
2998 /* convert a string of -D options (or digits) into an int.
2999  * sets *s to point to the char after the options */
3000
3001 #ifdef DEBUGGING
3002 int
3003 Perl_get_debug_opts(pTHX_ const char **s, bool givehelp)
3004 {
3005     static const char * const usage_msgd[] = {
3006       " Debugging flag values: (see also -d)\n"
3007       "  p  Tokenizing and parsing (with v, displays parse stack)\n"
3008       "  s  Stack snapshots (with v, displays all stacks)\n"
3009       "  l  Context (loop) stack processing\n"
3010       "  t  Trace execution\n"
3011       "  o  Method and overloading resolution\n",
3012       "  c  String/numeric conversions\n"
3013       "  P  Print profiling info, source file input state\n"
3014       "  m  Memory and SV allocation\n"
3015       "  f  Format processing\n"
3016       "  r  Regular expression parsing and execution\n"
3017       "  x  Syntax tree dump\n",
3018       "  u  Tainting checks\n"
3019       "  H  Hash dump -- usurps values()\n"
3020       "  X  Scratchpad allocation\n"
3021       "  D  Cleaning up\n"
3022       "  S  Op slab allocation\n"
3023       "  T  Tokenising\n"
3024       "  R  Include reference counts of dumped variables (eg when using -Ds)\n",
3025       "  J  Do not s,t,P-debug (Jump over) opcodes within package DB\n"
3026       "  v  Verbose: use in conjunction with other flags\n"
3027       "  C  Copy On Write\n"
3028       "  A  Consistency checks on internal structures\n"
3029       "  q  quiet - currently only suppresses the 'EXECUTING' message\n"
3030       "  M  trace smart match resolution\n"
3031       "  B  dump suBroutine definitions, including special Blocks like BEGIN\n",
3032       "  L  trace some locale setting information--for Perl core development\n",
3033       NULL
3034     };
3035     int i = 0;
3036
3037     PERL_ARGS_ASSERT_GET_DEBUG_OPTS;
3038
3039     if (isALPHA(**s)) {
3040         /* if adding extra options, remember to update DEBUG_MASK */
3041         static const char debopts[] = "psltocPmfrxuUHXDSTRJvCAqMBL";
3042
3043         for (; isWORDCHAR(**s); (*s)++) {
3044             const char * const d = strchr(debopts,**s);
3045             if (d)
3046                 i |= 1 << (d - debopts);
3047             else if (ckWARN_d(WARN_DEBUGGING))
3048                 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
3049                     "invalid option -D%c, use -D'' to see choices\n", **s);
3050         }
3051     }
3052     else if (isDIGIT(**s)) {
3053         const char* e;
3054         i = grok_atou(*s, &e);
3055         if (e)
3056             *s = e;
3057         for (; isWORDCHAR(**s); (*s)++) ;
3058     }
3059     else if (givehelp) {
3060       const char *const *p = usage_msgd;
3061       while (*p) PerlIO_puts(PerlIO_stdout(), *p++);
3062     }
3063 #  ifdef EBCDIC
3064     if ((i & DEBUG_p_FLAG) && ckWARN_d(WARN_DEBUGGING))
3065         Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
3066                 "-Dp not implemented on this platform\n");
3067 #  endif
3068     return i;
3069 }
3070 #endif
3071
3072 /* This routine handles any switches that can be given during run */
3073
3074 const char *
3075 Perl_moreswitches(pTHX_ const char *s)
3076 {
3077     dVAR;
3078     UV rschar;
3079     const char option = *s; /* used to remember option in -m/-M code */
3080
3081     PERL_ARGS_ASSERT_MORESWITCHES;
3082
3083     switch (*s) {
3084     case '0':
3085     {
3086          I32 flags = 0;
3087          STRLEN numlen;
3088
3089          SvREFCNT_dec(PL_rs);
3090          if (s[1] == 'x' && s[2]) {
3091               const char *e = s+=2;
3092               U8 *tmps;
3093
3094               while (*e)
3095                 e++;
3096               numlen = e - s;
3097               flags = PERL_SCAN_SILENT_ILLDIGIT;
3098               rschar = (U32)grok_hex(s, &numlen, &flags, NULL);
3099               if (s + numlen < e) {
3100                    rschar = 0; /* Grandfather -0xFOO as -0 -xFOO. */
3101                    numlen = 0;
3102                    s--;
3103               }
3104               PL_rs = newSVpvs("");
3105               SvGROW(PL_rs, (STRLEN)(UNISKIP(rschar) + 1));
3106               tmps = (U8*)SvPVX(PL_rs);
3107               uvchr_to_utf8(tmps, rschar);
3108               SvCUR_set(PL_rs, UNISKIP(rschar));
3109               SvUTF8_on(PL_rs);
3110          }
3111          else {
3112               numlen = 4;
3113               rschar = (U32)grok_oct(s, &numlen, &flags, NULL);
3114               if (rschar & ~((U8)~0))
3115                    PL_rs = &PL_sv_undef;
3116               else if (!rschar && numlen >= 2)
3117                    PL_rs = newSVpvs("");
3118               else {
3119                    char ch = (char)rschar;
3120                    PL_rs = newSVpvn(&ch, 1);
3121               }
3122          }
3123          sv_setsv(get_sv("/", GV_ADD), PL_rs);
3124          return s + numlen;
3125     }
3126     case 'C':
3127         s++;
3128         PL_unicode = parse_unicode_opts( (const char **)&s );
3129         if (PL_unicode & PERL_UNICODE_UTF8CACHEASSERT_FLAG)
3130             PL_utf8cache = -1;
3131         return s;
3132     case 'F':
3133         PL_minus_a = TRUE;
3134         PL_minus_F = TRUE;
3135         PL_minus_n = TRUE;
3136         PL_splitstr = ++s;
3137         while (*s && !isSPACE(*s)) ++s;
3138         PL_splitstr = savepvn(PL_splitstr, s - PL_splitstr);
3139         return s;
3140     case 'a':
3141         PL_minus_a = TRUE;
3142         PL_minus_n = TRUE;
3143         s++;
3144         return s;
3145     case 'c':
3146         PL_minus_c = TRUE;
3147         s++;
3148         return s;
3149     case 'd':
3150         forbid_setid('d', FALSE);
3151         s++;
3152
3153         /* -dt indicates to the debugger that threads will be used */
3154         if (*s == 't' && !isWORDCHAR(s[1])) {
3155             ++s;
3156             my_setenv("PERL5DB_THREADED", "1");
3157         }
3158
3159         /* The following permits -d:Mod to accepts arguments following an =
3160            in the fashion that -MSome::Mod does. */
3161         if (*s == ':' || *s == '=') {
3162             const char *start;
3163             const char *end;
3164             SV *sv;
3165
3166             if (*++s == '-') {
3167                 ++s;
3168                 sv = newSVpvs("no Devel::");
3169             } else {
3170                 sv = newSVpvs("use Devel::");
3171             }
3172
3173             start = s;
3174             end = s + strlen(s);
3175
3176             /* We now allow -d:Module=Foo,Bar and -d:-Module */
3177             while(isWORDCHAR(*s) || *s==':') ++s;
3178             if (*s != '=')
3179                 sv_catpvn(sv, start, end - start);
3180             else {
3181                 sv_catpvn(sv, start, s-start);
3182                 /* Don't use NUL as q// delimiter here, this string goes in the
3183                  * environment. */
3184                 Perl_sv_catpvf(aTHX_ sv, " split(/,/,q{%s});", ++s);
3185             }
3186             s = end;
3187             my_setenv("PERL5DB", SvPV_nolen_const(sv));
3188             SvREFCNT_dec(sv);
3189         }
3190         if (!PL_perldb) {
3191             PL_perldb = PERLDB_ALL;
3192             init_debugger();
3193         }
3194         return s;
3195     case 'D':
3196     {
3197 #ifdef DEBUGGING
3198         forbid_setid('D', FALSE);
3199         s++;
3200         PL_debug = get_debug_opts( (const char **)&s, 1) | DEBUG_TOP_FLAG;
3201 #else /* !DEBUGGING */
3202         if (ckWARN_d(WARN_DEBUGGING))
3203             Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
3204                    "Recompile perl with -DDEBUGGING to use -D switch (did you mean -d ?)\n");
3205         for (s++; isWORDCHAR(*s); s++) ;
3206 #endif
3207         return s;
3208     }
3209     case 'h':
3210         usage();
3211     case 'i':
3212         Safefree(PL_inplace);
3213 #if defined(__CYGWIN__) /* do backup extension automagically */
3214         if (*(s+1) == '\0') {
3215         PL_inplace = savepvs(".bak");
3216         return s+1;
3217         }
3218 #endif /* __CYGWIN__ */
3219         {
3220             const char * const start = ++s;
3221             while (*s && !isSPACE(*s))
3222                 ++s;
3223
3224             PL_inplace = savepvn(start, s - start);
3225         }
3226         if (*s) {
3227             ++s;
3228             if (*s == '-')      /* Additional switches on #! line. */
3229                 s++;
3230         }
3231         return s;
3232     case 'I':   /* -I handled both here and in parse_body() */
3233         forbid_setid('I', FALSE);
3234         ++s;
3235         while (*s && isSPACE(*s))
3236             ++s;
3237         if (*s) {
3238             const char *e, *p;
3239             p = s;
3240             /* ignore trailing spaces (possibly followed by other switches) */
3241             do {
3242                 for (e = p; *e && !isSPACE(*e); e++) ;
3243                 p = e;
3244                 while (isSPACE(*p))
3245                     p++;
3246             } while (*p && *p != '-');
3247             incpush(s, e-s,
3248                     INCPUSH_ADD_SUB_DIRS|INCPUSH_ADD_OLD_VERS|INCPUSH_UNSHIFT);
3249             s = p;
3250             if (*s == '-')
3251                 s++;
3252         }
3253         else
3254             Perl_croak(aTHX_ "No directory specified for -I");
3255         return s;
3256     case 'l':
3257         PL_minus_l = TRUE;
3258         s++;
3259         if (PL_ors_sv) {
3260             SvREFCNT_dec(PL_ors_sv);
3261             PL_ors_sv = NULL;
3262         }
3263         if (isDIGIT(*s)) {
3264             I32 flags = 0;
3265             STRLEN numlen;
3266             PL_ors_sv = newSVpvs("\n");
3267             numlen = 3 + (*s == '0');
3268             *SvPVX(PL_ors_sv) = (char)grok_oct(s, &numlen, &flags, NULL);
3269             s += numlen;
3270         }
3271         else {
3272             if (RsPARA(PL_rs)) {
3273                 PL_ors_sv = newSVpvs("\n\n");
3274             }
3275             else {
3276                 PL_ors_sv = newSVsv(PL_rs);
3277             }
3278         }
3279         return s;
3280     case 'M':
3281         forbid_setid('M', FALSE);       /* XXX ? */
3282         /* FALLTHROUGH */
3283     case 'm':
3284         forbid_setid('m', FALSE);       /* XXX ? */
3285         if (*++s) {
3286             const char *start;
3287             const char *end;
3288             SV *sv;
3289             const char *use = "use ";
3290             bool colon = FALSE;
3291             /* -M-foo == 'no foo'       */
3292             /* Leading space on " no " is deliberate, to make both
3293                possibilities the same length.  */
3294             if (*s == '-') { use = " no "; ++s; }
3295             sv = newSVpvn(use,4);
3296             start = s;
3297             /* We allow -M'Module qw(Foo Bar)'  */
3298             while(isWORDCHAR(*s) || *s==':') {
3299                 if( *s++ == ':' ) {
3300                     if( *s == ':' )
3301                         s++;
3302                     else
3303                         colon = TRUE;
3304                 }
3305             }
3306             if (s == start)
3307                 Perl_croak(aTHX_ "Module name required with -%c option",
3308                                     option);
3309             if (colon)
3310                 Perl_croak(aTHX_ "Invalid module name %.*s with -%c option: "
3311                                     "contains single ':'",
3312                                     (int)(s - start), start, option);
3313             end = s + strlen(s);
3314             if (*s != '=') {
3315                 sv_catpvn(sv, start, end - start);
3316                 if (option == 'm') {
3317                     if (*s != '\0')
3318                         Perl_croak(aTHX_ "Can't use '%c' after -mname", *s);
3319                     sv_catpvs( sv, " ()");
3320                 }
3321             } else {
3322                 sv_catpvn(sv, start, s-start);
3323                 /* Use NUL as q''-delimiter.  */
3324                 sv_catpvs(sv, " split(/,/,q\0");
3325                 ++s;
3326                 sv_catpvn(sv, s, end - s);
3327                 sv_catpvs(sv,  "\0)");
3328             }
3329             s = end;
3330             Perl_av_create_and_push(aTHX_ &PL_preambleav, sv);
3331         }
3332         else
3333             Perl_croak(aTHX_ "Missing argument to -%c", option);
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', FALSE);
3345         PL_doswitches = TRUE;
3346         s++;
3347         return s;
3348     case 't':
3349     case 'T':
3350 #if defined(SILENT_NO_TAINT_SUPPORT)
3351             /* silently ignore */
3352 #elif defined(NO_TAINT_SUPPORT)
3353         Perl_croak_nocontext("This perl was compiled without taint support. "
3354                    "Cowardly refusing to run with -t or -T flags");
3355 #else
3356         if (!TAINTING_get)
3357             TOO_LATE_FOR(*s);
3358 #endif
3359         s++;
3360         return s;
3361     case 'u':
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         minus_v();
3371     case 'w':
3372         if (! (PL_dowarn & G_WARN_ALL_MASK)) {
3373             PL_dowarn |= G_WARN_ON;
3374         }
3375         s++;
3376         return s;
3377     case 'W':
3378         PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
3379         if (!specialWARN(PL_compiling.cop_warnings))
3380             PerlMemShared_free(PL_compiling.cop_warnings);
3381         PL_compiling.cop_warnings = pWARN_ALL ;
3382         s++;
3383         return s;
3384     case 'X':
3385         PL_dowarn = G_WARN_ALL_OFF;
3386         if (!specialWARN(PL_compiling.cop_warnings))
3387             PerlMemShared_free(PL_compiling.cop_warnings);
3388         PL_compiling.cop_warnings = pWARN_NONE ;
3389         s++;
3390         return s;
3391     case '*':
3392     case ' ':
3393         while( *s == ' ' )
3394           ++s;
3395         if (s[0] == '-')        /* Additional switches on #! line. */
3396             return s+1;
3397         break;
3398     case '-':
3399     case 0:
3400 #if defined(WIN32) || !defined(PERL_STRICT_CR)
3401     case '\r':
3402 #endif
3403     case '\n':
3404     case '\t':
3405         break;
3406 #ifdef ALTERNATE_SHEBANG
3407     case 'S':                   /* OS/2 needs -S on "extproc" line. */
3408         break;
3409 #endif
3410     case 'e': case 'f': case 'x': case 'E':
3411 #ifndef ALTERNATE_SHEBANG
3412     case 'S':
3413 #endif
3414     case 'V':
3415         Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s);
3416     default:
3417         Perl_croak(aTHX_
3418             "Unrecognized switch: -%.1s  (-h will show valid options)",s
3419         );
3420     }
3421     return NULL;
3422 }
3423
3424
3425 STATIC void
3426 S_minus_v(pTHX)
3427 {
3428         PerlIO * PIO_stdout;
3429         {
3430             const char * const level_str = "v" PERL_VERSION_STRING;
3431             const STRLEN level_len = sizeof("v" PERL_VERSION_STRING)-1;
3432 #ifdef PERL_PATCHNUM
3433             SV* level;
3434 #  ifdef PERL_GIT_UNCOMMITTED_CHANGES
3435             static const char num [] = PERL_PATCHNUM "*";
3436 #  else
3437             static const char num [] = PERL_PATCHNUM;
3438 #  endif
3439             {
3440                 const STRLEN num_len = sizeof(num)-1;
3441                 /* A very advanced compiler would fold away the strnEQ
3442                    and this whole conditional, but most (all?) won't do it.
3443                    SV level could also be replaced by with preprocessor
3444                    catenation.
3445                 */
3446                 if (num_len >= level_len && strnEQ(num,level_str,level_len)) {
3447                     /* per 46807d8e80, PERL_PATCHNUM is outside of the control
3448                        of the interp so it might contain format characters
3449                     */
3450                     level = newSVpvn(num, num_len);
3451                 } else {
3452                     level = Perl_newSVpvf_nocontext("%s (%s)", level_str, num);
3453                 }
3454             }
3455 #else
3456         SV* level = newSVpvn(level_str, level_len);
3457 #endif /* #ifdef PERL_PATCHNUM */
3458         PIO_stdout =  PerlIO_stdout();
3459             PerlIO_printf(PIO_stdout,
3460                 "\nThis is perl "       STRINGIFY(PERL_REVISION)
3461                 ", version "            STRINGIFY(PERL_VERSION)
3462                 ", subversion "         STRINGIFY(PERL_SUBVERSION)
3463                 " (%"SVf") built for "  ARCHNAME, SVfARG(level)
3464                 );
3465             SvREFCNT_dec_NN(level);
3466         }
3467 #if defined(LOCAL_PATCH_COUNT)
3468         if (LOCAL_PATCH_COUNT > 0)
3469             PerlIO_printf(PIO_stdout,
3470                           "\n(with %d registered patch%s, "
3471                           "see perl -V for more detail)",
3472                           LOCAL_PATCH_COUNT,
3473                           (LOCAL_PATCH_COUNT!=1) ? "es" : "");
3474 #endif
3475
3476         PerlIO_printf(PIO_stdout,
3477                       "\n\nCopyright 1987-2014, Larry Wall\n");
3478 #ifdef MSDOS
3479         PerlIO_printf(PIO_stdout,
3480                       "\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
3481 #endif
3482 #ifdef DJGPP
3483         PerlIO_printf(PIO_stdout,
3484                       "djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n"
3485                       "djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n");
3486 #endif
3487 #ifdef OS2
3488         PerlIO_printf(PIO_stdout,
3489                       "\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
3490                       "Version 5 port Copyright (c) 1994-2002, Andreas Kaiser, Ilya Zakharevich\n");
3491 #endif
3492 #ifdef OEMVS
3493         PerlIO_printf(PIO_stdout,
3494                       "MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
3495 #endif
3496 #ifdef __VOS__
3497         PerlIO_printf(PIO_stdout,
3498                       "Stratus OpenVOS port by Paul.Green@stratus.com, 1997-2013\n");
3499 #endif
3500 #ifdef POSIX_BC
3501         PerlIO_printf(PIO_stdout,
3502                       "BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
3503 #endif
3504 #ifdef UNDER_CE
3505         PerlIO_printf(PIO_stdout,
3506                         "WINCE port by Rainer Keuchel, 2001-2002\n"
3507                         "Built on " __DATE__ " " __TIME__ "\n\n");
3508         wce_hitreturn();
3509 #endif
3510 #ifdef __SYMBIAN32__
3511         PerlIO_printf(PIO_stdout,
3512                       "Symbian port by Nokia, 2004-2005\n");
3513 #endif
3514 #ifdef BINARY_BUILD_NOTICE
3515         BINARY_BUILD_NOTICE;
3516 #endif
3517         PerlIO_printf(PIO_stdout,
3518                       "\n\
3519 Perl may be copied only under the terms of either the Artistic License or the\n\
3520 GNU General Public License, which may be found in the Perl 5 source kit.\n\n\
3521 Complete documentation for Perl, including FAQ lists, should be found on\n\
3522 this system using \"man perl\" or \"perldoc perl\".  If you have access to the\n\
3523 Internet, point your browser at http://www.perl.org/, the Perl Home Page.\n\n");
3524         my_exit(0);
3525 }
3526
3527 /* compliments of Tom Christiansen */
3528
3529 /* unexec() can be found in the Gnu emacs distribution */
3530 /* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
3531
3532 #ifdef VMS
3533 #include <lib$routines.h>
3534 #endif
3535
3536 void
3537 Perl_my_unexec(pTHX)
3538 {
3539 #ifdef UNEXEC
3540     SV *    prog = newSVpv(BIN_EXP, 0);
3541     SV *    file = newSVpv(PL_origfilename, 0);
3542     int    status = 1;
3543     extern int etext;
3544
3545     sv_catpvs(prog, "/perl");
3546     sv_catpvs(file, ".perldump");
3547
3548     unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
3549     /* unexec prints msg to stderr in case of failure */
3550     PerlProc_exit(status);
3551 #else
3552     PERL_UNUSED_CONTEXT;
3553 #  ifdef VMS
3554      lib$signal(SS$_DEBUG);  /* ssdef.h #included from vmsish.h */
3555 #  elif defined(WIN32) || defined(__CYGWIN__)
3556     Perl_croak_nocontext("dump is not supported");
3557 #  else
3558     ABORT();            /* for use with undump */
3559 #  endif
3560 #endif
3561 }
3562
3563 /* initialize curinterp */
3564 STATIC void
3565 S_init_interp(pTHX)
3566 {
3567 #ifdef MULTIPLICITY
3568 #  define PERLVAR(prefix,var,type)
3569 #  define PERLVARA(prefix,var,n,type)
3570 #  if defined(PERL_IMPLICIT_CONTEXT)
3571 #    define PERLVARI(prefix,var,type,init)      aTHX->prefix##var = init;
3572 #    define PERLVARIC(prefix,var,type,init)     aTHX->prefix##var = init;
3573 #  else
3574 #    define PERLVARI(prefix,var,type,init)      PERL_GET_INTERP->var = init;
3575 #    define PERLVARIC(prefix,var,type,init)     PERL_GET_INTERP->var = init;
3576 #  endif
3577 #  include "intrpvar.h"
3578 #  undef PERLVAR
3579 #  undef PERLVARA
3580 #  undef PERLVARI
3581 #  undef PERLVARIC
3582 #else
3583 #  define PERLVAR(prefix,var,type)
3584 #  define PERLVARA(prefix,var,n,type)
3585 #  define PERLVARI(prefix,var,type,init)        PL_##var = init;
3586 #  define PERLVARIC(prefix,var,type,init)       PL_##var = init;
3587 #  include "intrpvar.h"
3588 #  undef PERLVAR
3589 #  undef PERLVARA
3590 #  undef PERLVARI
3591 #  undef PERLVARIC
3592 #endif
3593
3594 }
3595
3596 STATIC void
3597 S_init_main_stash(pTHX)
3598 {
3599     GV *gv;
3600
3601     PL_curstash = PL_defstash = (HV *)SvREFCNT_inc_simple_NN(newHV());
3602     /* We know that the string "main" will be in the global shared string
3603        table, so it's a small saving to use it rather than allocate another
3604        8 bytes.  */
3605     PL_curstname = newSVpvs_share("main");
3606     gv = gv_fetchpvs("main::", GV_ADD|GV_NOTQUAL, SVt_PVHV);
3607     /* If we hadn't caused another reference to "main" to be in the shared
3608        string table above, then it would be worth reordering these two,
3609        because otherwise all we do is delete "main" from it as a consequence
3610        of the SvREFCNT_dec, only to add it again with hv_name_set */
3611     SvREFCNT_dec(GvHV(gv));
3612     hv_name_set(PL_defstash, "main", 4, 0);
3613     GvHV(gv) = MUTABLE_HV(SvREFCNT_inc_simple(PL_defstash));
3614     SvREADONLY_on(gv);
3615     PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpvs("INC", GV_ADD|GV_NOTQUAL,
3616                                              SVt_PVAV)));
3617     SvREFCNT_inc_simple_void(PL_incgv); /* Don't allow it to be freed */
3618     GvMULTI_on(PL_incgv);
3619     PL_hintgv = gv_fetchpvs("\010", GV_ADD|GV_NOTQUAL, SVt_PV); /* ^H */
3620     SvREFCNT_inc_simple_void(PL_hintgv);
3621     GvMULTI_on(PL_hintgv);
3622     PL_defgv = gv_fetchpvs("_", GV_ADD|GV_NOTQUAL, SVt_PVAV);
3623     SvREFCNT_inc_simple_void(PL_defgv);
3624     PL_errgv = gv_fetchpvs("@", GV_ADD|GV_NOTQUAL, SVt_PV);
3625     SvREFCNT_inc_simple_void(PL_errgv);
3626     GvMULTI_on(PL_errgv);
3627     PL_replgv = gv_fetchpvs("\022", GV_ADD|GV_NOTQUAL, SVt_PV); /* ^R */
3628     SvREFCNT_inc_simple_void(PL_replgv);
3629     GvMULTI_on(PL_replgv);
3630     (void)Perl_form(aTHX_ "%240s","");  /* Preallocate temp - for immediate signals. */
3631 #ifdef PERL_DONT_CREATE_GVSV
3632     gv_SVadd(PL_errgv);
3633 #endif
3634     sv_grow(ERRSV, 240);        /* Preallocate - for immediate signals. */
3635     CLEAR_ERRSV();
3636     SET_CURSTASH(PL_defstash);
3637     CopSTASH_set(&PL_compiling, PL_defstash);
3638     PL_debstash = GvHV(gv_fetchpvs("DB::", GV_ADDMULTI, SVt_PVHV));
3639     PL_globalstash = GvHV(gv_fetchpvs("CORE::GLOBAL::", GV_ADDMULTI,
3640                                       SVt_PVHV));
3641     /* We must init $/ before switches are processed. */
3642     sv_setpvs(get_sv("/", GV_ADD), "\n");
3643 }
3644
3645 STATIC PerlIO *
3646 S_open_script(pTHX_ const char *scriptname, bool dosearch, bool *suidscript)
3647 {
3648     int fdscript = -1;
3649     PerlIO *rsfp = NULL;
3650     Stat_t tmpstatbuf;
3651     int fd;
3652
3653     PERL_ARGS_ASSERT_OPEN_SCRIPT;
3654
3655     if (PL_e_script) {
3656         PL_origfilename = savepvs("-e");
3657     }
3658     else {
3659         /* if find_script() returns, it returns a malloc()-ed value */
3660         scriptname = PL_origfilename = find_script(scriptname, dosearch, NULL, 1);
3661
3662         if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
3663             const char *s = scriptname + 8;
3664             const char* e;
3665             fdscript = grok_atou(s, &e);
3666             s = e;
3667             if (*s) {
3668                 /* PSz 18 Feb 04
3669                  * Tell apart "normal" usage of fdscript, e.g.
3670                  * with bash on FreeBSD:
3671                  *   perl <( echo '#!perl -DA'; echo 'print "$0\n"')
3672                  * from usage in suidperl.
3673                  * Does any "normal" usage leave garbage after the number???
3674                  * Is it a mistake to use a similar /dev/fd/ construct for
3675                  * suidperl?
3676                  */
3677                 *suidscript = TRUE;
3678                 /* PSz 20 Feb 04
3679                  * Be supersafe and do some sanity-checks.
3680                  * Still, can we be sure we got the right thing?
3681                  */
3682                 if (*s != '/') {
3683                     Perl_croak(aTHX_ "Wrong syntax (suid) fd script name \"%s\"\n", s);
3684                 }
3685                 if (! *(s+1)) {
3686                     Perl_croak(aTHX_ "Missing (suid) fd script name\n");
3687                 }
3688                 scriptname = savepv(s + 1);
3689                 Safefree(PL_origfilename);
3690                 PL_origfilename = (char *)scriptname;
3691             }
3692         }
3693     }
3694
3695     CopFILE_free(PL_curcop);
3696     CopFILE_set(PL_curcop, PL_origfilename);
3697     if (*PL_origfilename == '-' && PL_origfilename[1] == '\0')
3698         scriptname = (char *)"";
3699     if (fdscript >= 0) {
3700         rsfp = PerlIO_fdopen(fdscript,PERL_SCRIPT_MODE);
3701     }
3702     else if (!*scriptname) {
3703         forbid_setid(0, *suidscript);
3704         return NULL;
3705     }
3706     else {
3707 #ifdef FAKE_BIT_BUCKET
3708         /* This hack allows one not to have /dev/null (or BIT_BUCKET as it
3709          * is called) and still have the "-e" work.  (Believe it or not,
3710          * a /dev/null is required for the "-e" to work because source
3711          * filter magic is used to implement it. ) This is *not* a general
3712          * replacement for a /dev/null.  What we do here is create a temp
3713          * file (an empty file), open up that as the script, and then
3714          * immediately close and unlink it.  Close enough for jazz. */
3715 #define FAKE_BIT_BUCKET_PREFIX "/tmp/perlnull-"
3716 #define FAKE_BIT_BUCKET_SUFFIX "XXXXXXXX"
3717 #define FAKE_BIT_BUCKET_TEMPLATE FAKE_BIT_BUCKET_PREFIX FAKE_BIT_BUCKET_SUFFIX
3718         char tmpname[sizeof(FAKE_BIT_BUCKET_TEMPLATE)] = {
3719             FAKE_BIT_BUCKET_TEMPLATE
3720         };
3721         const char * const err = "Failed to create a fake bit bucket";
3722         if (strEQ(scriptname, BIT_BUCKET)) {
3723 #ifdef HAS_MKSTEMP /* Hopefully mkstemp() is safe here. */
3724             int old_umask = umask(0600);
3725             int tmpfd = mkstemp(tmpname);
3726             umask(old_umask);
3727             if (tmpfd > -1) {
3728                 scriptname = tmpname;
3729                 close(tmpfd);
3730             } else
3731                 Perl_croak(aTHX_ err);
3732 #else
3733 #  ifdef HAS_MKTEMP
3734             scriptname = mktemp(tmpname);
3735             if (!scriptname)
3736                 Perl_croak(aTHX_ err);
3737 #  endif
3738 #endif
3739         }
3740 #endif
3741         rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
3742 #ifdef FAKE_BIT_BUCKET
3743         if (memEQ(scriptname, FAKE_BIT_BUCKET_PREFIX,
3744                   sizeof(FAKE_BIT_BUCKET_PREFIX) - 1)
3745             && strlen(scriptname) == sizeof(tmpname) - 1) {
3746             unlink(scriptname);
3747         }
3748         scriptname = BIT_BUCKET;
3749 #endif
3750     }
3751     if (!rsfp) {
3752         /* PSz 16 Sep 03  Keep neat error message */
3753         if (PL_e_script)
3754             Perl_croak(aTHX_ "Can't open "BIT_BUCKET": %s\n", Strerror(errno));
3755         else
3756             Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
3757                     CopFILE(PL_curcop), Strerror(errno));
3758     }
3759     fd = PerlIO_fileno(rsfp);
3760 #if defined(HAS_FCNTL) && defined(F_SETFD)
3761     if (fd >= 0) {
3762         /* ensure close-on-exec */
3763         if (fcntl(fd, F_SETFD, 1) < 0) {
3764             Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
3765                        CopFILE(PL_curcop), Strerror(errno));
3766         }
3767     }
3768 #endif
3769
3770     if (fd < 0 ||
3771         (PerlLIO_fstat(fd, &tmpstatbuf) >= 0
3772          && S_ISDIR(tmpstatbuf.st_mode)))
3773         Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
3774             CopFILE(PL_curcop),
3775             Strerror(EISDIR));
3776
3777     return rsfp;
3778 }
3779
3780 /* Mention
3781  * I_SYSSTATVFS HAS_FSTATVFS
3782  * I_SYSMOUNT
3783  * I_STATFS     HAS_FSTATFS     HAS_GETFSSTAT
3784  * I_MNTENT     HAS_GETMNTENT   HAS_HASMNTOPT
3785  * here so that metaconfig picks them up. */
3786
3787
3788 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
3789 /* Don't even need this function.  */
3790 #else
3791 STATIC void
3792 S_validate_suid(pTHX_ PerlIO *rsfp)
3793 {
3794     const Uid_t  my_uid = PerlProc_getuid();
3795     const Uid_t my_euid = PerlProc_geteuid();
3796     const Gid_t  my_gid = PerlProc_getgid();
3797     const Gid_t my_egid = PerlProc_getegid();
3798
3799     PERL_ARGS_ASSERT_VALIDATE_SUID;
3800
3801     if (my_euid != my_uid || my_egid != my_gid) {       /* (suidperl doesn't exist, in fact) */
3802         dVAR;
3803         int fd = PerlIO_fileno(rsfp);
3804         if (fd < 0) {
3805             Perl_croak(aTHX_ "Illegal suidscript");
3806         } else {
3807             if (PerlLIO_fstat(fd, &PL_statbuf) < 0) {   /* may be either wrapped or real suid */
3808                 Perl_croak(aTHX_ "Illegal suidscript");
3809             }
3810         }
3811         if ((my_euid != my_uid && my_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
3812             ||
3813             (my_egid != my_gid && my_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
3814             )
3815             if (!PL_do_undump)
3816                 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
3817 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
3818         /* not set-id, must be wrapped */
3819     }
3820 }
3821 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
3822
3823 STATIC void
3824 S_find_beginning(pTHX_ SV* linestr_sv, PerlIO *rsfp)
3825 {
3826     const char *s;
3827     const char *s2;
3828
3829     PERL_ARGS_ASSERT_FIND_BEGINNING;
3830
3831     /* skip forward in input to the real script? */
3832
3833     do {
3834         if ((s = sv_gets(linestr_sv, rsfp, 0)) == NULL)
3835             Perl_croak(aTHX_ "No Perl script found in input\n");
3836         s2 = s;
3837     } while (!(*s == '#' && s[1] == '!' && ((s = instr(s,"perl")) || (s = instr(s2,"PERL")))));
3838     PerlIO_ungetc(rsfp, '\n');          /* to keep line count right */
3839     while (*s && !(isSPACE (*s) || *s == '#')) s++;
3840     s2 = s;
3841     while (*s == ' ' || *s == '\t') s++;
3842     if (*s++ == '-') {
3843         while (isDIGIT(s2[-1]) || s2[-1] == '-' || s2[-1] == '.'
3844                || s2[-1] == '_') s2--;
3845         if (strnEQ(s2-4,"perl",4))
3846             while ((s = moreswitches(s)))
3847                 ;
3848     }
3849 }
3850
3851
3852 STATIC void
3853 S_init_ids(pTHX)
3854 {
3855     /* no need to do anything here any more if we don't
3856      * do tainting. */
3857 #ifndef NO_TAINT_SUPPORT
3858     const Uid_t my_uid = PerlProc_getuid();
3859     const Uid_t my_euid = PerlProc_geteuid();
3860     const Gid_t my_gid = PerlProc_getgid();
3861     const Gid_t my_egid = PerlProc_getegid();
3862
3863     PERL_UNUSED_CONTEXT;
3864
3865     /* Should not happen: */
3866     CHECK_MALLOC_TAINT(my_uid && (my_euid != my_uid || my_egid != my_gid));
3867     TAINTING_set( TAINTING_get | (my_uid && (my_euid != my_uid || my_egid != my_gid)) );
3868 #endif
3869     /* BUG */
3870     /* PSz 27 Feb 04
3871      * Should go by suidscript, not uid!=euid: why disallow
3872      * system("ls") in scripts run from setuid things?
3873      * Or, is this run before we check arguments and set suidscript?
3874      * What about SETUID_SCRIPTS_ARE_SECURE_NOW: could we use fdscript then?
3875      * (We never have suidscript, can we be sure to have fdscript?)
3876      * Or must then go by UID checks? See comments in forbid_setid also.
3877      */
3878 }
3879
3880 /* This is used very early in the lifetime of the program,
3881  * before even the options are parsed, so PL_tainting has
3882  * not been initialized properly.  */
3883 bool
3884 Perl_doing_taint(int argc, char *argv[], char *envp[])
3885 {
3886 #ifndef PERL_IMPLICIT_SYS
3887     /* If we have PERL_IMPLICIT_SYS we can't call getuid() et alia
3888      * before we have an interpreter-- and the whole point of this
3889      * function is to be called at such an early stage.  If you are on
3890      * a system with PERL_IMPLICIT_SYS but you do have a concept of
3891      * "tainted because running with altered effective ids', you'll
3892      * have to add your own checks somewhere in here.  The two most
3893      * known samples of 'implicitness' are Win32 and NetWare, neither
3894      * of which has much of concept of 'uids'. */
3895     Uid_t uid  = PerlProc_getuid();
3896     Uid_t euid = PerlProc_geteuid();
3897     Gid_t gid  = PerlProc_getgid();
3898     Gid_t egid = PerlProc_getegid();
3899     (void)envp;
3900
3901 #ifdef VMS
3902     uid  |=  gid << 16;
3903     euid |= egid << 16;
3904 #endif
3905     if (uid && (euid != uid || egid != gid))
3906         return 1;
3907 #endif /* !PERL_IMPLICIT_SYS */
3908     /* This is a really primitive check; environment gets ignored only
3909      * if -T are the first chars together; otherwise one gets
3910      *  "Too late" message. */
3911     if ( argc > 1 && argv[1][0] == '-'
3912          && isALPHA_FOLD_EQ(argv[1][1], 't'))
3913         return 1;
3914     return 0;
3915 }
3916
3917 /* Passing the flag as a single char rather than a string is a slight space
3918    optimisation.  The only message that isn't /^-.$/ is
3919    "program input from stdin", which is substituted in place of '\0', which
3920    could never be a command line flag.  */
3921 STATIC void
3922 S_forbid_setid(pTHX_ const char flag, const bool suidscript) /* g */
3923 {
3924     char string[3] = "-x";
3925     const char *message = "program input from stdin";
3926
3927     PERL_UNUSED_CONTEXT;
3928     if (flag) {
3929         string[1] = flag;
3930         message = string;
3931     }
3932
3933 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
3934     if (PerlProc_getuid() != PerlProc_geteuid())
3935         Perl_croak(aTHX_ "No %s allowed while running setuid", message);
3936     if (PerlProc_getgid() != PerlProc_getegid())
3937         Perl_croak(aTHX_ "No %s allowed while running setgid", message);
3938 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
3939     if (suidscript)
3940         Perl_croak(aTHX_ "No %s allowed with (suid) fdscript", message);
3941 }
3942
3943 void
3944 Perl_init_dbargs(pTHX)
3945 {
3946     AV *const args = PL_dbargs = GvAV(gv_AVadd((gv_fetchpvs("DB::args",
3947                                                             GV_ADDMULTI,
3948                                                             SVt_PVAV))));
3949
3950     if (AvREAL(args)) {
3951         /* Someone has already created it.
3952            It might have entries, and if we just turn off AvREAL(), they will
3953            "leak" until global destruction.  */
3954         av_clear(args);
3955         if (SvTIED_mg((const SV *)args, PERL_MAGIC_tied))
3956             Perl_croak(aTHX_ "Cannot set tied @DB::args");
3957     }
3958     AvREIFY_only(PL_dbargs);
3959 }
3960
3961 void
3962 Perl_init_debugger(pTHX)
3963 {
3964     HV * const ostash = PL_curstash;
3965
3966     PL_curstash = (HV *)SvREFCNT_inc_simple(PL_debstash);
3967
3968     Perl_init_dbargs(aTHX);
3969     PL_DBgv = MUTABLE_GV(
3970         SvREFCNT_inc(gv_fetchpvs("DB::DB", GV_ADDMULTI, SVt_PVGV))
3971     );
3972     PL_DBline = MUTABLE_GV(
3973         SvREFCNT_inc(gv_fetchpvs("DB::dbline", GV_ADDMULTI, SVt_PVAV))
3974     );
3975     PL_DBsub = MUTABLE_GV(SvREFCNT_inc(
3976         gv_HVadd(gv_fetchpvs("DB::sub", GV_ADDMULTI, SVt_PVHV))
3977     ));
3978     PL_DBsingle = GvSV((gv_fetchpvs("DB::single", GV_ADDMULTI, SVt_PV)));
3979     if (!SvIOK(PL_DBsingle))
3980         sv_setiv(PL_DBsingle, 0);
3981     PL_DBtrace = GvSV((gv_fetchpvs("DB::trace", GV_ADDMULTI, SVt_PV)));
3982     if (!SvIOK(PL_DBtrace))
3983         sv_setiv(PL_DBtrace, 0);
3984     PL_DBsignal = GvSV((gv_fetchpvs("DB::signal", GV_ADDMULTI, SVt_PV)));
3985     if (!SvIOK(PL_DBsignal))
3986         sv_setiv(PL_DBsignal, 0);
3987     SvREFCNT_dec(PL_curstash);
3988     PL_curstash = ostash;
3989 }
3990
3991 #ifndef STRESS_REALLOC
3992 #define REASONABLE(size) (size)
3993 #define REASONABLE_but_at_least(size,min) (size)
3994 #else
3995 #define REASONABLE(size) (1) /* unreasonable */
3996 #define REASONABLE_but_at_least(size,min) (min)
3997 #endif
3998
3999 void
4000 Perl_init_stacks(pTHX)
4001 {
4002     /* start with 128-item stack and 8K cxstack */
4003     PL_curstackinfo = new_stackinfo(REASONABLE(128),
4004                                  REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
4005     PL_curstackinfo->si_type = PERLSI_MAIN;
4006     PL_curstack = PL_curstackinfo->si_stack;
4007     PL_mainstack = PL_curstack;         /* remember in case we switch stacks */
4008
4009     PL_stack_base = AvARRAY(PL_curstack);
4010     PL_stack_sp = PL_stack_base;
4011     PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
4012
4013     Newx(PL_tmps_stack,REASONABLE(128),SV*);
4014     PL_tmps_floor = -1;
4015     PL_tmps_ix = -1;
4016     PL_tmps_max = REASONABLE(128);
4017
4018     Newx(PL_markstack,REASONABLE(32),I32);
4019     PL_markstack_ptr = PL_markstack;
4020     PL_markstack_max = PL_markstack + REASONABLE(32);
4021
4022     SET_MARK_OFFSET;
4023
4024     Newx(PL_scopestack,REASONABLE(32),I32);
4025 #ifdef DEBUGGING
4026     Newx(PL_scopestack_name,REASONABLE(32),const char*);
4027 #endif
4028     PL_scopestack_ix = 0;
4029     PL_scopestack_max = REASONABLE(32);
4030
4031     Newx(PL_savestack,REASONABLE_but_at_least(128,SS_MAXPUSH),ANY);
4032     PL_savestack_ix = 0;
4033     PL_savestack_max = REASONABLE_but_at_least(128,SS_MAXPUSH);
4034 }
4035
4036 #undef REASONABLE
4037
4038 STATIC void
4039 S_nuke_stacks(pTHX)
4040 {
4041     while (PL_curstackinfo->si_next)
4042         PL_curstackinfo = PL_curstackinfo->si_next;
4043     while (PL_curstackinfo) {
4044         PERL_SI *p = PL_curstackinfo->si_prev;
4045         /* curstackinfo->si_stack got nuked by sv_free_arenas() */
4046         Safefree(PL_curstackinfo->si_cxstack);
4047         Safefree(PL_curstackinfo);
4048         PL_curstackinfo = p;
4049     }
4050     Safefree(PL_tmps_stack);
4051     Safefree(PL_markstack);
4052     Safefree(PL_scopestack);
4053 #ifdef DEBUGGING
4054     Safefree(PL_scopestack_name);
4055 #endif
4056     Safefree(PL_savestack);
4057 }
4058
4059 void
4060 Perl_populate_isa(pTHX_ const char *name, STRLEN len, ...)
4061 {
4062     GV *const gv = gv_fetchpvn(name, len, GV_ADD | GV_ADDMULTI, SVt_PVAV);
4063     AV *const isa = GvAVn(gv);
4064     va_list args;
4065
4066     PERL_ARGS_ASSERT_POPULATE_ISA;
4067
4068     if(AvFILLp(isa) != -1)
4069         return;
4070
4071     /* NOTE: No support for tied ISA */
4072
4073     va_start(args, len);
4074     do {
4075         const char *const parent = va_arg(args, const char*);
4076         size_t parent_len;
4077
4078         if (!parent)
4079             break;
4080         parent_len = va_arg(args, size_t);
4081
4082         /* Arguments are supplied with a trailing ::  */
4083         assert(parent_len > 2);
4084         assert(parent[parent_len - 1] == ':');
4085         assert(parent[parent_len - 2] == ':');
4086         av_push(isa, newSVpvn(parent, parent_len - 2));
4087         (void) gv_fetchpvn(parent, parent_len, GV_ADD, SVt_PVGV);
4088     } while (1);
4089     va_end(args);
4090 }
4091
4092
4093 STATIC void
4094 S_init_predump_symbols(pTHX)
4095 {
4096     GV *tmpgv;
4097     IO *io;
4098
4099     sv_setpvs(get_sv("\"", GV_ADD), " ");
4100     PL_ofsgv = (GV*)SvREFCNT_inc(gv_fetchpvs(",", GV_ADD|GV_NOTQUAL, SVt_PV));
4101
4102
4103     /* Historically, PVIOs were blessed into IO::Handle, unless
4104        FileHandle was loaded, in which case they were blessed into
4105        that. Action at a distance.
4106        However, if we simply bless into IO::Handle, we break code
4107        that assumes that PVIOs will have (among others) a seek
4108        method. IO::File inherits from IO::Handle and IO::Seekable,
4109        and provides the needed methods. But if we simply bless into
4110        it, then we break code that assumed that by loading
4111        IO::Handle, *it* would work.
4112        So a compromise is to set up the correct @IO::File::ISA,
4113        so that code that does C<use IO::Handle>; will still work.
4114     */
4115
4116     Perl_populate_isa(aTHX_ STR_WITH_LEN("IO::File::ISA"),
4117                       STR_WITH_LEN("IO::Handle::"),
4118                       STR_WITH_LEN("IO::Seekable::"),
4119                       STR_WITH_LEN("Exporter::"),
4120                       NULL);
4121
4122     PL_stdingv = gv_fetchpvs("STDIN", GV_ADD|GV_NOTQUAL, SVt_PVIO);
4123     GvMULTI_on(PL_stdingv);
4124     io = GvIOp(PL_stdingv);
4125     IoTYPE(io) = IoTYPE_RDONLY;
4126     IoIFP(io) = PerlIO_stdin();
4127     tmpgv = gv_fetchpvs("stdin", GV_ADD|GV_NOTQUAL, SVt_PV);
4128     GvMULTI_on(tmpgv);
4129     GvIOp(tmpgv) = MUTABLE_IO(SvREFCNT_inc_simple(io));
4130
4131     tmpgv = gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVIO);
4132     GvMULTI_on(tmpgv);
4133     io = GvIOp(tmpgv);
4134     IoTYPE(io) = IoTYPE_WRONLY;
4135     IoOFP(io) = IoIFP(io) = PerlIO_stdout();
4136     setdefout(tmpgv);
4137     tmpgv = gv_fetchpvs("stdout", GV_ADD|GV_NOTQUAL, SVt_PV);
4138     GvMULTI_on(tmpgv);
4139     GvIOp(tmpgv) = MUTABLE_IO(SvREFCNT_inc_simple(io));
4140
4141     PL_stderrgv = gv_fetchpvs("STDERR", GV_ADD|GV_NOTQUAL, SVt_PVIO);
4142     GvMULTI_on(PL_stderrgv);
4143     io = GvIOp(PL_stderrgv);
4144     IoTYPE(io) = IoTYPE_WRONLY;
4145     IoOFP(io) = IoIFP(io) = PerlIO_stderr();
4146     tmpgv = gv_fetchpvs("stderr", GV_ADD|GV_NOTQUAL, SVt_PV);
4147     GvMULTI_on(tmpgv);
4148     GvIOp(tmpgv) = MUTABLE_IO(SvREFCNT_inc_simple(io));
4149
4150     PL_statname = newSVpvs("");         /* last filename we did stat on */
4151 }
4152
4153 void
4154 Perl_init_argv_symbols(pTHX_ int argc, char **argv)
4155 {
4156     PERL_ARGS_ASSERT_INIT_ARGV_SYMBOLS;
4157
4158     argc--,argv++;      /* skip name of script */
4159     if (PL_doswitches) {
4160         for (; argc > 0 && **argv == '-'; argc--,argv++) {
4161             char *s;
4162             if (!argv[0][1])
4163                 break;
4164             if (argv[0][1] == '-' && !argv[0][2]) {
4165                 argc--,argv++;
4166                 break;
4167             }
4168             if ((s = strchr(argv[0], '='))) {
4169                 const char *const start_name = argv[0] + 1;
4170                 sv_setpv(GvSV(gv_fetchpvn_flags(start_name, s - start_name,
4171                                                 TRUE, SVt_PV)), s + 1);
4172             }
4173             else
4174                 sv_setiv(GvSV(gv_fetchpv(argv[0]+1, GV_ADD, SVt_PV)),1);
4175         }
4176     }
4177     if ((PL_argvgv = gv_fetchpvs("ARGV", GV_ADD|GV_NOTQUAL, SVt_PVAV))) {
4178         SvREFCNT_inc_simple_void_NN(PL_argvgv);
4179         GvMULTI_on(PL_argvgv);
4180         av_clear(GvAVn(PL_argvgv));
4181         for (; argc > 0; argc--,argv++) {
4182             SV * const sv = newSVpv(argv[0],0);
4183             av_push(GvAV(PL_argvgv),sv);
4184             if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) {
4185                  if (PL_unicode & PERL_UNICODE_ARGV_FLAG)
4186                       SvUTF8_on(sv);
4187             }
4188             if (PL_unicode & PERL_UNICODE_WIDESYSCALLS_FLAG) /* Sarathy? */
4189                  (void)sv_utf8_decode(sv);
4190         }
4191     }
4192
4193     if (PL_inplace && (!PL_argvgv || AvFILL(GvAV(PL_argvgv)) == -1))
4194         Perl_ck_warner_d(aTHX_ packWARN(WARN_INPLACE),
4195                          "-i used with no filenames on the command line, "
4196                          "reading from STDIN");
4197 }
4198
4199 STATIC void
4200 S_init_postdump_symbols(pTHX_ int argc, char **argv, char **env)
4201 {
4202 #ifdef USE_ITHREADS
4203     dVAR;
4204 #endif
4205     GV* tmpgv;
4206
4207     PERL_ARGS_ASSERT_INIT_POSTDUMP_SYMBOLS;
4208
4209     PL_toptarget = newSV_type(SVt_PVIV);
4210     sv_setpvs(PL_toptarget, "");
4211     PL_bodytarget = newSV_type(SVt_PVIV);
4212     sv_setpvs(PL_bodytarget, "");
4213     PL_formtarget = PL_bodytarget;
4214
4215     TAINT;
4216
4217     init_argv_symbols(argc,argv);
4218
4219     if ((tmpgv = gv_fetchpvs("0", GV_ADD|GV_NOTQUAL, SVt_PV))) {
4220         sv_setpv(GvSV(tmpgv),PL_origfilename);
4221     }
4222     if ((PL_envgv = gv_fetchpvs("ENV", GV_ADD|GV_NOTQUAL, SVt_PVHV))) {
4223         HV *hv;
4224         bool env_is_not_environ;
4225         SvREFCNT_inc_simple_void_NN(PL_envgv);
4226         GvMULTI_on(PL_envgv);
4227         hv = GvHVn(PL_envgv);
4228         hv_magic(hv, NULL, PERL_MAGIC_env);
4229 #ifndef PERL_MICRO
4230 #ifdef USE_ENVIRON_ARRAY
4231         /* Note that if the supplied env parameter is actually a copy
4232            of the global environ then it may now point to free'd memory
4233            if the environment has been modified since. To avoid this
4234            problem we treat env==NULL as meaning 'use the default'
4235         */
4236         if (!env)
4237             env = environ;
4238         env_is_not_environ = env != environ;
4239         if (env_is_not_environ
4240 #  ifdef USE_ITHREADS
4241             && PL_curinterp == aTHX
4242 #  endif
4243            )
4244         {
4245             environ[0] = NULL;
4246         }
4247         if (env) {
4248           char *s, *old_var;
4249           SV *sv;
4250           for (; *env; env++) {
4251             old_var = *env;
4252
4253             if (!(s = strchr(old_var,'=')) || s == old_var)
4254                 continue;
4255
4256 #if defined(MSDOS) && !defined(DJGPP)
4257             *s = '\0';
4258             (void)strupr(old_var);
4259             *s = '=';
4260 #endif
4261             sv = newSVpv(s+1, 0);
4262             (void)hv_store(hv, old_var, s - old_var, sv, 0);
4263             if (env_is_not_environ)
4264                 mg_set(sv);
4265           }
4266       }
4267 #endif /* USE_ENVIRON_ARRAY */
4268 #endif /* !PERL_MICRO */
4269     }
4270     TAINT_NOT;
4271
4272     /* touch @F array to prevent spurious warnings 20020415 MJD */
4273     if (PL_minus_a) {
4274       (void) get_av("main::F", GV_ADD | GV_ADDMULTI);
4275     }
4276 }
4277
4278 STATIC void
4279 S_init_perllib(pTHX)
4280 {
4281 #ifndef VMS
4282     const char *perl5lib = NULL;
4283 #endif
4284     const char *s;
4285 #if defined(WIN32) && !defined(PERL_IS_MINIPERL)
4286     STRLEN len;
4287 #endif
4288
4289     if (!TAINTING_get) {
4290 #ifndef VMS
4291         perl5lib = PerlEnv_getenv("PERL5LIB");
4292 /*
4293  * It isn't possible to delete an environment variable with
4294  * PERL_USE_SAFE_PUTENV set unless unsetenv() is also available, so in that
4295  * case we treat PERL5LIB as undefined if it has a zero-length value.
4296  */
4297 #if defined(PERL_USE_SAFE_PUTENV) && ! defined(HAS_UNSETENV)
4298         if (perl5lib && *perl5lib != '\0')
4299 #else
4300         if (perl5lib)
4301 #endif
4302             incpush_use_sep(perl5lib, 0, INCPUSH_ADD_SUB_DIRS);
4303         else {
4304             s = PerlEnv_getenv("PERLLIB");
4305             if (s)
4306                 incpush_use_sep(s, 0, 0);
4307         }
4308 #else /* VMS */
4309         /* Treat PERL5?LIB as a possible search list logical name -- the
4310          * "natural" VMS idiom for a Unix path string.  We allow each
4311          * element to be a set of |-separated directories for compatibility.
4312          */
4313         char buf[256];
4314         int idx = 0;
4315         if (my_trnlnm("PERL5LIB",buf,0))
4316             do {
4317                 incpush_use_sep(buf, 0, INCPUSH_ADD_SUB_DIRS);
4318             } while (my_trnlnm("PERL5LIB",buf,++idx));
4319         else {
4320             while (my_trnlnm("PERLLIB",buf,idx++))
4321                 incpush_use_sep(buf, 0, 0);
4322         }
4323 #endif /* VMS */
4324     }
4325
4326 #ifndef PERL_IS_MINIPERL
4327     /* miniperl gets just -I..., the split of $ENV{PERL5LIB}, and "." in @INC
4328        (and not the architecture specific directories from $ENV{PERL5LIB}) */
4329
4330 /* Use the ~-expanded versions of APPLLIB (undocumented),
4331     SITEARCH, SITELIB, VENDORARCH, VENDORLIB, ARCHLIB and PRIVLIB
4332 */
4333 #ifdef APPLLIB_EXP
4334     S_incpush_use_sep(aTHX_ STR_WITH_LEN(APPLLIB_EXP),
4335                       INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE);
4336 #endif
4337
4338 #ifdef SITEARCH_EXP
4339     /* sitearch is always relative to sitelib on Windows for
4340      * DLL-based path intuition to work correctly */
4341 #  if !defined(WIN32)
4342         S_incpush_use_sep(aTHX_ STR_WITH_LEN(SITEARCH_EXP),
4343                           INCPUSH_CAN_RELOCATE);
4344 #  endif
4345 #endif
4346
4347 #ifdef SITELIB_EXP
4348 #  if defined(WIN32)
4349     /* this picks up sitearch as well */
4350         s = win32_get_sitelib(PERL_FS_VERSION, &len);
4351         if (s)
4352             incpush_use_sep(s, len, INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE);
4353 #  else
4354         S_incpush_use_sep(aTHX_ STR_WITH_LEN(SITELIB_EXP), INCPUSH_CAN_RELOCATE);
4355 #  endif
4356 #endif
4357
4358 #ifdef PERL_VENDORARCH_EXP
4359     /* vendorarch is always relative to vendorlib on Windows for
4360      * DLL-based path intuition to work correctly */
4361 #  if !defined(WIN32)
4362     S_incpush_use_sep(aTHX_ STR_WITH_LEN(PERL_VENDORARCH_EXP),
4363                       INCPUSH_CAN_RELOCATE);
4364 #  endif
4365 #endif
4366
4367 #ifdef PERL_VENDORLIB_EXP
4368 #  if defined(WIN32)
4369     /* this picks up vendorarch as well */
4370         s = win32_get_vendorlib(PERL_FS_VERSION, &len);
4371         if (s)
4372             incpush_use_sep(s, len, INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE);
4373 #  else
4374         S_incpush_use_sep(aTHX_ STR_WITH_LEN(PERL_VENDORLIB_EXP),
4375                           INCPUSH_CAN_RELOCATE);
4376 #  endif
4377 #endif
4378
4379 #ifdef ARCHLIB_EXP
4380     S_incpush_use_sep(aTHX_ STR_WITH_LEN(ARCHLIB_EXP), INCPUSH_CAN_RELOCATE);
4381 #endif
4382
4383 #ifndef PRIVLIB_EXP
4384 #  define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
4385 #endif
4386
4387 #if defined(WIN32)
4388     s = win32_get_privlib(PERL_FS_VERSION, &len);
4389     if (s)
4390         incpush_use_sep(s, len, INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE);
4391 #else
4392 #  ifdef NETWARE
4393     S_incpush_use_sep(aTHX_ PRIVLIB_EXP, 0, INCPUSH_CAN_RELOCATE);
4394 #  else
4395     S_incpush_use_sep(aTHX_ STR_WITH_LEN(PRIVLIB_EXP), INCPUSH_CAN_RELOCATE);
4396 #  endif
4397 #endif
4398
4399 #ifdef PERL_OTHERLIBDIRS
4400     S_incpush_use_sep(aTHX_ STR_WITH_LEN(PERL_OTHERLIBDIRS),
4401                       INCPUSH_ADD_VERSIONED_SUB_DIRS|INCPUSH_NOT_BASEDIR
4402                       |INCPUSH_CAN_RELOCATE);
4403 #endif
4404
4405     if (!TAINTING_get) {
4406 #ifndef VMS
4407 /*
4408  * It isn't possible to delete an environment variable with
4409  * PERL_USE_SAFE_PUTENV set unless unsetenv() is also available, so in that
4410  * case we treat PERL5LIB as undefined if it has a zero-length value.
4411  */
4412 #if defined(PERL_USE_SAFE_PUTENV) && ! defined(HAS_UNSETENV)
4413         if (perl5lib && *perl5lib != '\0')
4414 #else
4415         if (perl5lib)
4416 #endif
4417             incpush_use_sep(perl5lib, 0,
4418                             INCPUSH_ADD_OLD_VERS|INCPUSH_NOT_BASEDIR);
4419 #else /* VMS */
4420         /* Treat PERL5?LIB as a possible search list logical name -- the
4421          * "natural" VMS idiom for a Unix path string.  We allow each
4422          * element to be a set of |-separated directories for compatibility.
4423          */
4424         char buf[256];
4425         int idx = 0;
4426         if (my_trnlnm("PERL5LIB",buf,0))
4427             do {
4428                 incpush_use_sep(buf, 0,
4429                                 INCPUSH_ADD_OLD_VERS|INCPUSH_NOT_BASEDIR);
4430             } while (my_trnlnm("PERL5LIB",buf,++idx));
4431 #endif /* VMS */
4432     }
4433
4434 /* Use the ~-expanded versions of APPLLIB (undocumented),
4435     SITELIB and VENDORLIB for older versions
4436 */
4437 #ifdef APPLLIB_EXP
4438     S_incpush_use_sep(aTHX_ STR_WITH_LEN(APPLLIB_EXP), INCPUSH_ADD_OLD_VERS
4439                       |INCPUSH_NOT_BASEDIR|INCPUSH_CAN_RELOCATE);
4440 #endif
4441
4442 #if defined(SITELIB_STEM) && defined(PERL_INC_VERSION_LIST)
4443     /* Search for version-specific dirs below here */
4444     S_incpush_use_sep(aTHX_ STR_WITH_LEN(SITELIB_STEM),
4445                       INCPUSH_ADD_OLD_VERS|INCPUSH_CAN_RELOCATE);
4446 #endif
4447
4448
4449 #if defined(PERL_VENDORLIB_STEM) && defined(PERL_INC_VERSION_LIST)
4450     /* Search for version-specific dirs below here */
4451     S_incpush_use_sep(aTHX_ STR_WITH_LEN(PERL_VENDORLIB_STEM),
4452                       INCPUSH_ADD_OLD_VERS|INCPUSH_CAN_RELOCATE);
4453 #endif
4454
4455 #ifdef PERL_OTHERLIBDIRS
4456     S_incpush_use_sep(aTHX_ STR_WITH_LEN(PERL_OTHERLIBDIRS),
4457                       INCPUSH_ADD_OLD_VERS|INCPUSH_ADD_ARCHONLY_SUB_DIRS
4458                       |INCPUSH_CAN_RELOCATE);
4459 #endif
4460 #endif /* !PERL_IS_MINIPERL */
4461
4462     if (!TAINTING_get)
4463         S_incpush(aTHX_ STR_WITH_LEN("."), 0);
4464 }
4465
4466 #if defined(DOSISH) || defined(__SYMBIAN32__)
4467 #    define PERLLIB_SEP ';'
4468 #else
4469 #  if defined(VMS)
4470 #    define PERLLIB_SEP '|'
4471 #  else
4472 #    define PERLLIB_SEP ':'
4473 #  endif
4474 #endif
4475 #ifndef PERLLIB_MANGLE
4476 #  define PERLLIB_MANGLE(s,n) (s)
4477 #endif
4478
4479 #ifndef PERL_IS_MINIPERL
4480 /* Push a directory onto @INC if it exists.
4481    Generate a new SV if we do this, to save needing to copy the SV we push
4482    onto @INC  */
4483 STATIC SV *
4484 S_incpush_if_exists(pTHX_ AV *const av, SV *dir, SV *const stem)
4485 {
4486     Stat_t tmpstatbuf;
4487
4488     PERL_ARGS_ASSERT_INCPUSH_IF_EXISTS;
4489
4490     if (PerlLIO_stat(SvPVX_const(dir), &tmpstatbuf) >= 0 &&
4491         S_ISDIR(tmpstatbuf.st_mode)) {
4492         av_push(av, dir);
4493         dir = newSVsv(stem);
4494     } else {
4495         /* Truncate dir back to stem.  */
4496         SvCUR_set(dir, SvCUR(stem));
4497     }
4498     return dir;
4499 }
4500 #endif
4501
4502 STATIC SV *
4503 S_mayberelocate(pTHX_ const char *const dir, STRLEN len, U32 flags)
4504 {
4505     const U8 canrelocate = (U8)flags & INCPUSH_CAN_RELOCATE;
4506     SV *libdir;
4507
4508     PERL_ARGS_ASSERT_MAYBERELOCATE;
4509     assert(len > 0);
4510
4511     /* I am not convinced that this is valid when PERLLIB_MANGLE is
4512        defined to so something (in os2/os2.c), but the code has been
4513        this way, ignoring any possible changed of length, since
4514        760ac839baf413929cd31cc32ffd6dba6b781a81 (5.003_02) so I'll leave
4515        it be.  */
4516     libdir = newSVpvn(PERLLIB_MANGLE(dir, len), len);
4517
4518 #ifdef VMS
4519     {
4520         char *unix;
4521
4522         if ((unix = tounixspec_ts(SvPV(libdir,len),NULL)) != NULL) {
4523             len = strlen(unix);
4524             while (len > 1 && unix[len-1] == '/') len--;  /* Cosmetic */
4525             sv_usepvn(libdir,unix,len);
4526         }
4527         else
4528             PerlIO_printf(Perl_error_log,
4529                           "Failed to unixify @INC element \"%s\"\n",
4530                           SvPV_nolen_const(libdir));
4531     }
4532 #endif
4533
4534         /* Do the if() outside the #ifdef to avoid warnings about an unused
4535            parameter.  */
4536         if (canrelocate) {
4537 #ifdef PERL_RELOCATABLE_INC
4538         /*
4539          * Relocatable include entries are marked with a leading .../
4540          *
4541          * The algorithm is
4542          * 0: Remove that leading ".../"
4543          * 1: Remove trailing executable name (anything after the last '/')
4544          *    from the perl path to give a perl prefix
4545          * Then
4546          * While the @INC element starts "../" and the prefix ends with a real
4547          * directory (ie not . or ..) chop that real directory off the prefix
4548          * and the leading "../" from the @INC element. ie a logical "../"
4549          * cleanup
4550          * Finally concatenate the prefix and the remainder of the @INC element
4551          * The intent is that /usr/local/bin/perl and .../../lib/perl5
4552          * generates /usr/local/lib/perl5
4553          */
4554             const char *libpath = SvPVX(libdir);
4555             STRLEN libpath_len = SvCUR(libdir);
4556             if (libpath_len >= 4 && memEQ (libpath, ".../", 4)) {
4557                 /* Game on!  */
4558                 SV * const caret_X = get_sv("\030", 0);
4559                 /* Going to use the SV just as a scratch buffer holding a C
4560                    string:  */
4561                 SV *prefix_sv;
4562                 char *prefix;
4563                 char *lastslash;
4564
4565                 /* $^X is *the* source of taint if tainting is on, hence
4566                    SvPOK() won't be true.  */
4567                 assert(caret_X);
4568                 assert(SvPOKp(caret_X));
4569                 prefix_sv = newSVpvn_flags(SvPVX(caret_X), SvCUR(caret_X),
4570                                            SvUTF8(caret_X));
4571                 /* Firstly take off the leading .../
4572                    If all else fail we'll do the paths relative to the current
4573                    directory.  */
4574                 sv_chop(libdir, libpath + 4);
4575                 /* Don't use SvPV as we're intentionally bypassing taining,
4576                    mortal copies that the mg_get of tainting creates, and
4577                    corruption that seems to come via the save stack.
4578                    I guess that the save stack isn't correctly set up yet.  */
4579                 libpath = SvPVX(libdir);
4580                 libpath_len = SvCUR(libdir);
4581
4582                 /* This would work more efficiently with memrchr, but as it's
4583                    only a GNU extension we'd need to probe for it and
4584                    implement our own. Not hard, but maybe not worth it?  */
4585
4586                 prefix = SvPVX(prefix_sv);
4587                 lastslash = strrchr(prefix, '/');
4588
4589                 /* First time in with the *lastslash = '\0' we just wipe off
4590                    the trailing /perl from (say) /usr/foo/bin/perl
4591                 */
4592                 if (lastslash) {
4593                     SV *tempsv;
4594                     while ((*lastslash = '\0'), /* Do that, come what may.  */
4595                            (libpath_len >= 3 && memEQ(libpath, "../", 3)
4596                             && (lastslash = strrchr(prefix, '/')))) {
4597                         if (lastslash[1] == '\0'
4598                             || (lastslash[1] == '.'
4599                                 && (lastslash[2] == '/' /* ends "/."  */
4600                                     || (lastslash[2] == '/'
4601                                         && lastslash[3] == '/' /* or "/.."  */
4602                                         )))) {
4603                             /* Prefix ends "/" or "/." or "/..", any of which
4604                                are fishy, so don't do any more logical cleanup.
4605                             */
4606                             break;
4607                         }
4608                         /* Remove leading "../" from path  */
4609                         libpath += 3;
4610                         libpath_len -= 3;
4611                         /* Next iteration round the loop removes the last
4612                            directory name from prefix by writing a '\0' in
4613                            the while clause.  */
4614                     }
4615                     /* prefix has been terminated with a '\0' to the correct
4616                        length. libpath points somewhere into the libdir SV.
4617                        We need to join the 2 with '/' and drop the result into
4618                        libdir.  */
4619                     tempsv = Perl_newSVpvf(aTHX_ "%s/%s", prefix, libpath);
4620                     SvREFCNT_dec(libdir);
4621                     /* And this is the new libdir.  */
4622                     libdir = tempsv;
4623                     if (TAINTING_get &&
4624                         (PerlProc_getuid() != PerlProc_geteuid() ||
4625                          PerlProc_getgid() != PerlProc_getegid())) {
4626                         /* Need to taint relocated paths if running set ID  */
4627                         SvTAINTED_on(libdir);
4628                     }
4629                 }
4630                 SvREFCNT_dec(prefix_sv);
4631             }
4632 #endif
4633         }
4634     return libdir;
4635 }
4636
4637 STATIC void
4638 S_incpush(pTHX_ const char *const dir, STRLEN len, U32 flags)
4639 {
4640 #ifndef PERL_IS_MINIPERL
4641     const U8 using_sub_dirs
4642         = (U8)flags & (INCPUSH_ADD_VERSIONED_SUB_DIRS
4643                        |INCPUSH_ADD_ARCHONLY_SUB_DIRS|INCPUSH_ADD_OLD_VERS);
4644     const U8 add_versioned_sub_dirs
4645         = (U8)flags & INCPUSH_ADD_VERSIONED_SUB_DIRS;
4646     const U8 add_archonly_sub_dirs
4647         = (U8)flags & INCPUSH_ADD_ARCHONLY_SUB_DIRS;
4648 #ifdef PERL_INC_VERSION_LIST
4649     const U8 addoldvers  = (U8)flags & INCPUSH_ADD_OLD_VERS;
4650 #endif
4651 #endif
4652     const U8 unshift     = (U8)flags & INCPUSH_UNSHIFT;
4653     const U8 push_basedir = (flags & INCPUSH_NOT_BASEDIR) ? 0 : 1;
4654     AV *const inc = GvAVn(PL_incgv);
4655
4656     PERL_ARGS_ASSERT_INCPUSH;
4657     assert(len > 0);
4658
4659     /* Could remove this vestigial extra block, if we don't mind a lot of
4660        re-indenting diff noise.  */
4661     {
4662         SV *const libdir = mayberelocate(dir, len, flags);
4663         /* Change 20189146be79a0596543441fa369c6bf7f85103f, to fix RT#6665,
4664            arranged to unshift #! line -I onto the front of @INC. However,
4665            -I can add version and architecture specific libraries, and they
4666            need to go first. The old code assumed that it was always
4667            pushing. Hence to make it work, need to push the architecture
4668            (etc) libraries onto a temporary array, then "unshift" that onto
4669            the front of @INC.  */
4670 #ifndef PERL_IS_MINIPERL
4671         AV *const av = (using_sub_dirs) ? (unshift ? newAV() : inc) : NULL;
4672
4673         /*
4674          * BEFORE pushing libdir onto @INC we may first push version- and
4675          * archname-specific sub-directories.
4676          */
4677         if (using_sub_dirs) {
4678             SV *subdir = newSVsv(libdir);
4679 #ifdef PERL_INC_VERSION_LIST
4680             /* Configure terminates PERL_INC_VERSION_LIST with a NULL */
4681             const char * const incverlist[] = { PERL_INC_VERSION_LIST };
4682             const char * const *incver;
4683 #endif
4684
4685             if (add_versioned_sub_dirs) {
4686                 /* .../version/archname if -d .../version/archname */
4687                 sv_catpvs(subdir, "/" PERL_FS_VERSION "/" ARCHNAME);
4688                 subdir = S_incpush_if_exists(aTHX_ av, subdir, libdir);
4689
4690                 /* .../version if -d .../version */
4691                 sv_catpvs(subdir, "/" PERL_FS_VERSION);
4692                 subdir = S_incpush_if_exists(aTHX_ av, subdir, libdir);
4693             }
4694
4695 #ifdef PERL_INC_VERSION_LIST
4696             if (addoldvers) {
4697                 for (incver = incverlist; *incver; incver++) {
4698                     /* .../xxx if -d .../xxx */
4699                     Perl_sv_catpvf(aTHX_ subdir, "/%s", *incver);
4700                     subdir = S_incpush_if_exists(aTHX_ av, subdir, libdir);
4701                 }
4702             }
4703 #endif
4704
4705             if (add_archonly_sub_dirs) {
4706                 /* .../archname if -d .../archname */
4707                 sv_catpvs(subdir, "/" ARCHNAME);
4708                 subdir = S_incpush_if_exists(aTHX_ av, subdir, libdir);
4709
4710             }
4711
4712             assert (SvREFCNT(subdir) == 1);
4713             SvREFCNT_dec(subdir);
4714         }
4715 #endif /* !PERL_IS_MINIPERL */
4716         /* finally add this lib directory at the end of @INC */
4717         if (unshift) {
4718 #ifdef PERL_IS_MINIPERL
4719             const Size_t extra = 0;
4720 #else
4721             Size_t extra = av_tindex(av) + 1;
4722 #endif
4723             av_unshift(inc, extra + push_basedir);
4724             if (push_basedir)
4725                 av_store(inc, extra, libdir);
4726 #ifndef PERL_IS_MINIPERL
4727             while (extra--) {
4728                 /* av owns a reference, av_store() expects to be donated a
4729                    reference, and av expects to be sane when it's cleared.
4730                    If I wanted to be naughty and wrong, I could peek inside the
4731                    implementation of av_clear(), realise that it uses
4732                    SvREFCNT_dec() too, so av's array could be a run of NULLs,
4733                    and so directly steal from it (with a memcpy() to inc, and
4734                    then memset() to NULL them out. But people copy code from the
4735                    core expecting it to be best practise, so let's use the API.
4736                    Although studious readers will note that I'm not checking any
4737                    return codes.  */
4738                 av_store(inc, extra, SvREFCNT_inc(*av_fetch(av, extra, FALSE)));
4739             }
4740             SvREFCNT_dec(av);
4741 #endif
4742         }
4743         else if (push_basedir) {
4744             av_push(inc, libdir);
4745         }
4746
4747         if (!push_basedir) {
4748             assert (SvREFCNT(libdir) == 1);
4749             SvREFCNT_dec(libdir);
4750         }
4751     }
4752 }
4753
4754 STATIC void
4755 S_incpush_use_sep(pTHX_ const char *p, STRLEN len, U32 flags)
4756 {
4757     const char *s;
4758     const char *end;
4759     /* This logic has been broken out from S_incpush(). It may be possible to
4760        simplify it.  */
4761
4762     PERL_ARGS_ASSERT_INCPUSH_USE_SEP;
4763
4764     /* perl compiled with -DPERL_RELOCATABLE_INCPUSH will ignore the len
4765      * argument to incpush_use_sep.  This allows creation of relocatable
4766      * Perl distributions that patch the binary at install time.  Those
4767      * distributions will have to provide their own relocation tools; this
4768      * is not a feature otherwise supported by core Perl.
4769      */
4770 #ifndef PERL_RELOCATABLE_INCPUSH
4771     if (!len)
4772 #endif
4773         len = strlen(p);
4774
4775     end = p + len;
4776
4777     /* Break at all separators */
4778     while ((s = (const char*)memchr(p, PERLLIB_SEP, end - p))) {
4779         if (s == p) {
4780             /* skip any consecutive separators */
4781
4782             /* Uncomment the next line for PATH semantics */
4783             /* But you'll need to write tests */
4784             /* av_push(GvAVn(PL_incgv), newSVpvs(".")); */
4785         } else {
4786             incpush(p, (STRLEN)(s - p), flags);
4787         }
4788         p = s + 1;
4789     }
4790     if (p != end)
4791         incpush(p, (STRLEN)(end - p), flags);
4792
4793 }
4794
4795 void
4796 Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
4797 {
4798     SV *atsv;
4799     volatile const line_t oldline = PL_curcop ? CopLINE(PL_curcop) : 0;
4800     CV *cv;
4801     STRLEN len;
4802     int ret;
4803     dJMPENV;
4804
4805     PERL_ARGS_ASSERT_CALL_LIST;
4806
4807     while (av_tindex(paramList) >= 0) {
4808         cv = MUTABLE_CV(av_shift(paramList));
4809         if (PL_savebegin) {
4810             if (paramList == PL_beginav) {
4811                 /* save PL_beginav for compiler */
4812                 Perl_av_create_and_push(aTHX_ &PL_beginav_save, MUTABLE_SV(cv));
4813             }
4814             else if (paramList == PL_checkav) {
4815                 /* save PL_checkav for compiler */
4816                 Perl_av_create_and_push(aTHX_ &PL_checkav_save, MUTABLE_SV(cv));
4817             }
4818             else if (paramList == PL_unitcheckav) {
4819                 /* save PL_unitcheckav for compiler */
4820                 Perl_av_create_and_push(aTHX_ &PL_unitcheckav_save, MUTABLE_SV(cv));
4821             }
4822         } else {
4823             SAVEFREESV(cv);
4824         }
4825         JMPENV_PUSH(ret);
4826         switch (ret) {
4827         case 0:
4828             CALL_LIST_BODY(cv);
4829             atsv = ERRSV;
4830             (void)SvPV_const(atsv, len);
4831             if (len) {
4832                 PL_curcop = &PL_compiling;
4833                 CopLINE_set(PL_curcop, oldline);
4834                 if (paramList == PL_beginav)
4835                     sv_catpvs(atsv, "BEGIN failed--compilation aborted");
4836                 else
4837                     Perl_sv_catpvf(aTHX_ atsv,
4838                                    "%s failed--call queue aborted",
4839                                    paramList == PL_checkav ? "CHECK"
4840                                    : paramList == PL_initav ? "INIT"
4841                                    : paramList == PL_unitcheckav ? "UNITCHECK"
4842                                    : "END");
4843                 while (PL_scopestack_ix > oldscope)
4844                     LEAVE;
4845                 JMPENV_POP;
4846                 Perl_croak(aTHX_ "%"SVf"", SVfARG(atsv));
4847             }
4848             break;
4849         case 1:
4850             STATUS_ALL_FAILURE;
4851             /* FALLTHROUGH */
4852         case 2:
4853             /* my_exit() was called */
4854             while (PL_scopestack_ix > oldscope)
4855                 LEAVE;
4856             FREETMPS;
4857             SET_CURSTASH(PL_defstash);
4858             PL_curcop = &PL_compiling;
4859             CopLINE_set(PL_curcop, oldline);
4860             JMPENV_POP;
4861             my_exit_jump();
4862             assert(0); /* NOTREACHED */
4863         case 3:
4864             if (PL_restartop) {
4865                 PL_curcop = &PL_compiling;
4866                 CopLINE_set(PL_curcop, oldline);
4867                 JMPENV_JUMP(3);
4868             }
4869             PerlIO_printf(Perl_error_log, "panic: restartop in call_list\n");
4870             FREETMPS;
4871             break;
4872         }
4873         JMPENV_POP;
4874     }
4875 }
4876
4877 void
4878 Perl_my_exit(pTHX_ U32 status)
4879 {
4880     if (PL_exit_flags & PERL_EXIT_ABORT) {
4881         abort();
4882     }
4883     if (PL_exit_flags & PERL_EXIT_WARN) {
4884         PL_exit_flags |= PERL_EXIT_ABORT; /* Protect against reentrant calls */
4885         Perl_warn(aTHX_ "Unexpected exit %lu", (unsigned long)status);
4886         PL_exit_flags &= ~PERL_EXIT_ABORT;
4887     }
4888     switch (status) {
4889     case 0:
4890         STATUS_ALL_SUCCESS;
4891         break;
4892     case 1:
4893         STATUS_ALL_FAILURE;
4894         break;
4895     default:
4896         STATUS_EXIT_SET(status);
4897         break;
4898     }
4899     my_exit_jump();
4900 }
4901
4902 void
4903 Perl_my_failure_exit(pTHX)
4904 {
4905 #ifdef VMS
4906      /* We have been called to fall on our sword.  The desired exit code
4907       * should be already set in STATUS_UNIX, but could be shifted over
4908       * by 8 bits.  STATUS_UNIX_EXIT_SET will handle the cases where a
4909       * that code is set.
4910       *
4911       * If an error code has not been set, then force the issue.
4912       */
4913     if (MY_POSIX_EXIT) {
4914
4915         /* According to the die_exit.t tests, if errno is non-zero */
4916         /* It should be used for the error status. */
4917
4918         if (errno == EVMSERR) {
4919             STATUS_NATIVE = vaxc$errno;
4920         } else {
4921
4922             /* According to die_exit.t tests, if the child_exit code is */
4923             /* also zero, then we need to exit with a code of 255 */
4924             if ((errno != 0) && (errno < 256))
4925                 STATUS_UNIX_EXIT_SET(errno);
4926             else if (STATUS_UNIX < 255) {
4927                 STATUS_UNIX_EXIT_SET(255);
4928             }
4929
4930         }
4931
4932         /* The exit code could have been set by $? or vmsish which
4933          * means that it may not have fatal set.  So convert
4934          * success/warning codes to fatal with out changing
4935          * the POSIX status code.  The severity makes VMS native
4936          * status handling work, while UNIX mode programs use the
4937          * the POSIX exit codes.
4938          */
4939          if ((STATUS_NATIVE & (STS$K_SEVERE|STS$K_ERROR)) == 0) {
4940             STATUS_NATIVE &= STS$M_COND_ID;
4941             STATUS_NATIVE |= STS$K_ERROR | STS$M_INHIB_MSG;
4942          }
4943     }
4944     else {
4945         /* Traditionally Perl on VMS always expects a Fatal Error. */
4946         if (vaxc$errno & 1) {
4947
4948             /* So force success status to failure */
4949             if (STATUS_NATIVE & 1)
4950                 STATUS_ALL_FAILURE;
4951         }
4952         else {
4953             if (!vaxc$errno) {
4954                 STATUS_UNIX = EINTR; /* In case something cares */
4955                 STATUS_ALL_FAILURE;
4956             }
4957             else {
4958                 int severity;
4959                 STATUS_NATIVE = vaxc$errno; /* Should already be this */
4960
4961                 /* Encode the severity code */
4962                 severity = STATUS_NATIVE & STS$M_SEVERITY;
4963                 STATUS_UNIX = (severity ? severity : 1) << 8;
4964
4965                 /* Perl expects this to be a fatal error */
4966                 if (severity != STS$K_SEVERE)
4967                     STATUS_ALL_FAILURE;
4968             }
4969         }
4970     }
4971
4972 #else
4973     int exitstatus;
4974     if (errno & 255)
4975         STATUS_UNIX_SET(errno);
4976     else {
4977         exitstatus = STATUS_UNIX >> 8;
4978         if (exitstatus & 255)
4979             STATUS_UNIX_SET(exitstatus);
4980         else
4981             STATUS_UNIX_SET(255);
4982     }
4983 #endif
4984     if (PL_exit_flags & PERL_EXIT_ABORT) {
4985         abort();
4986     }
4987     if (PL_exit_flags & PERL_EXIT_WARN) {
4988         PL_exit_flags |= PERL_EXIT_ABORT; /* Protect against reentrant calls */
4989         Perl_warn(aTHX_ "Unexpected exit failure %ld", (long)PL_statusvalue);
4990         PL_exit_flags &= ~PERL_EXIT_ABORT;
4991     }
4992     my_exit_jump();
4993 }
4994
4995 STATIC void
4996 S_my_exit_jump(pTHX)
4997 {
4998     if (PL_e_script) {
4999         SvREFCNT_dec(PL_e_script);
5000         PL_e_script = NULL;
5001     }
5002
5003     POPSTACK_TO(PL_mainstack);
5004     dounwind(-1);
5005     LEAVE_SCOPE(0);
5006
5007     JMPENV_JUMP(2);
5008 }
5009
5010 static I32
5011 read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen)
5012 {
5013     const char * const p  = SvPVX_const(PL_e_script);
5014     const char *nl = strchr(p, '\n');
5015
5016     PERL_UNUSED_ARG(idx);
5017     PERL_UNUSED_ARG(maxlen);
5018
5019     nl = (nl) ? nl+1 : SvEND(PL_e_script);
5020     if (nl-p == 0) {
5021         filter_del(read_e_script);
5022         return 0;
5023     }
5024     sv_catpvn(buf_sv, p, nl-p);
5025     sv_chop(PL_e_script, nl);
5026     return 1;
5027 }
5028
5029 /*
5030  * Local variables:
5031  * c-indentation-style: bsd
5032  * c-basic-offset: 4
5033  * indent-tabs-mode: nil
5034  * End:
5035  *
5036  * ex: set ts=8 sts=4 sw=4 et:
5037  */