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