perl.c

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