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