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