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