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-2012, 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
3653     PERL_ARGS_ASSERT_OPEN_SCRIPT;
3654
3655     if (PL_e_script) {
3656         PL_origfilename = savepvs("-e");
3657     }
3658     else {
3659         /* if find_script() returns, it returns a malloc()-ed value */
3660         scriptname = PL_origfilename = find_script(scriptname, dosearch, NULL, 1);
3661
3662         if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
3663             const char *s = scriptname + 8;
3664             fdscript = atoi(s);
3665             while (isDIGIT(*s))
3666                 s++;
3667             if (*s) {
3668                 /* PSz 18 Feb 04
3669                  * Tell apart "normal" usage of fdscript, e.g.
3670                  * with bash on FreeBSD:
3671                  *   perl <( echo '#!perl -DA'; echo 'print "$0\n"')
3672                  * from usage in suidperl.
3673                  * Does any "normal" usage leave garbage after the number???
3674                  * Is it a mistake to use a similar /dev/fd/ construct for
3675                  * suidperl?
3676                  */
3677                 *suidscript = TRUE;
3678                 /* PSz 20 Feb 04
3679                  * Be supersafe and do some sanity-checks.
3680                  * Still, can we be sure we got the right thing?
3681                  */
3682                 if (*s != '/') {
3683                     Perl_croak(aTHX_ "Wrong syntax (suid) fd script name \"%s\"\n", s);
3684                 }
3685                 if (! *(s+1)) {
3686                     Perl_croak(aTHX_ "Missing (suid) fd script name\n");
3687                 }
3688                 scriptname = savepv(s + 1);
3689                 Safefree(PL_origfilename);
3690                 PL_origfilename = (char *)scriptname;
3691             }
3692         }
3693     }
3694
3695     CopFILE_free(PL_curcop);
3696     CopFILE_set(PL_curcop, PL_origfilename);
3697     if (*PL_origfilename == '-' && PL_origfilename[1] == '\0')
3698         scriptname = (char *)"";
3699     if (fdscript >= 0) {
3700         rsfp = PerlIO_fdopen(fdscript,PERL_SCRIPT_MODE);
3701     }
3702     else if (!*scriptname) {
3703         forbid_setid(0, *suidscript);
3704         return NULL;
3705     }
3706     else {
3707 #ifdef FAKE_BIT_BUCKET
3708         /* This hack allows one not to have /dev/null (or BIT_BUCKET as it
3709          * is called) and still have the "-e" work.  (Believe it or not,
3710          * a /dev/null is required for the "-e" to work because source
3711          * filter magic is used to implement it. ) This is *not* a general
3712          * replacement for a /dev/null.  What we do here is create a temp
3713          * file (an empty file), open up that as the script, and then
3714          * immediately close and unlink it.  Close enough for jazz. */
3715 #define FAKE_BIT_BUCKET_PREFIX "/tmp/perlnull-"
3716 #define FAKE_BIT_BUCKET_SUFFIX "XXXXXXXX"
3717 #define FAKE_BIT_BUCKET_TEMPLATE FAKE_BIT_BUCKET_PREFIX FAKE_BIT_BUCKET_SUFFIX
3718         char tmpname[sizeof(FAKE_BIT_BUCKET_TEMPLATE)] = {
3719             FAKE_BIT_BUCKET_TEMPLATE
3720         };
3721         const char * const err = "Failed to create a fake bit bucket";
3722         if (strEQ(scriptname, BIT_BUCKET)) {
3723 #ifdef HAS_MKSTEMP /* Hopefully mkstemp() is safe here. */
3724             int tmpfd = mkstemp(tmpname);
3725             if (tmpfd > -1) {
3726                 scriptname = tmpname;
3727                 close(tmpfd);
3728             } else
3729                 Perl_croak(aTHX_ err);
3730 #else
3731 #  ifdef HAS_MKTEMP
3732             scriptname = mktemp(tmpname);
3733             if (!scriptname)
3734                 Perl_croak(aTHX_ err);
3735 #  endif
3736 #endif
3737         }
3738 #endif
3739         rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
3740 #ifdef FAKE_BIT_BUCKET
3741         if (memEQ(scriptname, FAKE_BIT_BUCKET_PREFIX,
3742                   sizeof(FAKE_BIT_BUCKET_PREFIX) - 1)
3743             && strlen(scriptname) == sizeof(tmpname) - 1) {
3744             unlink(scriptname);
3745         }
3746         scriptname = BIT_BUCKET;
3747 #endif
3748     }
3749     if (!rsfp) {
3750         /* PSz 16 Sep 03  Keep neat error message */
3751         if (PL_e_script)
3752             Perl_croak(aTHX_ "Can't open "BIT_BUCKET": %s\n", Strerror(errno));
3753         else
3754             Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
3755                     CopFILE(PL_curcop), Strerror(errno));
3756     }
3757 #if defined(HAS_FCNTL) && defined(F_SETFD)
3758     /* ensure close-on-exec */
3759     fcntl(PerlIO_fileno(rsfp), F_SETFD, 1);
3760 #endif
3761     return rsfp;
3762 }
3763
3764 /* Mention
3765  * I_SYSSTATVFS HAS_FSTATVFS
3766  * I_SYSMOUNT
3767  * I_STATFS     HAS_FSTATFS     HAS_GETFSSTAT
3768  * I_MNTENT     HAS_GETMNTENT   HAS_HASMNTOPT
3769  * here so that metaconfig picks them up. */
3770
3771
3772 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
3773 /* Don't even need this function.  */
3774 #else
3775 STATIC void
3776 S_validate_suid(pTHX_ PerlIO *rsfp)
3777 {
3778     const UV  my_uid = PerlProc_getuid();
3779     const UV my_euid = PerlProc_geteuid();
3780     const UV  my_gid = PerlProc_getgid();
3781     const UV my_egid = PerlProc_getegid();
3782
3783     PERL_ARGS_ASSERT_VALIDATE_SUID;
3784
3785     if (my_euid != my_uid || my_egid != my_gid) {       /* (suidperl doesn't exist, in fact) */
3786         dVAR;
3787
3788         PerlLIO_fstat(PerlIO_fileno(rsfp),&PL_statbuf); /* may be either wrapped or real suid */
3789         if ((my_euid != my_uid && my_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
3790             ||
3791             (my_egid != my_gid && my_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
3792            )
3793             if (!PL_do_undump)
3794                 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
3795 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
3796         /* not set-id, must be wrapped */
3797     }
3798 }
3799 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
3800
3801 STATIC void
3802 S_find_beginning(pTHX_ SV* linestr_sv, PerlIO *rsfp)
3803 {
3804     dVAR;
3805     const char *s;
3806     const char *s2;
3807
3808     PERL_ARGS_ASSERT_FIND_BEGINNING;
3809
3810     /* skip forward in input to the real script? */
3811
3812     do {
3813         if ((s = sv_gets(linestr_sv, rsfp, 0)) == NULL)
3814             Perl_croak(aTHX_ "No Perl script found in input\n");
3815         s2 = s;
3816     } while (!(*s == '#' && s[1] == '!' && ((s = instr(s,"perl")) || (s = instr(s2,"PERL")))));
3817     PerlIO_ungetc(rsfp, '\n');          /* to keep line count right */
3818     while (*s && !(isSPACE (*s) || *s == '#')) s++;
3819     s2 = s;
3820     while (*s == ' ' || *s == '\t') s++;
3821     if (*s++ == '-') {
3822         while (isDIGIT(s2[-1]) || s2[-1] == '-' || s2[-1] == '.'
3823                || s2[-1] == '_') s2--;
3824         if (strnEQ(s2-4,"perl",4))
3825             while ((s = moreswitches(s)))
3826                 ;
3827     }
3828 }
3829
3830
3831 STATIC void
3832 S_init_ids(pTHX)
3833 {
3834     /* no need to do anything here any more if we don't
3835      * do tainting. */
3836 #if !NO_TAINT_SUPPORT
3837     dVAR;
3838     const UV my_uid = PerlProc_getuid();
3839     const UV my_euid = PerlProc_geteuid();
3840     const UV my_gid = PerlProc_getgid();
3841     const UV my_egid = PerlProc_getegid();
3842
3843     /* Should not happen: */
3844     CHECK_MALLOC_TAINT(my_uid && (my_euid != my_uid || my_egid != my_gid));
3845     TAINTING_set( TAINTING_get | (my_uid && (my_euid != my_uid || my_egid != my_gid)) );
3846 #endif
3847     /* BUG */
3848     /* PSz 27 Feb 04
3849      * Should go by suidscript, not uid!=euid: why disallow
3850      * system("ls") in scripts run from setuid things?
3851      * Or, is this run before we check arguments and set suidscript?
3852      * What about SETUID_SCRIPTS_ARE_SECURE_NOW: could we use fdscript then?
3853      * (We never have suidscript, can we be sure to have fdscript?)
3854      * Or must then go by UID checks? See comments in forbid_setid also.
3855      */
3856 }
3857
3858 /* This is used very early in the lifetime of the program,
3859  * before even the options are parsed, so PL_tainting has
3860  * not been initialized properly.  */
3861 bool
3862 Perl_doing_taint(int argc, char *argv[], char *envp[])
3863 {
3864 #ifndef PERL_IMPLICIT_SYS
3865     /* If we have PERL_IMPLICIT_SYS we can't call getuid() et alia
3866      * before we have an interpreter-- and the whole point of this
3867      * function is to be called at such an early stage.  If you are on
3868      * a system with PERL_IMPLICIT_SYS but you do have a concept of
3869      * "tainted because running with altered effective ids', you'll
3870      * have to add your own checks somewhere in here.  The two most
3871      * known samples of 'implicitness' are Win32 and NetWare, neither
3872      * of which has much of concept of 'uids'. */
3873     int uid  = PerlProc_getuid();
3874     int euid = PerlProc_geteuid();
3875     int gid  = PerlProc_getgid();
3876     int egid = PerlProc_getegid();
3877     (void)envp;
3878
3879 #ifdef VMS
3880     uid  |=  gid << 16;
3881     euid |= egid << 16;
3882 #endif
3883     if (uid && (euid != uid || egid != gid))
3884         return 1;
3885 #endif /* !PERL_IMPLICIT_SYS */
3886     /* This is a really primitive check; environment gets ignored only
3887      * if -T are the first chars together; otherwise one gets
3888      *  "Too late" message. */
3889     if ( argc > 1 && argv[1][0] == '-'
3890          && (argv[1][1] == 't' || argv[1][1] == 'T') )
3891         return 1;
3892     return 0;
3893 }
3894
3895 /* Passing the flag as a single char rather than a string is a slight space
3896    optimisation.  The only message that isn't /^-.$/ is
3897    "program input from stdin", which is substituted in place of '\0', which
3898    could never be a command line flag.  */
3899 STATIC void
3900 S_forbid_setid(pTHX_ const char flag, const bool suidscript) /* g */
3901 {
3902     dVAR;
3903     char string[3] = "-x";
3904     const char *message = "program input from stdin";
3905
3906     if (flag) {
3907         string[1] = flag;
3908         message = string;
3909     }
3910
3911 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
3912     if (PerlProc_getuid() != PerlProc_geteuid())
3913         Perl_croak(aTHX_ "No %s allowed while running setuid", message);
3914     if (PerlProc_getgid() != PerlProc_getegid())
3915         Perl_croak(aTHX_ "No %s allowed while running setgid", message);
3916 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
3917     if (suidscript)
3918         Perl_croak(aTHX_ "No %s allowed with (suid) fdscript", message);
3919 }
3920
3921 void
3922 Perl_init_dbargs(pTHX)
3923 {
3924     AV *const args = PL_dbargs = GvAV(gv_AVadd((gv_fetchpvs("DB::args",
3925                                                             GV_ADDMULTI,
3926                                                             SVt_PVAV))));
3927
3928     if (AvREAL(args)) {
3929         /* Someone has already created it.
3930            It might have entries, and if we just turn off AvREAL(), they will
3931            "leak" until global destruction.  */
3932         av_clear(args);
3933         if (SvTIED_mg((const SV *)args, PERL_MAGIC_tied))
3934             Perl_croak(aTHX_ "Cannot set tied @DB::args");
3935     }
3936     AvREIFY_only(PL_dbargs);
3937 }
3938
3939 void
3940 Perl_init_debugger(pTHX)
3941 {
3942     dVAR;
3943     HV * const ostash = PL_curstash;
3944
3945     PL_curstash = (HV *)SvREFCNT_inc_simple(PL_debstash);
3946
3947     Perl_init_dbargs(aTHX);
3948     PL_DBgv = gv_fetchpvs("DB::DB", GV_ADDMULTI, SVt_PVGV);
3949     PL_DBline = gv_fetchpvs("DB::dbline", GV_ADDMULTI, SVt_PVAV);
3950     PL_DBsub = gv_HVadd(gv_fetchpvs("DB::sub", GV_ADDMULTI, SVt_PVHV));
3951     PL_DBsingle = GvSV((gv_fetchpvs("DB::single", GV_ADDMULTI, SVt_PV)));
3952     if (!SvIOK(PL_DBsingle))
3953         sv_setiv(PL_DBsingle, 0);
3954     PL_DBtrace = GvSV((gv_fetchpvs("DB::trace", GV_ADDMULTI, SVt_PV)));
3955     if (!SvIOK(PL_DBtrace))
3956         sv_setiv(PL_DBtrace, 0);
3957     PL_DBsignal = GvSV((gv_fetchpvs("DB::signal", GV_ADDMULTI, SVt_PV)));
3958     if (!SvIOK(PL_DBsignal))
3959         sv_setiv(PL_DBsignal, 0);
3960     SvREFCNT_dec(PL_curstash);
3961     PL_curstash = ostash;
3962 }
3963
3964 #ifndef STRESS_REALLOC
3965 #define REASONABLE(size) (size)
3966 #else
3967 #define REASONABLE(size) (1) /* unreasonable */
3968 #endif
3969
3970 void
3971 Perl_init_stacks(pTHX)
3972 {
3973     dVAR;
3974     /* start with 128-item stack and 8K cxstack */
3975     PL_curstackinfo = new_stackinfo(REASONABLE(128),
3976                                  REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
3977     PL_curstackinfo->si_type = PERLSI_MAIN;
3978     PL_curstack = PL_curstackinfo->si_stack;
3979     PL_mainstack = PL_curstack;         /* remember in case we switch stacks */
3980
3981     PL_stack_base = AvARRAY(PL_curstack);
3982     PL_stack_sp = PL_stack_base;
3983     PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
3984
3985     Newx(PL_tmps_stack,REASONABLE(128),SV*);
3986     PL_tmps_floor = -1;
3987     PL_tmps_ix = -1;
3988     PL_tmps_max = REASONABLE(128);
3989
3990     Newx(PL_markstack,REASONABLE(32),I32);
3991     PL_markstack_ptr = PL_markstack;
3992     PL_markstack_max = PL_markstack + REASONABLE(32);
3993
3994     SET_MARK_OFFSET;
3995
3996     Newx(PL_scopestack,REASONABLE(32),I32);
3997 #ifdef DEBUGGING
3998     Newx(PL_scopestack_name,REASONABLE(32),const char*);
3999 #endif
4000     PL_scopestack_ix = 0;
4001     PL_scopestack_max = REASONABLE(32);
4002
4003     Newx(PL_savestack,REASONABLE(128),ANY);
4004     PL_savestack_ix = 0;
4005     PL_savestack_max = REASONABLE(128);
4006 }
4007
4008 #undef REASONABLE
4009
4010 STATIC void
4011 S_nuke_stacks(pTHX)
4012 {
4013     dVAR;
4014     while (PL_curstackinfo->si_next)
4015         PL_curstackinfo = PL_curstackinfo->si_next;
4016     while (PL_curstackinfo) {
4017         PERL_SI *p = PL_curstackinfo->si_prev;
4018         /* curstackinfo->si_stack got nuked by sv_free_arenas() */
4019         Safefree(PL_curstackinfo->si_cxstack);
4020         Safefree(PL_curstackinfo);
4021         PL_curstackinfo = p;
4022     }
4023     Safefree(PL_tmps_stack);
4024     Safefree(PL_markstack);
4025     Safefree(PL_scopestack);
4026 #ifdef DEBUGGING
4027     Safefree(PL_scopestack_name);
4028 #endif
4029     Safefree(PL_savestack);
4030 }
4031
4032 void
4033 Perl_populate_isa(pTHX_ const char *name, STRLEN len, ...)
4034 {
4035     GV *const gv = gv_fetchpvn(name, len, GV_ADD | GV_ADDMULTI, SVt_PVAV);
4036     AV *const isa = GvAVn(gv);
4037     va_list args;
4038
4039     PERL_ARGS_ASSERT_POPULATE_ISA;
4040
4041     if(AvFILLp(isa) != -1)
4042         return;
4043
4044     /* NOTE: No support for tied ISA */
4045
4046     va_start(args, len);
4047     do {
4048         const char *const parent = va_arg(args, const char*);
4049         size_t parent_len;
4050
4051         if (!parent)
4052             break;
4053         parent_len = va_arg(args, size_t);
4054
4055         /* Arguments are supplied with a trailing ::  */
4056         assert(parent_len > 2);
4057         assert(parent[parent_len - 1] == ':');
4058         assert(parent[parent_len - 2] == ':');
4059         av_push(isa, newSVpvn(parent, parent_len - 2));
4060         (void) gv_fetchpvn(parent, parent_len, GV_ADD, SVt_PVGV);
4061     } while (1);
4062     va_end(args);
4063 }
4064
4065
4066 STATIC void
4067 S_init_predump_symbols(pTHX)
4068 {
4069     dVAR;
4070     GV *tmpgv;
4071     IO *io;
4072
4073     sv_setpvs(get_sv("\"", GV_ADD), " ");
4074     PL_ofsgv = (GV*)SvREFCNT_inc(gv_fetchpvs(",", GV_ADD|GV_NOTQUAL, SVt_PV));
4075
4076
4077     /* Historically, PVIOs were blessed into IO::Handle, unless
4078        FileHandle was loaded, in which case they were blessed into
4079        that. Action at a distance.
4080        However, if we simply bless into IO::Handle, we break code
4081        that assumes that PVIOs will have (among others) a seek
4082        method. IO::File inherits from IO::Handle and IO::Seekable,
4083        and provides the needed methods. But if we simply bless into
4084        it, then we break code that assumed that by loading
4085        IO::Handle, *it* would work.
4086        So a compromise is to set up the correct @IO::File::ISA,
4087        so that code that does C<use IO::Handle>; will still work.
4088     */
4089
4090     Perl_populate_isa(aTHX_ STR_WITH_LEN("IO::File::ISA"),
4091                       STR_WITH_LEN("IO::Handle::"),
4092                       STR_WITH_LEN("IO::Seekable::"),
4093                       STR_WITH_LEN("Exporter::"),
4094                       NULL);
4095
4096     PL_stdingv = gv_fetchpvs("STDIN", GV_ADD|GV_NOTQUAL, SVt_PVIO);
4097     GvMULTI_on(PL_stdingv);
4098     io = GvIOp(PL_stdingv);
4099     IoTYPE(io) = IoTYPE_RDONLY;
4100     IoIFP(io) = PerlIO_stdin();
4101     tmpgv = gv_fetchpvs("stdin", GV_ADD|GV_NOTQUAL, SVt_PV);
4102     GvMULTI_on(tmpgv);
4103     GvIOp(tmpgv) = MUTABLE_IO(SvREFCNT_inc_simple(io));
4104
4105     tmpgv = gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVIO);
4106     GvMULTI_on(tmpgv);
4107     io = GvIOp(tmpgv);
4108     IoTYPE(io) = IoTYPE_WRONLY;
4109     IoOFP(io) = IoIFP(io) = PerlIO_stdout();
4110     setdefout(tmpgv);
4111     tmpgv = gv_fetchpvs("stdout", GV_ADD|GV_NOTQUAL, SVt_PV);
4112     GvMULTI_on(tmpgv);
4113     GvIOp(tmpgv) = MUTABLE_IO(SvREFCNT_inc_simple(io));
4114
4115     PL_stderrgv = gv_fetchpvs("STDERR", GV_ADD|GV_NOTQUAL, SVt_PVIO);
4116     GvMULTI_on(PL_stderrgv);
4117     io = GvIOp(PL_stderrgv);
4118     IoTYPE(io) = IoTYPE_WRONLY;
4119     IoOFP(io) = IoIFP(io) = PerlIO_stderr();
4120     tmpgv = gv_fetchpvs("stderr", GV_ADD|GV_NOTQUAL, SVt_PV);
4121     GvMULTI_on(tmpgv);
4122     GvIOp(tmpgv) = MUTABLE_IO(SvREFCNT_inc_simple(io));
4123
4124     PL_statname = newSVpvs("");         /* last filename we did stat on */
4125 }
4126
4127 void
4128 Perl_init_argv_symbols(pTHX_ int argc, char **argv)
4129 {
4130     dVAR;
4131
4132     PERL_ARGS_ASSERT_INIT_ARGV_SYMBOLS;
4133
4134     argc--,argv++;      /* skip name of script */
4135     if (PL_doswitches) {
4136         for (; argc > 0 && **argv == '-'; argc--,argv++) {
4137             char *s;
4138             if (!argv[0][1])
4139                 break;
4140             if (argv[0][1] == '-' && !argv[0][2]) {
4141                 argc--,argv++;
4142                 break;
4143             }
4144             if ((s = strchr(argv[0], '='))) {
4145                 const char *const start_name = argv[0] + 1;
4146                 sv_setpv(GvSV(gv_fetchpvn_flags(start_name, s - start_name,
4147                                                 TRUE, SVt_PV)), s + 1);
4148             }
4149             else
4150                 sv_setiv(GvSV(gv_fetchpv(argv[0]+1, GV_ADD, SVt_PV)),1);
4151         }
4152     }
4153     if ((PL_argvgv = gv_fetchpvs("ARGV", GV_ADD|GV_NOTQUAL, SVt_PVAV))) {
4154         GvMULTI_on(PL_argvgv);
4155         (void)gv_AVadd(PL_argvgv);
4156         av_clear(GvAVn(PL_argvgv));
4157         for (; argc > 0; argc--,argv++) {
4158             SV * const sv = newSVpv(argv[0],0);
4159             av_push(GvAVn(PL_argvgv),sv);
4160             if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) {
4161                  if (PL_unicode & PERL_UNICODE_ARGV_FLAG)
4162                       SvUTF8_on(sv);
4163             }
4164             if (PL_unicode & PERL_UNICODE_WIDESYSCALLS_FLAG) /* Sarathy? */
4165                  (void)sv_utf8_decode(sv);
4166         }
4167     }
4168
4169     if (PL_inplace && (!PL_argvgv || AvFILL(GvAV(PL_argvgv)) == -1))
4170         Perl_ck_warner_d(aTHX_ packWARN(WARN_INPLACE),
4171                          "-i used with no filenames on the command line, "
4172                          "reading from STDIN");
4173 }
4174
4175 STATIC void
4176 S_init_postdump_symbols(pTHX_ int argc, char **argv, char **env)
4177 {
4178     dVAR;
4179     GV* tmpgv;
4180
4181     PERL_ARGS_ASSERT_INIT_POSTDUMP_SYMBOLS;
4182
4183     PL_toptarget = newSV_type(SVt_PVIV);
4184     sv_setpvs(PL_toptarget, "");
4185     PL_bodytarget = newSV_type(SVt_PVIV);
4186     sv_setpvs(PL_bodytarget, "");
4187     PL_formtarget = PL_bodytarget;
4188
4189     TAINT;
4190
4191     init_argv_symbols(argc,argv);
4192
4193     if ((tmpgv = gv_fetchpvs("0", GV_ADD|GV_NOTQUAL, SVt_PV))) {
4194         sv_setpv(GvSV(tmpgv),PL_origfilename);
4195     }
4196     if ((PL_envgv = gv_fetchpvs("ENV", GV_ADD|GV_NOTQUAL, SVt_PVHV))) {
4197         HV *hv;
4198         bool env_is_not_environ;
4199         GvMULTI_on(PL_envgv);
4200         hv = GvHVn(PL_envgv);
4201         hv_magic(hv, NULL, PERL_MAGIC_env);
4202 #ifndef PERL_MICRO
4203 #ifdef USE_ENVIRON_ARRAY
4204         /* Note that if the supplied env parameter is actually a copy
4205            of the global environ then it may now point to free'd memory
4206            if the environment has been modified since. To avoid this
4207            problem we treat env==NULL as meaning 'use the default'
4208         */
4209         if (!env)
4210             env = environ;
4211         env_is_not_environ = env != environ;
4212         if (env_is_not_environ
4213 #  ifdef USE_ITHREADS
4214             && PL_curinterp == aTHX
4215 #  endif
4216            )
4217         {
4218             environ[0] = NULL;
4219         }
4220         if (env) {
4221           char *s, *old_var;
4222           SV *sv;
4223           for (; *env; env++) {
4224             old_var = *env;
4225
4226             if (!(s = strchr(old_var,'=')) || s == old_var)
4227                 continue;
4228
4229 #if defined(MSDOS) && !defined(DJGPP)
4230             *s = '\0';
4231             (void)strupr(old_var);
4232             *s = '=';
4233 #endif
4234             sv = newSVpv(s+1, 0);
4235             (void)hv_store(hv, old_var, s - old_var, sv, 0);
4236             if (env_is_not_environ)
4237                 mg_set(sv);
4238           }
4239       }
4240 #endif /* USE_ENVIRON_ARRAY */
4241 #endif /* !PERL_MICRO */
4242     }
4243     TAINT_NOT;
4244
4245     /* touch @F array to prevent spurious warnings 20020415 MJD */
4246     if (PL_minus_a) {
4247       (void) get_av("main::F", GV_ADD | GV_ADDMULTI);
4248     }
4249 }
4250
4251 STATIC void
4252 S_init_perllib(pTHX)
4253 {
4254     dVAR;
4255 #ifndef VMS
4256     const char *perl5lib = NULL;
4257 #endif
4258     const char *s;
4259 #if defined(WIN32) && !defined(PERL_IS_MINIPERL)
4260     STRLEN len;
4261 #endif
4262
4263     if (!TAINTING_get) {
4264 #ifndef VMS
4265         perl5lib = PerlEnv_getenv("PERL5LIB");
4266 /*
4267  * It isn't possible to delete an environment variable with
4268  * PERL_USE_SAFE_PUTENV set unless unsetenv() is also available, so in that
4269  * case we treat PERL5LIB as undefined if it has a zero-length value.
4270  */
4271 #if defined(PERL_USE_SAFE_PUTENV) && ! defined(HAS_UNSETENV)
4272         if (perl5lib && *perl5lib != '\0')
4273 #else
4274         if (perl5lib)
4275 #endif
4276             incpush_use_sep(perl5lib, 0, INCPUSH_ADD_SUB_DIRS);
4277         else {
4278             s = PerlEnv_getenv("PERLLIB");
4279             if (s)
4280                 incpush_use_sep(s, 0, 0);
4281         }
4282 #else /* VMS */
4283         /* Treat PERL5?LIB as a possible search list logical name -- the
4284          * "natural" VMS idiom for a Unix path string.  We allow each
4285          * element to be a set of |-separated directories for compatibility.
4286          */
4287         char buf[256];
4288         int idx = 0;
4289         if (my_trnlnm("PERL5LIB",buf,0))
4290             do {
4291                 incpush_use_sep(buf, 0, INCPUSH_ADD_SUB_DIRS);
4292             } while (my_trnlnm("PERL5LIB",buf,++idx));
4293         else {
4294             while (my_trnlnm("PERLLIB",buf,idx++))
4295                 incpush_use_sep(buf, 0, 0);
4296         }
4297 #endif /* VMS */
4298     }
4299
4300 #ifndef PERL_IS_MINIPERL
4301     /* miniperl gets just -I..., the split of $ENV{PERL5LIB}, and "." in @INC
4302        (and not the architecture specific directories from $ENV{PERL5LIB}) */
4303
4304 /* Use the ~-expanded versions of APPLLIB (undocumented),
4305     SITEARCH, SITELIB, VENDORARCH, VENDORLIB, ARCHLIB and PRIVLIB
4306 */
4307 #ifdef APPLLIB_EXP
4308     S_incpush_use_sep(aTHX_ STR_WITH_LEN(APPLLIB_EXP),
4309                       INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE);
4310 #endif
4311
4312 #ifdef SITEARCH_EXP
4313     /* sitearch is always relative to sitelib on Windows for
4314      * DLL-based path intuition to work correctly */
4315 #  if !defined(WIN32)
4316         S_incpush_use_sep(aTHX_ STR_WITH_LEN(SITEARCH_EXP),
4317                           INCPUSH_CAN_RELOCATE);
4318 #  endif
4319 #endif
4320
4321 #ifdef SITELIB_EXP
4322 #  if defined(WIN32)
4323     /* this picks up sitearch as well */
4324         s = win32_get_sitelib(PERL_FS_VERSION, &len);
4325         if (s)
4326             incpush_use_sep(s, len, INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE);
4327 #  else
4328         S_incpush_use_sep(aTHX_ STR_WITH_LEN(SITELIB_EXP), INCPUSH_CAN_RELOCATE);
4329 #  endif
4330 #endif
4331
4332 #ifdef PERL_VENDORARCH_EXP
4333     /* vendorarch is always relative to vendorlib on Windows for
4334      * DLL-based path intuition to work correctly */
4335 #  if !defined(WIN32)
4336     S_incpush_use_sep(aTHX_ STR_WITH_LEN(PERL_VENDORARCH_EXP),
4337                       INCPUSH_CAN_RELOCATE);
4338 #  endif
4339 #endif
4340
4341 #ifdef PERL_VENDORLIB_EXP
4342 #  if defined(WIN32)
4343     /* this picks up vendorarch as well */
4344         s = win32_get_vendorlib(PERL_FS_VERSION, &len);
4345         if (s)
4346             incpush_use_sep(s, len, INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE);
4347 #  else
4348         S_incpush_use_sep(aTHX_ STR_WITH_LEN(PERL_VENDORLIB_EXP),
4349                           INCPUSH_CAN_RELOCATE);
4350 #  endif
4351 #endif
4352
4353 #ifdef ARCHLIB_EXP
4354     S_incpush_use_sep(aTHX_ STR_WITH_LEN(ARCHLIB_EXP), INCPUSH_CAN_RELOCATE);
4355 #endif
4356
4357 #ifndef PRIVLIB_EXP
4358 #  define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
4359 #endif
4360
4361 #if defined(WIN32)
4362     s = win32_get_privlib(PERL_FS_VERSION, &len);
4363     if (s)
4364         incpush_use_sep(s, len, INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE);
4365 #else
4366 #  ifdef NETWARE
4367     S_incpush_use_sep(aTHX_ PRIVLIB_EXP, 0, INCPUSH_CAN_RELOCATE);
4368 #  else
4369     S_incpush_use_sep(aTHX_ STR_WITH_LEN(PRIVLIB_EXP), INCPUSH_CAN_RELOCATE);
4370 #  endif
4371 #endif
4372
4373 #ifdef PERL_OTHERLIBDIRS
4374     S_incpush_use_sep(aTHX_ STR_WITH_LEN(PERL_OTHERLIBDIRS),
4375                       INCPUSH_ADD_VERSIONED_SUB_DIRS|INCPUSH_NOT_BASEDIR
4376                       |INCPUSH_CAN_RELOCATE);
4377 #endif
4378
4379     if (!TAINTING_get) {
4380 #ifndef VMS
4381 /*
4382  * It isn't possible to delete an environment variable with
4383  * PERL_USE_SAFE_PUTENV set unless unsetenv() is also available, so in that
4384  * case we treat PERL5LIB as undefined if it has a zero-length value.
4385  */
4386 #if defined(PERL_USE_SAFE_PUTENV) && ! defined(HAS_UNSETENV)
4387         if (perl5lib && *perl5lib != '\0')
4388 #else
4389         if (perl5lib)
4390 #endif
4391             incpush_use_sep(perl5lib, 0,
4392                             INCPUSH_ADD_OLD_VERS|INCPUSH_NOT_BASEDIR);
4393 #else /* VMS */
4394         /* Treat PERL5?LIB as a possible search list logical name -- the
4395          * "natural" VMS idiom for a Unix path string.  We allow each
4396          * element to be a set of |-separated directories for compatibility.
4397          */
4398         char buf[256];
4399         int idx = 0;
4400         if (my_trnlnm("PERL5LIB",buf,0))
4401             do {
4402                 incpush_use_sep(buf, 0,
4403                                 INCPUSH_ADD_OLD_VERS|INCPUSH_NOT_BASEDIR);
4404             } while (my_trnlnm("PERL5LIB",buf,++idx));
4405 #endif /* VMS */
4406     }
4407
4408 /* Use the ~-expanded versions of APPLLIB (undocumented),
4409     SITELIB and VENDORLIB for older versions
4410 */
4411 #ifdef APPLLIB_EXP
4412     S_incpush_use_sep(aTHX_ STR_WITH_LEN(APPLLIB_EXP), INCPUSH_ADD_OLD_VERS
4413                       |INCPUSH_NOT_BASEDIR|INCPUSH_CAN_RELOCATE);
4414 #endif
4415
4416 #if defined(SITELIB_STEM) && defined(PERL_INC_VERSION_LIST)
4417     /* Search for version-specific dirs below here */
4418     S_incpush_use_sep(aTHX_ STR_WITH_LEN(SITELIB_STEM),
4419                       INCPUSH_ADD_OLD_VERS|INCPUSH_CAN_RELOCATE);
4420 #endif
4421
4422
4423 #if defined(PERL_VENDORLIB_STEM) && defined(PERL_INC_VERSION_LIST)
4424     /* Search for version-specific dirs below here */
4425     S_incpush_use_sep(aTHX_ STR_WITH_LEN(PERL_VENDORLIB_STEM),
4426                       INCPUSH_ADD_OLD_VERS|INCPUSH_CAN_RELOCATE);
4427 #endif
4428
4429 #ifdef PERL_OTHERLIBDIRS
4430     S_incpush_use_sep(aTHX_ STR_WITH_LEN(PERL_OTHERLIBDIRS),
4431                       INCPUSH_ADD_OLD_VERS|INCPUSH_ADD_ARCHONLY_SUB_DIRS
4432                       |INCPUSH_CAN_RELOCATE);
4433 #endif
4434 #endif /* !PERL_IS_MINIPERL */
4435
4436     if (!TAINTING_get)
4437         S_incpush(aTHX_ STR_WITH_LEN("."), 0);
4438 }
4439
4440 #if defined(DOSISH) || defined(__SYMBIAN32__)
4441 #    define PERLLIB_SEP ';'
4442 #else
4443 #  if defined(VMS)
4444 #    define PERLLIB_SEP '|'
4445 #  else
4446 #    define PERLLIB_SEP ':'
4447 #  endif
4448 #endif
4449 #ifndef PERLLIB_MANGLE
4450 #  define PERLLIB_MANGLE(s,n) (s)
4451 #endif
4452
4453 #ifndef PERL_IS_MINIPERL
4454 /* Push a directory onto @INC if it exists.
4455    Generate a new SV if we do this, to save needing to copy the SV we push
4456    onto @INC  */
4457 STATIC SV *
4458 S_incpush_if_exists(pTHX_ AV *const av, SV *dir, SV *const stem)
4459 {
4460     dVAR;
4461     Stat_t tmpstatbuf;
4462
4463     PERL_ARGS_ASSERT_INCPUSH_IF_EXISTS;
4464
4465     if (PerlLIO_stat(SvPVX_const(dir), &tmpstatbuf) >= 0 &&
4466         S_ISDIR(tmpstatbuf.st_mode)) {
4467         av_push(av, dir);
4468         dir = newSVsv(stem);
4469     } else {
4470         /* Truncate dir back to stem.  */
4471         SvCUR_set(dir, SvCUR(stem));
4472     }
4473     return dir;
4474 }
4475 #endif
4476
4477 STATIC SV *
4478 S_mayberelocate(pTHX_ const char *const dir, STRLEN len, U32 flags)
4479 {
4480     const U8 canrelocate = (U8)flags & INCPUSH_CAN_RELOCATE;
4481     SV *libdir;
4482
4483     PERL_ARGS_ASSERT_MAYBERELOCATE;
4484     assert(len > 0);
4485
4486         if (len) {
4487             /* I am not convinced that this is valid when PERLLIB_MANGLE is
4488                defined to so something (in os2/os2.c), but the code has been
4489                this way, ignoring any possible changed of length, since
4490                760ac839baf413929cd31cc32ffd6dba6b781a81 (5.003_02) so I'll leave
4491                it be.  */
4492             libdir = newSVpvn(PERLLIB_MANGLE(dir, len), len);
4493         } else {
4494             libdir = newSVpv(PERLLIB_MANGLE(dir, 0), 0);
4495         }
4496
4497 #ifdef VMS
4498     {
4499         char *unix;
4500
4501         if ((unix = tounixspec_ts(SvPV(libdir,len),NULL)) != NULL) {
4502             len = strlen(unix);
4503             while (unix[len-1] == '/') len--;  /* Cosmetic */
4504             sv_usepvn(libdir,unix,len);
4505         }
4506         else
4507             PerlIO_printf(Perl_error_log,
4508                           "Failed to unixify @INC element \"%s\"\n",
4509                           SvPV_nolen_const(libdir));
4510     }
4511 #endif
4512
4513         /* Do the if() outside the #ifdef to avoid warnings about an unused
4514            parameter.  */
4515         if (canrelocate) {
4516 #ifdef PERL_RELOCATABLE_INC
4517         /*
4518          * Relocatable include entries are marked with a leading .../
4519          *
4520          * The algorithm is
4521          * 0: Remove that leading ".../"
4522          * 1: Remove trailing executable name (anything after the last '/')
4523          *    from the perl path to give a perl prefix
4524          * Then
4525          * While the @INC element starts "../" and the prefix ends with a real
4526          * directory (ie not . or ..) chop that real directory off the prefix
4527          * and the leading "../" from the @INC element. ie a logical "../"
4528          * cleanup
4529          * Finally concatenate the prefix and the remainder of the @INC element
4530          * The intent is that /usr/local/bin/perl and .../../lib/perl5
4531          * generates /usr/local/lib/perl5
4532          */
4533             const char *libpath = SvPVX(libdir);
4534             STRLEN libpath_len = SvCUR(libdir);
4535             if (libpath_len >= 4 && memEQ (libpath, ".../", 4)) {
4536                 /* Game on!  */
4537                 SV * const caret_X = get_sv("\030", 0);
4538                 /* Going to use the SV just as a scratch buffer holding a C
4539                    string:  */
4540                 SV *prefix_sv;
4541                 char *prefix;
4542                 char *lastslash;
4543
4544                 /* $^X is *the* source of taint if tainting is on, hence
4545                    SvPOK() won't be true.  */
4546                 assert(caret_X);
4547                 assert(SvPOKp(caret_X));
4548                 prefix_sv = newSVpvn_flags(SvPVX(caret_X), SvCUR(caret_X),
4549                                            SvUTF8(caret_X));
4550                 /* Firstly take off the leading .../
4551                    If all else fail we'll do the paths relative to the current
4552                    directory.  */
4553                 sv_chop(libdir, libpath + 4);
4554                 /* Don't use SvPV as we're intentionally bypassing taining,
4555                    mortal copies that the mg_get of tainting creates, and
4556                    corruption that seems to come via the save stack.
4557                    I guess that the save stack isn't correctly set up yet.  */
4558                 libpath = SvPVX(libdir);
4559                 libpath_len = SvCUR(libdir);
4560
4561                 /* This would work more efficiently with memrchr, but as it's
4562                    only a GNU extension we'd need to probe for it and
4563                    implement our own. Not hard, but maybe not worth it?  */
4564
4565                 prefix = SvPVX(prefix_sv);
4566                 lastslash = strrchr(prefix, '/');
4567
4568                 /* First time in with the *lastslash = '\0' we just wipe off
4569                    the trailing /perl from (say) /usr/foo/bin/perl
4570                 */
4571                 if (lastslash) {
4572                     SV *tempsv;
4573                     while ((*lastslash = '\0'), /* Do that, come what may.  */
4574                            (libpath_len >= 3 && memEQ(libpath, "../", 3)
4575                             && (lastslash = strrchr(prefix, '/')))) {
4576                         if (lastslash[1] == '\0'
4577                             || (lastslash[1] == '.'
4578                                 && (lastslash[2] == '/' /* ends "/."  */
4579                                     || (lastslash[2] == '/'
4580                                         && lastslash[3] == '/' /* or "/.."  */
4581                                         )))) {
4582                             /* Prefix ends "/" or "/." or "/..", any of which
4583                                are fishy, so don't do any more logical cleanup.
4584                             */
4585                             break;
4586                         }
4587                         /* Remove leading "../" from path  */
4588                         libpath += 3;
4589                         libpath_len -= 3;
4590                         /* Next iteration round the loop removes the last
4591                            directory name from prefix by writing a '\0' in
4592                            the while clause.  */
4593                     }
4594                     /* prefix has been terminated with a '\0' to the correct
4595                        length. libpath points somewhere into the libdir SV.
4596                        We need to join the 2 with '/' and drop the result into
4597                        libdir.  */
4598                     tempsv = Perl_newSVpvf(aTHX_ "%s/%s", prefix, libpath);
4599                     SvREFCNT_dec(libdir);
4600                     /* And this is the new libdir.  */
4601                     libdir = tempsv;
4602                     if (TAINTING_get &&
4603                         (PerlProc_getuid() != PerlProc_geteuid() ||
4604                          PerlProc_getgid() != PerlProc_getegid())) {
4605                         /* Need to taint relocated paths if running set ID  */
4606                         SvTAINTED_on(libdir);
4607                     }
4608                 }
4609                 SvREFCNT_dec(prefix_sv);
4610             }
4611 #endif
4612         }
4613     return libdir;
4614 }
4615
4616 STATIC void
4617 S_incpush(pTHX_ const char *const dir, STRLEN len, U32 flags)
4618 {
4619     dVAR;
4620 #ifndef PERL_IS_MINIPERL
4621     const U8 using_sub_dirs
4622         = (U8)flags & (INCPUSH_ADD_VERSIONED_SUB_DIRS
4623                        |INCPUSH_ADD_ARCHONLY_SUB_DIRS|INCPUSH_ADD_OLD_VERS);
4624     const U8 add_versioned_sub_dirs
4625         = (U8)flags & INCPUSH_ADD_VERSIONED_SUB_DIRS;
4626     const U8 add_archonly_sub_dirs
4627         = (U8)flags & INCPUSH_ADD_ARCHONLY_SUB_DIRS;
4628 #ifdef PERL_INC_VERSION_LIST
4629     const U8 addoldvers  = (U8)flags & INCPUSH_ADD_OLD_VERS;
4630 #endif
4631 #endif
4632     const U8 unshift     = (U8)flags & INCPUSH_UNSHIFT;
4633     const U8 push_basedir = (flags & INCPUSH_NOT_BASEDIR) ? 0 : 1;
4634     AV *const inc = GvAVn(PL_incgv);
4635
4636     PERL_ARGS_ASSERT_INCPUSH;
4637     assert(len > 0);
4638
4639     /* Could remove this vestigial extra block, if we don't mind a lot of
4640        re-indenting diff noise.  */
4641     {
4642         SV *const libdir = mayberelocate(dir, len, flags);
4643         /* Change 20189146be79a0596543441fa369c6bf7f85103f, to fix RT#6665,
4644            arranged to unshift #! line -I onto the front of @INC. However,
4645            -I can add version and architecture specific libraries, and they
4646            need to go first. The old code assumed that it was always
4647            pushing. Hence to make it work, need to push the architecture
4648            (etc) libraries onto a temporary array, then "unshift" that onto
4649            the front of @INC.  */
4650 #ifndef PERL_IS_MINIPERL
4651         AV *const av = (using_sub_dirs) ? (unshift ? newAV() : inc) : NULL;
4652
4653         /*
4654          * BEFORE pushing libdir onto @INC we may first push version- and
4655          * archname-specific sub-directories.
4656          */
4657         if (using_sub_dirs) {
4658             SV *subdir = newSVsv(libdir);
4659 #ifdef PERL_INC_VERSION_LIST
4660             /* Configure terminates PERL_INC_VERSION_LIST with a NULL */
4661             const char * const incverlist[] = { PERL_INC_VERSION_LIST };
4662             const char * const *incver;
4663 #endif
4664
4665             if (add_versioned_sub_dirs) {
4666                 /* .../version/archname if -d .../version/archname */
4667                 sv_catpvs(subdir, "/" PERL_FS_VERSION "/" ARCHNAME);
4668                 subdir = S_incpush_if_exists(aTHX_ av, subdir, libdir);
4669
4670                 /* .../version if -d .../version */
4671                 sv_catpvs(subdir, "/" PERL_FS_VERSION);
4672                 subdir = S_incpush_if_exists(aTHX_ av, subdir, libdir);
4673             }
4674
4675 #ifdef PERL_INC_VERSION_LIST
4676             if (addoldvers) {
4677                 for (incver = incverlist; *incver; incver++) {
4678                     /* .../xxx if -d .../xxx */
4679                     Perl_sv_catpvf(aTHX_ subdir, "/%s", *incver);
4680                     subdir = S_incpush_if_exists(aTHX_ av, subdir, libdir);
4681                 }
4682             }
4683 #endif
4684
4685             if (add_archonly_sub_dirs) {
4686                 /* .../archname if -d .../archname */
4687                 sv_catpvs(subdir, "/" ARCHNAME);
4688                 subdir = S_incpush_if_exists(aTHX_ av, subdir, libdir);
4689
4690             }
4691
4692             assert (SvREFCNT(subdir) == 1);
4693             SvREFCNT_dec(subdir);
4694         }
4695 #endif /* !PERL_IS_MINIPERL */
4696         /* finally add this lib directory at the end of @INC */
4697         if (unshift) {
4698 #ifdef PERL_IS_MINIPERL
4699             const U32 extra = 0;
4700 #else
4701             U32 extra = av_len(av) + 1;
4702 #endif
4703             av_unshift(inc, extra + push_basedir);
4704             if (push_basedir)
4705                 av_store(inc, extra, libdir);
4706 #ifndef PERL_IS_MINIPERL
4707             while (extra--) {
4708                 /* av owns a reference, av_store() expects to be donated a
4709                    reference, and av expects to be sane when it's cleared.
4710                    If I wanted to be naughty and wrong, I could peek inside the
4711                    implementation of av_clear(), realise that it uses
4712                    SvREFCNT_dec() too, so av's array could be a run of NULLs,
4713                    and so directly steal from it (with a memcpy() to inc, and
4714                    then memset() to NULL them out. But people copy code from the
4715                    core expecting it to be best practise, so let's use the API.
4716                    Although studious readers will note that I'm not checking any
4717                    return codes.  */
4718                 av_store(inc, extra, SvREFCNT_inc(*av_fetch(av, extra, FALSE)));
4719             }
4720             SvREFCNT_dec(av);
4721 #endif
4722         }
4723         else if (push_basedir) {
4724             av_push(inc, libdir);
4725         }
4726
4727         if (!push_basedir) {
4728             assert (SvREFCNT(libdir) == 1);
4729             SvREFCNT_dec(libdir);
4730         }
4731     }
4732 }
4733
4734 STATIC void
4735 S_incpush_use_sep(pTHX_ const char *p, STRLEN len, U32 flags)
4736 {
4737     const char *s;
4738     const char *end;
4739     /* This logic has been broken out from S_incpush(). It may be possible to
4740        simplify it.  */
4741
4742     PERL_ARGS_ASSERT_INCPUSH_USE_SEP;
4743
4744     /* perl compiled with -DPERL_RELOCATABLE_INCPUSH will ignore the len
4745      * argument to incpush_use_sep.  This allows creation of relocatable
4746      * Perl distributions that patch the binary at install time.  Those
4747      * distributions will have to provide their own relocation tools; this
4748      * is not a feature otherwise supported by core Perl.
4749      */
4750 #ifndef PERL_RELOCATABLE_INCPUSH
4751     if (!len)
4752 #endif
4753         len = strlen(p);
4754
4755     end = p + len;
4756
4757     /* Break at all separators */
4758     while ((s = (const char*)memchr(p, PERLLIB_SEP, end - p))) {
4759         if (s == p) {
4760             /* skip any consecutive separators */
4761
4762             /* Uncomment the next line for PATH semantics */
4763             /* But you'll need to write tests */
4764             /* av_push(GvAVn(PL_incgv), newSVpvs(".")); */
4765         } else {
4766             incpush(p, (STRLEN)(s - p), flags);
4767         }
4768         p = s + 1;
4769     }
4770     if (p != end)
4771         incpush(p, (STRLEN)(end - p), flags);
4772
4773 }
4774
4775 void
4776 Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
4777 {
4778     dVAR;
4779     SV *atsv;
4780     volatile const line_t oldline = PL_curcop ? CopLINE(PL_curcop) : 0;
4781     CV *cv;
4782     STRLEN len;
4783     int ret;
4784     dJMPENV;
4785
4786     PERL_ARGS_ASSERT_CALL_LIST;
4787
4788     while (av_len(paramList) >= 0) {
4789         cv = MUTABLE_CV(av_shift(paramList));
4790         if (PL_savebegin) {
4791             if (paramList == PL_beginav) {
4792                 /* save PL_beginav for compiler */
4793                 Perl_av_create_and_push(aTHX_ &PL_beginav_save, MUTABLE_SV(cv));
4794             }
4795             else if (paramList == PL_checkav) {
4796                 /* save PL_checkav for compiler */
4797                 Perl_av_create_and_push(aTHX_ &PL_checkav_save, MUTABLE_SV(cv));
4798             }
4799             else if (paramList == PL_unitcheckav) {
4800                 /* save PL_unitcheckav for compiler */
4801                 Perl_av_create_and_push(aTHX_ &PL_unitcheckav_save, MUTABLE_SV(cv));
4802             }
4803         } else {
4804             if (!PL_madskills)
4805                 SAVEFREESV(cv);
4806         }
4807         JMPENV_PUSH(ret);
4808         switch (ret) {
4809         case 0:
4810 #ifdef PERL_MAD
4811             if (PL_madskills)
4812                 PL_madskills |= 16384;
4813 #endif
4814             CALL_LIST_BODY(cv);
4815 #ifdef PERL_MAD
4816             if (PL_madskills)
4817                 PL_madskills &= ~16384;
4818 #endif
4819             atsv = ERRSV;
4820             (void)SvPV_const(atsv, len);
4821             if (len) {
4822                 PL_curcop = &PL_compiling;
4823                 CopLINE_set(PL_curcop, oldline);
4824                 if (paramList == PL_beginav)
4825                     sv_catpvs(atsv, "BEGIN failed--compilation aborted");
4826                 else
4827                     Perl_sv_catpvf(aTHX_ atsv,
4828                                    "%s failed--call queue aborted",
4829                                    paramList == PL_checkav ? "CHECK"
4830                                    : paramList == PL_initav ? "INIT"
4831                                    : paramList == PL_unitcheckav ? "UNITCHECK"
4832                                    : "END");
4833                 while (PL_scopestack_ix > oldscope)
4834                     LEAVE;
4835                 JMPENV_POP;
4836                 Perl_croak(aTHX_ "%"SVf"", SVfARG(atsv));
4837             }
4838             break;
4839         case 1:
4840             STATUS_ALL_FAILURE;
4841             /* FALL THROUGH */
4842         case 2:
4843             /* my_exit() was called */
4844             while (PL_scopestack_ix > oldscope)
4845                 LEAVE;
4846             FREETMPS;
4847             SET_CURSTASH(PL_defstash);
4848             PL_curcop = &PL_compiling;
4849             CopLINE_set(PL_curcop, oldline);
4850             JMPENV_POP;
4851             my_exit_jump();
4852             assert(0); /* NOTREACHED */
4853         case 3:
4854             if (PL_restartop) {
4855                 PL_curcop = &PL_compiling;
4856                 CopLINE_set(PL_curcop, oldline);
4857                 JMPENV_JUMP(3);
4858             }
4859             PerlIO_printf(Perl_error_log, "panic: restartop in call_list\n");
4860             FREETMPS;
4861             break;
4862         }
4863         JMPENV_POP;
4864     }
4865 }
4866
4867 void
4868 Perl_my_exit(pTHX_ U32 status)
4869 {
4870     dVAR;
4871     switch (status) {
4872     case 0:
4873         STATUS_ALL_SUCCESS;
4874         break;
4875     case 1:
4876         STATUS_ALL_FAILURE;
4877         break;
4878     default:
4879         STATUS_EXIT_SET(status);
4880         break;
4881     }
4882     my_exit_jump();
4883 }
4884
4885 void
4886 Perl_my_failure_exit(pTHX)
4887 {
4888     dVAR;
4889 #ifdef VMS
4890      /* We have been called to fall on our sword.  The desired exit code
4891       * should be already set in STATUS_UNIX, but could be shifted over
4892       * by 8 bits.  STATUS_UNIX_EXIT_SET will handle the cases where a
4893       * that code is set.
4894       *
4895       * If an error code has not been set, then force the issue.
4896       */
4897     if (MY_POSIX_EXIT) {
4898
4899         /* According to the die_exit.t tests, if errno is non-zero */
4900         /* It should be used for the error status. */
4901
4902         if (errno == EVMSERR) {
4903             STATUS_NATIVE = vaxc$errno;
4904         } else {
4905
4906             /* According to die_exit.t tests, if the child_exit code is */
4907             /* also zero, then we need to exit with a code of 255 */
4908             if ((errno != 0) && (errno < 256))
4909                 STATUS_UNIX_EXIT_SET(errno);
4910             else if (STATUS_UNIX < 255) {
4911                 STATUS_UNIX_EXIT_SET(255);
4912             }
4913
4914         }
4915
4916         /* The exit code could have been set by $? or vmsish which
4917          * means that it may not have fatal set.  So convert
4918          * success/warning codes to fatal with out changing
4919          * the POSIX status code.  The severity makes VMS native
4920          * status handling work, while UNIX mode programs use the
4921          * the POSIX exit codes.
4922          */
4923          if ((STATUS_NATIVE & (STS$K_SEVERE|STS$K_ERROR)) == 0) {
4924             STATUS_NATIVE &= STS$M_COND_ID;
4925             STATUS_NATIVE |= STS$K_ERROR | STS$M_INHIB_MSG;
4926          }
4927     }
4928     else {
4929         /* Traditionally Perl on VMS always expects a Fatal Error. */
4930         if (vaxc$errno & 1) {
4931
4932             /* So force success status to failure */
4933             if (STATUS_NATIVE & 1)
4934                 STATUS_ALL_FAILURE;
4935         }
4936         else {
4937             if (!vaxc$errno) {
4938                 STATUS_UNIX = EINTR; /* In case something cares */
4939                 STATUS_ALL_FAILURE;
4940             }
4941             else {
4942                 int severity;
4943                 STATUS_NATIVE = vaxc$errno; /* Should already be this */
4944
4945                 /* Encode the severity code */
4946                 severity = STATUS_NATIVE & STS$M_SEVERITY;
4947                 STATUS_UNIX = (severity ? severity : 1) << 8;
4948
4949                 /* Perl expects this to be a fatal error */
4950                 if (severity != STS$K_SEVERE)
4951                     STATUS_ALL_FAILURE;
4952             }
4953         }
4954     }
4955
4956 #else
4957     int exitstatus;
4958     if (errno & 255)
4959         STATUS_UNIX_SET(errno);
4960     else {
4961         exitstatus = STATUS_UNIX >> 8;
4962         if (exitstatus & 255)
4963             STATUS_UNIX_SET(exitstatus);
4964         else
4965             STATUS_UNIX_SET(255);
4966     }
4967 #endif
4968     my_exit_jump();
4969 }
4970
4971 STATIC void
4972 S_my_exit_jump(pTHX)
4973 {
4974     dVAR;
4975
4976     if (PL_e_script) {
4977         SvREFCNT_dec(PL_e_script);
4978         PL_e_script = NULL;
4979     }
4980
4981     POPSTACK_TO(PL_mainstack);
4982     dounwind(-1);
4983     LEAVE_SCOPE(0);
4984
4985     JMPENV_JUMP(2);
4986 }
4987
4988 static I32
4989 read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen)
4990 {
4991     dVAR;
4992     const char * const p  = SvPVX_const(PL_e_script);
4993     const char *nl = strchr(p, '\n');
4994
4995     PERL_UNUSED_ARG(idx);
4996     PERL_UNUSED_ARG(maxlen);
4997
4998     nl = (nl) ? nl+1 : SvEND(PL_e_script);
4999     if (nl-p == 0) {
5000         filter_del(read_e_script);
5001         return 0;
5002     }
5003     sv_catpvn(buf_sv, p, nl-p);
5004     sv_chop(PL_e_script, nl);
5005     return 1;
5006 }
5007
5008 /*
5009  * Local variables:
5010  * c-indentation-style: bsd
5011  * c-basic-offset: 4
5012  * indent-tabs-mode: nil
5013  * End:
5014  *
5015  * ex: set ts=8 sts=4 sw=4 et:
5016  */