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