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