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_ascii);
 989     SvREFCNT_dec(PL_utf8_alpha);
 990     SvREFCNT_dec(PL_utf8_space);
 991     SvREFCNT_dec(PL_utf8_cntrl);
 992     SvREFCNT_dec(PL_utf8_graph);
 993     SvREFCNT_dec(PL_utf8_digit);
 994     SvREFCNT_dec(PL_utf8_upper);
 995     SvREFCNT_dec(PL_utf8_lower);
 996     SvREFCNT_dec(PL_utf8_print);
 997     SvREFCNT_dec(PL_utf8_punct);
 998     SvREFCNT_dec(PL_utf8_xdigit);
 999     SvREFCNT_dec(PL_utf8_mark);
1000     SvREFCNT_dec(PL_utf8_toupper);
1001     SvREFCNT_dec(PL_utf8_totitle);
1002     SvREFCNT_dec(PL_utf8_tolower);
1003     SvREFCNT_dec(PL_utf8_tofold);
1004     SvREFCNT_dec(PL_utf8_idstart);
1005     SvREFCNT_dec(PL_utf8_idcont);
1006     PL_utf8_alnum       = NULL;
1007     PL_utf8_ascii       = NULL;
1008     PL_utf8_alpha       = NULL;
1009     PL_utf8_space       = NULL;
1010     PL_utf8_cntrl       = NULL;
1011     PL_utf8_graph       = NULL;
1012     PL_utf8_digit       = NULL;
1013     PL_utf8_upper       = NULL;
1014     PL_utf8_lower       = NULL;
1015     PL_utf8_print       = NULL;
1016     PL_utf8_punct       = NULL;
1017     PL_utf8_xdigit      = NULL;
1018     PL_utf8_mark        = NULL;
1019     PL_utf8_toupper     = NULL;
1020     PL_utf8_totitle     = NULL;
1021     PL_utf8_tolower     = NULL;
1022     PL_utf8_tofold      = NULL;
1023     PL_utf8_idstart     = NULL;
1024     PL_utf8_idcont      = NULL;
1025
1026     if (!specialWARN(PL_compiling.cop_warnings))
1027         PerlMemShared_free(PL_compiling.cop_warnings);
1028     PL_compiling.cop_warnings = NULL;
1029     Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash);
1030     PL_compiling.cop_hints_hash = NULL;
1031     CopFILE_free(&PL_compiling);
1032     CopSTASH_free(&PL_compiling);
1033
1034     /* Prepare to destruct main symbol table.  */
1035
1036     hv = PL_defstash;
1037     PL_defstash = 0;
1038     SvREFCNT_dec(hv);
1039     SvREFCNT_dec(PL_curstname);
1040     PL_curstname = NULL;
1041
1042     /* clear queued errors */
1043     SvREFCNT_dec(PL_errors);
1044     PL_errors = NULL;
1045
1046     SvREFCNT_dec(PL_isarev);
1047
1048     FREETMPS;
1049     if (destruct_level >= 2 && ckWARN_d(WARN_INTERNAL)) {
1050         if (PL_scopestack_ix != 0)
1051             Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
1052                  "Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
1053                  (long)PL_scopestack_ix);
1054         if (PL_savestack_ix != 0)
1055             Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
1056                  "Unbalanced saves: %ld more saves than restores\n",
1057                  (long)PL_savestack_ix);
1058         if (PL_tmps_floor != -1)
1059             Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Unbalanced tmps: %ld more allocs than frees\n",
1060                  (long)PL_tmps_floor + 1);
1061         if (cxstack_ix != -1)
1062             Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Unbalanced context: %ld more PUSHes than POPs\n",
1063                  (long)cxstack_ix + 1);
1064     }
1065
1066     /* Now absolutely destruct everything, somehow or other, loops or no. */
1067
1068     /* the 2 is for PL_fdpid and PL_strtab */
1069     while (sv_clean_all() > 2)
1070         ;
1071
1072     AvREAL_off(PL_fdpid);               /* no surviving entries */
1073     SvREFCNT_dec(PL_fdpid);             /* needed in io_close() */
1074     PL_fdpid = NULL;
1075
1076 #ifdef HAVE_INTERP_INTERN
1077     sys_intern_clear();
1078 #endif
1079
1080     /* Destruct the global string table. */
1081     {
1082         /* Yell and reset the HeVAL() slots that are still holding refcounts,
1083          * so that sv_free() won't fail on them.
1084          * Now that the global string table is using a single hunk of memory
1085          * for both HE and HEK, we either need to explicitly unshare it the
1086          * correct way, or actually free things here.
1087          */
1088         I32 riter = 0;
1089         const I32 max = HvMAX(PL_strtab);
1090         HE * const * const array = HvARRAY(PL_strtab);
1091         HE *hent = array[0];
1092
1093         for (;;) {
1094             if (hent && ckWARN_d(WARN_INTERNAL)) {
1095                 HE * const next = HeNEXT(hent);
1096                 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
1097                      "Unbalanced string table refcount: (%ld) for \"%s\"",
1098                      (long)hent->he_valu.hent_refcount, HeKEY(hent));
1099                 Safefree(hent);
1100                 hent = next;
1101             }
1102             if (!hent) {
1103                 if (++riter > max)
1104                     break;
1105                 hent = array[riter];
1106             }
1107         }
1108
1109         Safefree(array);
1110         HvARRAY(PL_strtab) = 0;
1111         HvTOTALKEYS(PL_strtab) = 0;
1112         HvFILL(PL_strtab) = 0;
1113     }
1114     SvREFCNT_dec(PL_strtab);
1115
1116 #ifdef USE_ITHREADS
1117     /* free the pointer tables used for cloning */
1118     ptr_table_free(PL_ptr_table);
1119     PL_ptr_table = (PTR_TBL_t*)NULL;
1120 #endif
1121
1122     /* free special SVs */
1123
1124     SvREFCNT(&PL_sv_yes) = 0;
1125     sv_clear(&PL_sv_yes);
1126     SvANY(&PL_sv_yes) = NULL;
1127     SvFLAGS(&PL_sv_yes) = 0;
1128
1129     SvREFCNT(&PL_sv_no) = 0;
1130     sv_clear(&PL_sv_no);
1131     SvANY(&PL_sv_no) = NULL;
1132     SvFLAGS(&PL_sv_no) = 0;
1133
1134     {
1135         int i;
1136         for (i=0; i<=2; i++) {
1137             SvREFCNT(PERL_DEBUG_PAD(i)) = 0;
1138             sv_clear(PERL_DEBUG_PAD(i));
1139             SvANY(PERL_DEBUG_PAD(i)) = NULL;
1140             SvFLAGS(PERL_DEBUG_PAD(i)) = 0;
1141         }
1142     }
1143
1144     if (PL_sv_count != 0 && ckWARN_d(WARN_INTERNAL))
1145         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Scalars leaked: %ld\n", (long)PL_sv_count);
1146
1147 #ifdef DEBUG_LEAKING_SCALARS
1148     if (PL_sv_count != 0) {
1149         SV* sva;
1150         SV* sv;
1151         register SV* svend;
1152
1153         for (sva = PL_sv_arenaroot; sva; sva = MUTABLE_SV(SvANY(sva))) {
1154             svend = &sva[SvREFCNT(sva)];
1155             for (sv = sva + 1; sv < svend; ++sv) {
1156                 if (SvTYPE(sv) != SVTYPEMASK) {
1157                     PerlIO_printf(Perl_debug_log, "leaked: sv=0x%p"
1158                         " flags=0x%"UVxf
1159                         " refcnt=%"UVuf pTHX__FORMAT "\n"
1160                         "\tallocated at %s:%d %s %s%s\n",
1161                         (void*)sv, (UV)sv->sv_flags, (UV)sv->sv_refcnt
1162                         pTHX__VALUE,
1163                         sv->sv_debug_file ? sv->sv_debug_file : "(unknown)",
1164                         sv->sv_debug_line,
1165                         sv->sv_debug_inpad ? "for" : "by",
1166                         sv->sv_debug_optype ?
1167                             PL_op_name[sv->sv_debug_optype]: "(none)",
1168                         sv->sv_debug_cloned ? " (cloned)" : ""
1169                     );
1170 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
1171                     Perl_dump_sv_child(aTHX_ sv);
1172 #endif
1173                 }
1174             }
1175         }
1176     }
1177 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
1178     {
1179         int status;
1180         fd_set rset;
1181         /* Wait for up to 4 seconds for child to terminate.
1182            This seems to be the least effort way of timing out on reaping
1183            its exit status.  */
1184         struct timeval waitfor = {4, 0};
1185         int sock = PL_dumper_fd;
1186
1187         shutdown(sock, 1);
1188         FD_ZERO(&rset);
1189         FD_SET(sock, &rset);
1190         select(sock + 1, &rset, NULL, NULL, &waitfor);
1191         waitpid(child, &status, WNOHANG);
1192         close(sock);
1193     }
1194 #endif
1195 #endif
1196 #ifdef DEBUG_LEAKING_SCALARS_ABORT
1197     if (PL_sv_count)
1198         abort();
1199 #endif
1200     PL_sv_count = 0;
1201
1202 #ifdef PERL_DEBUG_READONLY_OPS
1203     free(PL_slabs);
1204     PL_slabs = NULL;
1205     PL_slab_count = 0;
1206 #endif
1207
1208 #if defined(PERLIO_LAYERS)
1209     /* No more IO - including error messages ! */
1210     PerlIO_cleanup(aTHX);
1211 #endif
1212
1213     /* sv_undef needs to stay immortal until after PerlIO_cleanup
1214        as currently layers use it rather than NULL as a marker
1215        for no arg - and will try and SvREFCNT_dec it.
1216      */
1217     SvREFCNT(&PL_sv_undef) = 0;
1218     SvREADONLY_off(&PL_sv_undef);
1219
1220     Safefree(PL_origfilename);
1221     PL_origfilename = NULL;
1222     Safefree(PL_reg_start_tmp);
1223     PL_reg_start_tmp = (char**)NULL;
1224     PL_reg_start_tmpl = 0;
1225     Safefree(PL_reg_curpm);
1226     Safefree(PL_reg_poscache);
1227     free_tied_hv_pool();
1228     Safefree(PL_op_mask);
1229     Safefree(PL_psig_name);
1230     PL_psig_name = (SV**)NULL;
1231     PL_psig_ptr = (SV**)NULL;
1232     Safefree(PL_psig_pend);
1233     PL_psig_pend = (int*)NULL;
1234     {
1235         /* We need to NULL PL_psig_pend first, so that
1236            signal handlers know not to use it */
1237         int *psig_save = PL_psig_pend;
1238         PL_psig_pend = (int*)NULL;
1239         Safefree(psig_save);
1240     }
1241     PL_formfeed = NULL;
1242     nuke_stacks();
1243     PL_tainting = FALSE;
1244     PL_taint_warn = FALSE;
1245     PL_hints = 0;               /* Reset hints. Should hints be per-interpreter ? */
1246     PL_debug = 0;
1247
1248     DEBUG_P(debprofdump());
1249
1250 #ifdef USE_REENTRANT_API
1251     Perl_reentrant_free(aTHX);
1252 #endif
1253
1254     sv_free_arenas();
1255
1256     while (PL_regmatch_slab) {
1257         regmatch_slab  *s = PL_regmatch_slab;
1258         PL_regmatch_slab = PL_regmatch_slab->next;
1259         Safefree(s);
1260     }
1261
1262     /* As the absolutely last thing, free the non-arena SV for mess() */
1263
1264     if (PL_mess_sv) {
1265         /* we know that type == SVt_PVMG */
1266
1267         /* it could have accumulated taint magic */
1268         MAGIC* mg;
1269         MAGIC* moremagic;
1270         for (mg = SvMAGIC(PL_mess_sv); mg; mg = moremagic) {
1271             moremagic = mg->mg_moremagic;
1272             if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global
1273                 && mg->mg_len >= 0)
1274                 Safefree(mg->mg_ptr);
1275             Safefree(mg);
1276         }
1277
1278         /* we know that type >= SVt_PV */
1279         SvPV_free(PL_mess_sv);
1280         Safefree(SvANY(PL_mess_sv));
1281         Safefree(PL_mess_sv);
1282         PL_mess_sv = NULL;
1283     }
1284     return STATUS_EXIT;
1285 }
1286
1287 /*
1288 =for apidoc perl_free
1289
1290 Releases a Perl interpreter.  See L<perlembed>.
1291
1292 =cut
1293 */
1294
1295 void
1296 perl_free(pTHXx)
1297 {
1298     dVAR;
1299
1300     PERL_ARGS_ASSERT_PERL_FREE;
1301
1302     if (PL_veto_cleanup)
1303         return;
1304
1305 #ifdef PERL_TRACK_MEMPOOL
1306     {
1307         /*
1308          * Don't free thread memory if PERL_DESTRUCT_LEVEL is set to a non-zero
1309          * value as we're probably hunting memory leaks then
1310          */
1311         const char * const s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL");
1312         if (!s || atoi(s) == 0) {
1313             const U32 old_debug = PL_debug;
1314             /* Emulate the PerlHost behaviour of free()ing all memory allocated in this
1315                thread at thread exit.  */
1316             if (DEBUG_m_TEST) {
1317                 PerlIO_puts(Perl_debug_log, "Disabling memory debugging as we "
1318                             "free this thread's memory\n");
1319                 PL_debug &= ~ DEBUG_m_FLAG;
1320             }
1321             while(aTHXx->Imemory_debug_header.next != &(aTHXx->Imemory_debug_header))
1322                 safesysfree(sTHX + (char *)(aTHXx->Imemory_debug_header.next));
1323             PL_debug = old_debug;
1324         }
1325     }
1326 #endif
1327
1328 #if defined(WIN32) || defined(NETWARE)
1329 #  if defined(PERL_IMPLICIT_SYS)
1330     {
1331 #    ifdef NETWARE
1332         void *host = nw_internal_host;
1333 #    else
1334         void *host = w32_internal_host;
1335 #    endif
1336         PerlMem_free(aTHXx);
1337 #    ifdef NETWARE
1338         nw_delete_internal_host(host);
1339 #    else
1340         win32_delete_internal_host(host);
1341 #    endif
1342     }
1343 #  else
1344     PerlMem_free(aTHXx);
1345 #  endif
1346 #else
1347     PerlMem_free(aTHXx);
1348 #endif
1349 }
1350
1351 #if defined(USE_ITHREADS)
1352 /* provide destructors to clean up the thread key when libperl is unloaded */
1353 #ifndef WIN32 /* handled during DLL_PROCESS_DETACH in win32/perllib.c */
1354
1355 #if defined(__hpux) && !(defined(__ux_version) && __ux_version <= 1020) && !defined(__GNUC__)
1356 #pragma fini "perl_fini"
1357 #elif defined(__sun) && !defined(__GNUC__)
1358 #pragma fini (perl_fini)
1359 #endif
1360
1361 static void
1362 #if defined(__GNUC__)
1363 __attribute__((destructor))
1364 #endif
1365 perl_fini(void)
1366 {
1367     dVAR;
1368     if (PL_curinterp  && !PL_veto_cleanup)
1369         FREE_THREAD_KEY;
1370 }
1371
1372 #endif /* WIN32 */
1373 #endif /* THREADS */
1374
1375 void
1376 Perl_call_atexit(pTHX_ ATEXIT_t fn, void *ptr)
1377 {
1378     dVAR;
1379     Renew(PL_exitlist, PL_exitlistlen+1, PerlExitListEntry);
1380     PL_exitlist[PL_exitlistlen].fn = fn;
1381     PL_exitlist[PL_exitlistlen].ptr = ptr;
1382     ++PL_exitlistlen;
1383 }
1384
1385 #ifdef HAS_PROCSELFEXE
1386 /* This is a function so that we don't hold on to MAXPATHLEN
1387    bytes of stack longer than necessary
1388  */
1389 STATIC void
1390 S_procself_val(pTHX_ SV *sv, const char *arg0)
1391 {
1392     char buf[MAXPATHLEN];
1393     int len = readlink(PROCSELFEXE_PATH, buf, sizeof(buf) - 1);
1394
1395     /* On Playstation2 Linux V1.0 (kernel 2.2.1) readlink(/proc/self/exe)
1396        includes a spurious NUL which will cause $^X to fail in system
1397        or backticks (this will prevent extensions from being built and
1398        many tests from working). readlink is not meant to add a NUL.
1399        Normal readlink works fine.
1400      */
1401     if (len > 0 && buf[len-1] == '\0') {
1402       len--;
1403     }
1404
1405     /* FreeBSD's implementation is acknowledged to be imperfect, sometimes
1406        returning the text "unknown" from the readlink rather than the path
1407        to the executable (or returning an error from the readlink).  Any valid
1408        path has a '/' in it somewhere, so use that to validate the result.
1409        See http://www.freebsd.org/cgi/query-pr.cgi?pr=35703
1410     */
1411     if (len > 0 && memchr(buf, '/', len)) {
1412         sv_setpvn(sv,buf,len);
1413     }
1414     else {
1415         sv_setpv(sv,arg0);
1416     }
1417 }
1418 #endif /* HAS_PROCSELFEXE */
1419
1420 STATIC void
1421 S_set_caret_X(pTHX) {
1422     dVAR;
1423     GV* tmpgv = gv_fetchpvs("\030", GV_ADD|GV_NOTQUAL, SVt_PV); /* $^X */
1424     if (tmpgv) {
1425 #ifdef HAS_PROCSELFEXE
1426         S_procself_val(aTHX_ GvSV(tmpgv), PL_origargv[0]);
1427 #else
1428 #ifdef OS2
1429         sv_setpv(GvSVn(tmpgv), os2_execname(aTHX));
1430 #else
1431         sv_setpv(GvSVn(tmpgv),PL_origargv[0]);
1432 #endif
1433 #endif
1434     }
1435 }
1436
1437 /*
1438 =for apidoc perl_parse
1439
1440 Tells a Perl interpreter to parse a Perl script.  See L<perlembed>.
1441
1442 =cut
1443 */
1444
1445 int
1446 perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env)
1447 {
1448     dVAR;
1449     I32 oldscope;
1450     int ret;
1451     dJMPENV;
1452
1453     PERL_ARGS_ASSERT_PERL_PARSE;
1454 #ifndef MULTIPLICITY
1455     PERL_UNUSED_ARG(my_perl);
1456 #endif
1457
1458 #if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT)
1459     /* [perl #22371] Algorimic Complexity Attack on Perl 5.6.1, 5.8.0
1460      * This MUST be done before any hash stores or fetches take place.
1461      * If you set PL_rehash_seed (and assumedly also PL_rehash_seed_set)
1462      * yourself, it is your responsibility to provide a good random seed!
1463      * You can also define PERL_HASH_SEED in compile time, see hv.h. */
1464     if (!PL_rehash_seed_set)
1465          PL_rehash_seed = get_hash_seed();
1466     {
1467         const char * const s = PerlEnv_getenv("PERL_HASH_SEED_DEBUG");
1468
1469         if (s && (atoi(s) == 1))
1470             PerlIO_printf(Perl_debug_log, "HASH_SEED = %"UVuf"\n", PL_rehash_seed);
1471     }
1472 #endif /* #if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT) */
1473
1474     PL_origargc = argc;
1475     PL_origargv = argv;
1476
1477     if (PL_origalen != 0) {
1478         PL_origalen = 1; /* don't use old PL_origalen if perl_parse() is called again */
1479     }
1480     else {
1481         /* Set PL_origalen be the sum of the contiguous argv[]
1482          * elements plus the size of the env in case that it is
1483          * contiguous with the argv[].  This is used in mg.c:Perl_magic_set()
1484          * as the maximum modifiable length of $0.  In the worst case
1485          * the area we are able to modify is limited to the size of
1486          * the original argv[0].  (See below for 'contiguous', though.)
1487          * --jhi */
1488          const char *s = NULL;
1489          int i;
1490          const UV mask =
1491            ~(UV)(PTRSIZE == 4 ? 3 : PTRSIZE == 8 ? 7 : PTRSIZE == 16 ? 15 : 0);
1492          /* Do the mask check only if the args seem like aligned. */
1493          const UV aligned =
1494            (mask < ~(UV)0) && ((PTR2UV(argv[0]) & mask) == PTR2UV(argv[0]));
1495
1496          /* See if all the arguments are contiguous in memory.  Note
1497           * that 'contiguous' is a loose term because some platforms
1498           * align the argv[] and the envp[].  If the arguments look
1499           * like non-aligned, assume that they are 'strictly' or
1500           * 'traditionally' contiguous.  If the arguments look like
1501           * aligned, we just check that they are within aligned
1502           * PTRSIZE bytes.  As long as no system has something bizarre
1503           * like the argv[] interleaved with some other data, we are
1504           * fine.  (Did I just evoke Murphy's Law?)  --jhi */
1505          if (PL_origargv && PL_origargc >= 1 && (s = PL_origargv[0])) {
1506               while (*s) s++;
1507               for (i = 1; i < PL_origargc; i++) {
1508                    if ((PL_origargv[i] == s + 1
1509 #ifdef OS2
1510                         || PL_origargv[i] == s + 2
1511 #endif
1512                             )
1513                        ||
1514                        (aligned &&
1515                         (PL_origargv[i] >  s &&
1516                          PL_origargv[i] <=
1517                          INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask)))
1518                         )
1519                    {
1520                         s = PL_origargv[i];
1521                         while (*s) s++;
1522                    }
1523                    else
1524                         break;
1525               }
1526          }
1527
1528 #ifndef PERL_USE_SAFE_PUTENV
1529          /* Can we grab env area too to be used as the area for $0? */
1530          if (s && PL_origenviron && !PL_use_safe_putenv) {
1531               if ((PL_origenviron[0] == s + 1)
1532                   ||
1533                   (aligned &&
1534                    (PL_origenviron[0] >  s &&
1535                     PL_origenviron[0] <=
1536                     INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask)))
1537                  )
1538               {
1539 #ifndef OS2             /* ENVIRON is read by the kernel too. */
1540                    s = PL_origenviron[0];
1541                    while (*s) s++;
1542 #endif
1543                    my_setenv("NoNe  SuCh", NULL);
1544                    /* Force copy of environment. */
1545                    for (i = 1; PL_origenviron[i]; i++) {
1546                         if (PL_origenviron[i] == s + 1
1547                             ||
1548                             (aligned &&
1549                              (PL_origenviron[i] >  s &&
1550                               PL_origenviron[i] <=
1551                               INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask)))
1552                            )
1553                         {
1554                              s = PL_origenviron[i];
1555                              while (*s) s++;
1556                         }
1557                         else
1558                              break;
1559                    }
1560               }
1561          }
1562 #endif /* !defined(PERL_USE_SAFE_PUTENV) */
1563
1564          PL_origalen = s ? s - PL_origargv[0] + 1 : 0;
1565     }
1566
1567     if (PL_do_undump) {
1568
1569         /* Come here if running an undumped a.out. */
1570
1571         PL_origfilename = savepv(argv[0]);
1572         PL_do_undump = FALSE;
1573         cxstack_ix = -1;                /* start label stack again */
1574         init_ids();
1575         assert (!PL_tainted);
1576         TAINT;
1577         S_set_caret_X(aTHX);
1578         TAINT_NOT;
1579         init_postdump_symbols(argc,argv,env);
1580         return 0;
1581     }
1582
1583     if (PL_main_root) {
1584         op_free(PL_main_root);
1585         PL_main_root = NULL;
1586     }
1587     PL_main_start = NULL;
1588     SvREFCNT_dec(PL_main_cv);
1589     PL_main_cv = NULL;
1590
1591     time(&PL_basetime);
1592     oldscope = PL_scopestack_ix;
1593     PL_dowarn = G_WARN_OFF;
1594
1595     JMPENV_PUSH(ret);
1596     switch (ret) {
1597     case 0:
1598         parse_body(env,xsinit);
1599         if (PL_unitcheckav)
1600             call_list(oldscope, PL_unitcheckav);
1601         if (PL_checkav)
1602             call_list(oldscope, PL_checkav);
1603         ret = 0;
1604         break;
1605     case 1:
1606         STATUS_ALL_FAILURE;
1607         /* FALL THROUGH */
1608     case 2:
1609         /* my_exit() was called */
1610         while (PL_scopestack_ix > oldscope)
1611             LEAVE;
1612         FREETMPS;
1613         PL_curstash = PL_defstash;
1614         if (PL_unitcheckav)
1615             call_list(oldscope, PL_unitcheckav);
1616         if (PL_checkav)
1617             call_list(oldscope, PL_checkav);
1618         ret = STATUS_EXIT;
1619         break;
1620     case 3:
1621         PerlIO_printf(Perl_error_log, "panic: top_env\n");
1622         ret = 1;
1623         break;
1624     }
1625     JMPENV_POP;
1626     return ret;
1627 }
1628
1629 #define INCPUSH_UNSHIFT                 0x01
1630 #define INCPUSH_ADD_OLD_VERS            0x02
1631 #define INCPUSH_ADD_VERSIONED_SUB_DIRS  0x04
1632 #define INCPUSH_ADD_ARCHONLY_SUB_DIRS   0x08
1633 #define INCPUSH_NOT_BASEDIR             0x10
1634 #define INCPUSH_CAN_RELOCATE            0x20
1635 #define INCPUSH_ADD_SUB_DIRS    \
1636     (INCPUSH_ADD_VERSIONED_SUB_DIRS|INCPUSH_ADD_ARCHONLY_SUB_DIRS)
1637
1638 STATIC void *
1639 S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
1640 {
1641     dVAR;
1642     PerlIO *rsfp;
1643     int argc = PL_origargc;
1644     char **argv = PL_origargv;
1645     const char *scriptname = NULL;
1646     VOL bool dosearch = FALSE;
1647     register char c;
1648     const char *cddir = NULL;
1649 #ifdef USE_SITECUSTOMIZE
1650     bool minus_f = FALSE;
1651 #endif
1652     SV *linestr_sv = newSV_type(SVt_PVIV);
1653     bool add_read_e_script = FALSE;
1654
1655     SvGROW(linestr_sv, 80);
1656     sv_setpvs(linestr_sv,"");
1657
1658     init_main_stash();
1659
1660     {
1661         const char *s;
1662     for (argc--,argv++; argc > 0; argc--,argv++) {
1663         if (argv[0][0] != '-' || !argv[0][1])
1664             break;
1665         s = argv[0]+1;
1666       reswitch:
1667         switch ((c = *s)) {
1668         case 'C':
1669 #ifndef PERL_STRICT_CR
1670         case '\r':
1671 #endif
1672         case ' ':
1673         case '0':
1674         case 'F':
1675         case 'a':
1676         case 'c':
1677         case 'd':
1678         case 'D':
1679         case 'h':
1680         case 'i':
1681         case 'l':
1682         case 'M':
1683         case 'm':
1684         case 'n':
1685         case 'p':
1686         case 's':
1687         case 'u':
1688         case 'U':
1689         case 'v':
1690         case 'W':
1691         case 'X':
1692         case 'w':
1693             if ((s = moreswitches(s)))
1694                 goto reswitch;
1695             break;
1696
1697         case 't':
1698             CHECK_MALLOC_TOO_LATE_FOR('t');
1699             if( !PL_tainting ) {
1700                  PL_taint_warn = TRUE;
1701                  PL_tainting = TRUE;
1702             }
1703             s++;
1704             goto reswitch;
1705         case 'T':
1706             CHECK_MALLOC_TOO_LATE_FOR('T');
1707             PL_tainting = TRUE;
1708             PL_taint_warn = FALSE;
1709             s++;
1710             goto reswitch;
1711
1712         case 'E':
1713             PL_minus_E = TRUE;
1714             /* FALL THROUGH */
1715         case 'e':
1716             forbid_setid('e', FALSE);
1717             if (!PL_e_script) {
1718                 PL_e_script = newSVpvs("");
1719                 add_read_e_script = TRUE;
1720             }
1721             if (*++s)
1722                 sv_catpv(PL_e_script, s);
1723             else if (argv[1]) {
1724                 sv_catpv(PL_e_script, argv[1]);
1725                 argc--,argv++;
1726             }
1727             else
1728                 Perl_croak(aTHX_ "No code specified for -%c", c);
1729             sv_catpvs(PL_e_script, "\n");
1730             break;
1731
1732         case 'f':
1733 #ifdef USE_SITECUSTOMIZE
1734             minus_f = TRUE;
1735 #endif
1736             s++;
1737             goto reswitch;
1738
1739         case 'I':       /* -I handled both here and in moreswitches() */
1740             forbid_setid('I', FALSE);
1741             if (!*++s && (s=argv[1]) != NULL) {
1742                 argc--,argv++;
1743             }
1744             if (s && *s) {
1745                 STRLEN len = strlen(s);
1746                 incpush(s, len, INCPUSH_ADD_SUB_DIRS|INCPUSH_ADD_OLD_VERS);
1747             }
1748             else
1749                 Perl_croak(aTHX_ "No directory specified for -I");
1750             break;
1751         case 'S':
1752             forbid_setid('S', FALSE);
1753             dosearch = TRUE;
1754             s++;
1755             goto reswitch;
1756         case 'V':
1757             {
1758                 SV *opts_prog;
1759
1760                 Perl_av_create_and_push(aTHX_ &PL_preambleav, newSVpvs("use Config;"));
1761                 if (*++s != ':')  {
1762                     /* Can't do newSVpvs() as that would involve pre-processor
1763                        condititionals inside a macro expansion.  */
1764                     opts_prog = Perl_newSVpv(aTHX_ "$_ = join ' ', sort qw("
1765 #  ifdef DEBUGGING
1766                              " DEBUGGING"
1767 #  endif
1768 #  ifdef NO_MATHOMS
1769                             " NO_MATHOMS"
1770 #  endif
1771 #  ifdef PERL_DISABLE_PMC
1772                              " PERL_DISABLE_PMC"
1773 #  endif
1774 #  ifdef PERL_DONT_CREATE_GVSV
1775                              " PERL_DONT_CREATE_GVSV"
1776 #  endif
1777 #  ifdef PERL_MALLOC_WRAP
1778                              " PERL_MALLOC_WRAP"
1779 #  endif
1780 #  ifdef PERL_MEM_LOG
1781                              " PERL_MEM_LOG"
1782 #  endif
1783 #  ifdef PERL_MEM_LOG_NOIMPL
1784                              " PERL_MEM_LOG_NOIMPL"
1785 #  endif
1786 #  ifdef PERL_USE_DEVEL
1787                              " PERL_USE_DEVEL"
1788 #  endif
1789 #  ifdef PERL_USE_SAFE_PUTENV
1790                              " PERL_USE_SAFE_PUTENV"
1791 #  endif
1792 #  ifdef USE_SITECUSTOMIZE
1793                              " USE_SITECUSTOMIZE"
1794 #  endif
1795 #  ifdef USE_FAST_STDIO
1796                              " USE_FAST_STDIO"
1797 #  endif
1798                                              , 0);
1799
1800                     sv_catpv(opts_prog, PL_bincompat_options);
1801                     /* Terminate the qw(, and then wrap at 76 columns.  */
1802                     sv_catpvs(opts_prog, "); s/(?=.{53})(.{1,53}) /$1\\n                        /mg;print Config::myconfig(),");
1803 #ifdef VMS
1804                     sv_catpvs(opts_prog,"\"\\nCharacteristics of this PERLSHR image: \\n");
1805 #else
1806                     sv_catpvs(opts_prog,"\"\\nCharacteristics of this binary (from libperl): \\n");
1807 #endif
1808                     sv_catpvs(opts_prog,"  Compile-time options: $_\\n\",");
1809
1810 #if defined(LOCAL_PATCH_COUNT)
1811                     if (LOCAL_PATCH_COUNT > 0) {
1812                         int i;
1813                         sv_catpvs(opts_prog,
1814                                  "\"  Locally applied patches:\\n\",");
1815                         for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
1816                             if (PL_localpatches[i])
1817                                 Perl_sv_catpvf(aTHX_ opts_prog,"q%c\t%s\n%c,",
1818                                     0, PL_localpatches[i], 0);
1819                         }
1820                     }
1821 #endif
1822                     Perl_sv_catpvf(aTHX_ opts_prog,
1823                                    "\"  Built under %s\\n",OSNAME);
1824 #ifdef __DATE__
1825 #  ifdef __TIME__
1826                     sv_catpvs(opts_prog,
1827                               "  Compiled at " __DATE__ " " __TIME__ "\\n\"");
1828 #  else
1829                     sv_catpvs(opts_prog, "  Compiled on " __DATE__ "\\n\"");
1830 #  endif
1831 #endif
1832                     sv_catpvs(opts_prog, "; $\"=\"\\n    \"; "
1833                              "@env = map { \"$_=\\\"$ENV{$_}\\\"\" } "
1834                              "sort grep {/^PERL/} keys %ENV; ");
1835 #ifdef __CYGWIN__
1836                     sv_catpvs(opts_prog,
1837                              "push @env, \"CYGWIN=\\\"$ENV{CYGWIN}\\\"\";");
1838 #endif
1839                     sv_catpvs(opts_prog,
1840                              "print \"  \\%ENV:\\n    @env\\n\" if @env;"
1841                              "print \"  \\@INC:\\n    @INC\\n\";");
1842                 }
1843                 else {
1844                     ++s;
1845                     opts_prog = Perl_newSVpvf(aTHX_
1846                                               "Config::config_vars(qw%c%s%c)",
1847                                               0, s, 0);
1848                     s += strlen(s);
1849                 }
1850                 av_push(PL_preambleav, opts_prog);
1851                 /* don't look for script or read stdin */
1852                 scriptname = BIT_BUCKET;
1853                 goto reswitch;
1854             }
1855         case 'x':
1856             PL_doextract = TRUE;
1857             s++;
1858             if (*s)
1859                 cddir = s;
1860             break;
1861         case 0:
1862             break;
1863         case '-':
1864             if (!*++s || isSPACE(*s)) {
1865                 argc--,argv++;
1866                 goto switch_end;
1867             }
1868             /* catch use of gnu style long options */
1869             if (strEQ(s, "version")) {
1870                 s = (char *)"v";
1871                 goto reswitch;
1872             }
1873             if (strEQ(s, "help")) {
1874                 s = (char *)"h";
1875                 goto reswitch;
1876             }
1877             s--;
1878             /* FALL THROUGH */
1879         default:
1880             Perl_croak(aTHX_ "Unrecognized switch: -%s  (-h will show valid options)",s);
1881         }
1882     }
1883     }
1884
1885   switch_end:
1886
1887     {
1888         char *s;
1889
1890     if (
1891 #ifndef SECURE_INTERNAL_GETENV
1892         !PL_tainting &&
1893 #endif
1894         (s = PerlEnv_getenv("PERL5OPT")))
1895     {
1896         while (isSPACE(*s))
1897             s++;
1898         if (*s == '-' && *(s+1) == 'T') {
1899             CHECK_MALLOC_TOO_LATE_FOR('T');
1900             PL_tainting = TRUE;
1901             PL_taint_warn = FALSE;
1902         }
1903         else {
1904             char *popt_copy = NULL;
1905             while (s && *s) {
1906                 const char *d;
1907                 while (isSPACE(*s))
1908                     s++;
1909                 if (*s == '-') {
1910                     s++;
1911                     if (isSPACE(*s))
1912                         continue;
1913                 }
1914                 d = s;
1915                 if (!*s)
1916                     break;
1917                 if (!strchr("CDIMUdmtwW", *s))
1918                     Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s);
1919                 while (++s && *s) {
1920                     if (isSPACE(*s)) {
1921                         if (!popt_copy) {
1922                             popt_copy = SvPVX(sv_2mortal(newSVpv(d,0)));
1923                             s = popt_copy + (s - d);
1924                             d = popt_copy;
1925                         }
1926                         *s++ = '\0';
1927                         break;
1928                     }
1929                 }
1930                 if (*d == 't') {
1931                     if( !PL_tainting ) {
1932                         PL_taint_warn = TRUE;
1933                         PL_tainting = TRUE;
1934                     }
1935                 } else {
1936                     moreswitches(d);
1937                 }
1938             }
1939         }
1940     }
1941     }
1942
1943 #ifdef USE_SITECUSTOMIZE
1944     if (!minus_f) {
1945         (void)Perl_av_create_and_unshift_one(aTHX_ &PL_preambleav,
1946                                              Perl_newSVpvf(aTHX_ "BEGIN { do '%s/sitecustomize.pl' }", SITELIB_EXP));
1947     }
1948 #endif
1949
1950     if (!scriptname)
1951         scriptname = argv[0];
1952     if (PL_e_script) {
1953         argc++,argv--;
1954         scriptname = BIT_BUCKET;        /* don't look for script or read stdin */
1955     }
1956     else if (scriptname == NULL) {
1957 #ifdef MSDOS
1958         if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) )
1959             moreswitches("h");
1960 #endif
1961         scriptname = "-";
1962     }
1963
1964     /* Set $^X early so that it can be used for relocatable paths in @INC  */
1965     assert (!PL_tainted);
1966     TAINT;
1967     S_set_caret_X(aTHX);
1968     TAINT_NOT;
1969     init_perllib();
1970
1971     {
1972         bool suidscript = FALSE;
1973
1974         open_script(scriptname, dosearch, &suidscript, &rsfp);
1975
1976         validate_suid(validarg, scriptname, fdscript, suidscript,
1977                       linestr_sv, rsfp);
1978
1979 #ifndef PERL_MICRO
1980 #  if defined(SIGCHLD) || defined(SIGCLD)
1981         {
1982 #  ifndef SIGCHLD
1983 #    define SIGCHLD SIGCLD
1984 #  endif
1985             Sighandler_t sigstate = rsignal_state(SIGCHLD);
1986             if (sigstate == (Sighandler_t) SIG_IGN) {
1987                 if (ckWARN(WARN_SIGNAL))
1988                     Perl_warner(aTHX_ packWARN(WARN_SIGNAL),
1989                                 "Can't ignore signal CHLD, forcing to default");
1990                 (void)rsignal(SIGCHLD, (Sighandler_t)SIG_DFL);
1991             }
1992         }
1993 #  endif
1994 #endif
1995
1996         if (PL_doextract) {
1997
1998             /* This will croak if suidscript is true, as -x cannot be used with
1999                setuid scripts.  */
2000             forbid_setid('x', suidscript);
2001             /* Hence you can't get here if suidscript is true */
2002
2003             find_beginning(linestr_sv, rsfp);
2004             if (cddir && PerlDir_chdir( (char *)cddir ) < 0)
2005                 Perl_croak(aTHX_ "Can't chdir to %s",cddir);
2006         }
2007     }
2008
2009     PL_main_cv = PL_compcv = MUTABLE_CV(newSV_type(SVt_PVCV));
2010     CvUNIQUE_on(PL_compcv);
2011
2012     CvPADLIST(PL_compcv) = pad_new(0);
2013
2014     PL_isarev = newHV();
2015
2016     boot_core_PerlIO();
2017     boot_core_UNIVERSAL();
2018     boot_core_mro();
2019
2020     if (xsinit)
2021         (*xsinit)(aTHX);        /* in case linked C routines want magical variables */
2022 #ifndef PERL_MICRO
2023 #if defined(VMS) || defined(WIN32) || defined(DJGPP) || defined(__CYGWIN__) || defined(EPOC) || defined(SYMBIAN)
2024     init_os_extras();
2025 #endif
2026 #endif
2027
2028 #ifdef USE_SOCKS
2029 #   ifdef HAS_SOCKS5_INIT
2030     socks5_init(argv[0]);
2031 #   else
2032     SOCKSinit(argv[0]);
2033 #   endif
2034 #endif
2035
2036     init_predump_symbols();
2037     /* init_postdump_symbols not currently designed to be called */
2038     /* more than once (ENV isn't cleared first, for example)     */
2039     /* But running with -u leaves %ENV & @ARGV undefined!    XXX */
2040     if (!PL_do_undump)
2041         init_postdump_symbols(argc,argv,env);
2042
2043     /* PL_unicode is turned on by -C, or by $ENV{PERL_UNICODE},
2044      * or explicitly in some platforms.
2045      * locale.c:Perl_init_i18nl10n() if the environment
2046      * look like the user wants to use UTF-8. */
2047 #if defined(__SYMBIAN32__)
2048     PL_unicode = PERL_UNICODE_STD_FLAG; /* See PERL_SYMBIAN_CONSOLE_UTF8. */
2049 #endif
2050     if (PL_unicode) {
2051          /* Requires init_predump_symbols(). */
2052          if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) {
2053               IO* io;
2054               PerlIO* fp;
2055               SV* sv;
2056
2057               /* Turn on UTF-8-ness on STDIN, STDOUT, STDERR
2058                * and the default open disciplines. */
2059               if ((PL_unicode & PERL_UNICODE_STDIN_FLAG) &&
2060                   PL_stdingv  && (io = GvIO(PL_stdingv)) &&
2061                   (fp = IoIFP(io)))
2062                    PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
2063               if ((PL_unicode & PERL_UNICODE_STDOUT_FLAG) &&
2064                   PL_defoutgv && (io = GvIO(PL_defoutgv)) &&
2065                   (fp = IoOFP(io)))
2066                    PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
2067               if ((PL_unicode & PERL_UNICODE_STDERR_FLAG) &&
2068                   PL_stderrgv && (io = GvIO(PL_stderrgv)) &&
2069                   (fp = IoOFP(io)))
2070                    PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
2071               if ((PL_unicode & PERL_UNICODE_INOUT_FLAG) &&
2072                   (sv = GvSV(gv_fetchpvs("\017PEN", GV_ADD|GV_NOTQUAL,
2073                                          SVt_PV)))) {
2074                    U32 in  = PL_unicode & PERL_UNICODE_IN_FLAG;
2075                    U32 out = PL_unicode & PERL_UNICODE_OUT_FLAG;
2076                    if (in) {
2077                         if (out)
2078                              sv_setpvs(sv, ":utf8\0:utf8");
2079                         else
2080                              sv_setpvs(sv, ":utf8\0");
2081                    }
2082                    else if (out)
2083                         sv_setpvs(sv, "\0:utf8");
2084                    SvSETMAGIC(sv);
2085               }
2086          }
2087     }
2088
2089     {
2090         const char *s;
2091     if ((s = PerlEnv_getenv("PERL_SIGNALS"))) {
2092          if (strEQ(s, "unsafe"))
2093               PL_signals |=  PERL_SIGNALS_UNSAFE_FLAG;
2094          else if (strEQ(s, "safe"))
2095               PL_signals &= ~PERL_SIGNALS_UNSAFE_FLAG;
2096          else
2097               Perl_croak(aTHX_ "PERL_SIGNALS illegal: \"%s\"", s);
2098     }
2099     }
2100
2101 #ifdef PERL_MAD
2102     {
2103         const char *s;
2104     if ((s = PerlEnv_getenv("PERL_XMLDUMP"))) {
2105         PL_madskills = 1;
2106         PL_minus_c = 1;
2107         if (!s || !s[0])
2108             PL_xmlfp = PerlIO_stdout();
2109         else {
2110             PL_xmlfp = PerlIO_open(s, "w");
2111             if (!PL_xmlfp)
2112                 Perl_croak(aTHX_ "Can't open %s", s);
2113         }
2114         my_setenv("PERL_XMLDUMP", NULL);        /* hide from subprocs */
2115     }
2116     }
2117
2118     {
2119         const char *s;
2120     if ((s = PerlEnv_getenv("PERL_MADSKILLS"))) {
2121         PL_madskills = atoi(s);
2122         my_setenv("PERL_MADSKILLS", NULL);      /* hide from subprocs */
2123     }
2124     }
2125 #endif
2126
2127     lex_start(linestr_sv, rsfp, TRUE);
2128     PL_subname = newSVpvs("main");
2129
2130     if (add_read_e_script)
2131         filter_add(read_e_script, NULL);
2132
2133     /* now parse the script */
2134
2135     SETERRNO(0,SS_NORMAL);
2136     if (yyparse() || PL_parser->error_count) {
2137         if (PL_minus_c)
2138             Perl_croak(aTHX_ "%s had compilation errors.\n", PL_origfilename);
2139         else {
2140             Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
2141                        PL_origfilename);
2142         }
2143     }
2144     CopLINE_set(PL_curcop, 0);
2145     PL_curstash = PL_defstash;
2146     if (PL_e_script) {
2147         SvREFCNT_dec(PL_e_script);
2148         PL_e_script = NULL;
2149     }
2150
2151     if (PL_do_undump)
2152         my_unexec();
2153
2154     if (isWARN_ONCE) {
2155         SAVECOPFILE(PL_curcop);
2156         SAVECOPLINE(PL_curcop);
2157         gv_check(PL_defstash);
2158     }
2159
2160     LEAVE;
2161     FREETMPS;
2162
2163 #ifdef MYMALLOC
2164     {
2165         const char *s;
2166     if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
2167         dump_mstats("after compilation:");
2168     }
2169 #endif
2170
2171     ENTER;
2172     PL_restartop = 0;
2173     return NULL;
2174 }
2175
2176 /*
2177 =for apidoc perl_run
2178
2179 Tells a Perl interpreter to run.  See L<perlembed>.
2180
2181 =cut
2182 */
2183
2184 int
2185 perl_run(pTHXx)
2186 {
2187     dVAR;
2188     I32 oldscope;
2189     int ret = 0;
2190     dJMPENV;
2191
2192     PERL_ARGS_ASSERT_PERL_RUN;
2193 #ifndef MULTIPLICITY
2194     PERL_UNUSED_ARG(my_perl);
2195 #endif
2196
2197     oldscope = PL_scopestack_ix;
2198 #ifdef VMS
2199     VMSISH_HUSHED = 0;
2200 #endif
2201
2202     JMPENV_PUSH(ret);
2203     switch (ret) {
2204     case 1:
2205         cxstack_ix = -1;                /* start context stack again */
2206         goto redo_body;
2207     case 0:                             /* normal completion */
2208  redo_body:
2209         run_body(oldscope);
2210         /* FALL THROUGH */
2211     case 2:                             /* my_exit() */
2212         while (PL_scopestack_ix > oldscope)
2213             LEAVE;
2214         FREETMPS;
2215         PL_curstash = PL_defstash;
2216         if (!(PL_exit_flags & PERL_EXIT_DESTRUCT_END) &&
2217             PL_endav && !PL_minus_c)
2218             call_list(oldscope, PL_endav);
2219 #ifdef MYMALLOC
2220         if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
2221             dump_mstats("after execution:  ");
2222 #endif
2223         ret = STATUS_EXIT;
2224         break;
2225     case 3:
2226         if (PL_restartop) {
2227             POPSTACK_TO(PL_mainstack);
2228             goto redo_body;
2229         }
2230         PerlIO_printf(Perl_error_log, "panic: restartop\n");
2231         FREETMPS;
2232         ret = 1;
2233         break;
2234     }
2235
2236     JMPENV_POP;
2237     return ret;
2238 }
2239
2240 STATIC void
2241 S_run_body(pTHX_ I32 oldscope)
2242 {
2243     dVAR;
2244     DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
2245                     PL_sawampersand ? "Enabling" : "Omitting"));
2246
2247     if (!PL_restartop) {
2248 #ifdef PERL_MAD
2249         if (PL_xmlfp) {
2250             xmldump_all();
2251             exit(0);    /* less likely to core dump than my_exit(0) */
2252         }
2253 #endif
2254 #ifdef DEBUGGING
2255         if (DEBUG_x_TEST || DEBUG_B_TEST)
2256             dump_all_perl(!DEBUG_B_TEST);
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     STRLEN len;
2487     PERL_ARGS_ASSERT_CALL_METHOD;
2488
2489     len = strlen(methname);
2490
2491     /* XXX: sv_2mortal(newSVpvn_share(methname, len)) can be faster */
2492     return call_sv(newSVpvn_flags(methname, len, SVs_TEMP), flags | G_METHOD);
2493 }
2494
2495 /* May be called with any of a CV, a GV, or an SV containing the name. */
2496 /*
2497 =for apidoc p||call_sv
2498
2499 Performs a callback to the Perl sub whose name is in the SV.  See
2500 L<perlcall>.
2501
2502 =cut
2503 */
2504
2505 I32
2506 Perl_call_sv(pTHX_ SV *sv, VOL I32 flags)
2507                         /* See G_* flags in cop.h */
2508 {
2509     dVAR; dSP;
2510     LOGOP myop;         /* fake syntax tree node */
2511     UNOP method_op;
2512     I32 oldmark;
2513     VOL I32 retval = 0;
2514     I32 oldscope;
2515     bool oldcatch = CATCH_GET;
2516     int ret;
2517     OP* const oldop = PL_op;
2518     dJMPENV;
2519
2520     PERL_ARGS_ASSERT_CALL_SV;
2521
2522     if (flags & G_DISCARD) {
2523         ENTER;
2524         SAVETMPS;
2525     }
2526     if (!(flags & G_WANT)) {
2527         /* Backwards compatibility - as G_SCALAR was 0, it could be omitted.
2528          */
2529         flags |= G_SCALAR;
2530     }
2531
2532     Zero(&myop, 1, LOGOP);
2533     myop.op_next = NULL;
2534     if (!(flags & G_NOARGS))
2535         myop.op_flags |= OPf_STACKED;
2536     myop.op_flags |= OP_GIMME_REVERSE(flags);
2537     SAVEOP();
2538     PL_op = (OP*)&myop;
2539
2540     EXTEND(PL_stack_sp, 1);
2541     *++PL_stack_sp = sv;
2542     oldmark = TOPMARK;
2543     oldscope = PL_scopestack_ix;
2544
2545     if (PERLDB_SUB && PL_curstash != PL_debstash
2546            /* Handle first BEGIN of -d. */
2547           && (PL_DBcv || (PL_DBcv = GvCV(PL_DBsub)))
2548            /* Try harder, since this may have been a sighandler, thus
2549             * curstash may be meaningless. */
2550           && (SvTYPE(sv) != SVt_PVCV || CvSTASH((const CV *)sv) != PL_debstash)
2551           && !(flags & G_NODEBUG))
2552         PL_op->op_private |= OPpENTERSUB_DB;
2553
2554     if (flags & G_METHOD) {
2555         Zero(&method_op, 1, UNOP);
2556         method_op.op_next = PL_op;
2557         method_op.op_ppaddr = PL_ppaddr[OP_METHOD];
2558         method_op.op_type = OP_METHOD;
2559         myop.op_ppaddr = PL_ppaddr[OP_ENTERSUB];
2560         myop.op_type = OP_ENTERSUB;
2561         PL_op = (OP*)&method_op;
2562     }
2563
2564     if (!(flags & G_EVAL)) {
2565         CATCH_SET(TRUE);
2566         CALL_BODY_SUB((OP*)&myop);
2567         retval = PL_stack_sp - (PL_stack_base + oldmark);
2568         CATCH_SET(oldcatch);
2569     }
2570     else {
2571         myop.op_other = (OP*)&myop;
2572         PL_markstack_ptr--;
2573         create_eval_scope(flags|G_FAKINGEVAL);
2574         PL_markstack_ptr++;
2575
2576         JMPENV_PUSH(ret);
2577
2578         switch (ret) {
2579         case 0:
2580  redo_body:
2581             CALL_BODY_SUB((OP*)&myop);
2582             retval = PL_stack_sp - (PL_stack_base + oldmark);
2583             if (!(flags & G_KEEPERR)) {
2584                 CLEAR_ERRSV();
2585             }
2586             break;
2587         case 1:
2588             STATUS_ALL_FAILURE;
2589             /* FALL THROUGH */
2590         case 2:
2591             /* my_exit() was called */
2592             PL_curstash = PL_defstash;
2593             FREETMPS;
2594             JMPENV_POP;
2595             if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
2596                 Perl_croak(aTHX_ "Callback called exit");
2597             my_exit_jump();
2598             /* NOTREACHED */
2599         case 3:
2600             if (PL_restartop) {
2601                 PL_op = PL_restartop;
2602                 PL_restartop = 0;
2603                 goto redo_body;
2604             }
2605             PL_stack_sp = PL_stack_base + oldmark;
2606             if ((flags & G_WANT) == G_ARRAY)
2607                 retval = 0;
2608             else {
2609                 retval = 1;
2610                 *++PL_stack_sp = &PL_sv_undef;
2611             }
2612             break;
2613         }
2614
2615         if (PL_scopestack_ix > oldscope)
2616             delete_eval_scope();
2617         JMPENV_POP;
2618     }
2619
2620     if (flags & G_DISCARD) {
2621         PL_stack_sp = PL_stack_base + oldmark;
2622         retval = 0;
2623         FREETMPS;
2624         LEAVE;
2625     }
2626     PL_op = oldop;
2627     return retval;
2628 }
2629
2630 /* Eval a string. The G_EVAL flag is always assumed. */
2631
2632 /*
2633 =for apidoc p||eval_sv
2634
2635 Tells Perl to C<eval> the string in the SV.
2636
2637 =cut
2638 */
2639
2640 I32
2641 Perl_eval_sv(pTHX_ SV *sv, I32 flags)
2642
2643                         /* See G_* flags in cop.h */
2644 {
2645     dVAR;
2646     dSP;
2647     UNOP myop;          /* fake syntax tree node */
2648     VOL I32 oldmark = SP - PL_stack_base;
2649     VOL I32 retval = 0;
2650     int ret;
2651     OP* const oldop = PL_op;
2652     dJMPENV;
2653
2654     PERL_ARGS_ASSERT_EVAL_SV;
2655
2656     if (flags & G_DISCARD) {
2657         ENTER;
2658         SAVETMPS;
2659     }
2660
2661     SAVEOP();
2662     PL_op = (OP*)&myop;
2663     Zero(PL_op, 1, UNOP);
2664     EXTEND(PL_stack_sp, 1);
2665     *++PL_stack_sp = sv;
2666
2667     if (!(flags & G_NOARGS))
2668         myop.op_flags = OPf_STACKED;
2669     myop.op_next = NULL;
2670     myop.op_type = OP_ENTEREVAL;
2671     myop.op_flags |= OP_GIMME_REVERSE(flags);
2672     if (flags & G_KEEPERR)
2673         myop.op_flags |= OPf_SPECIAL;
2674
2675     /* fail now; otherwise we could fail after the JMPENV_PUSH but
2676      * before a PUSHEVAL, which corrupts the stack after a croak */
2677     TAINT_PROPER("eval_sv()");
2678
2679     JMPENV_PUSH(ret);
2680     switch (ret) {
2681     case 0:
2682  redo_body:
2683         CALL_BODY_EVAL((OP*)&myop);
2684         retval = PL_stack_sp - (PL_stack_base + oldmark);
2685         if (!(flags & G_KEEPERR)) {
2686             CLEAR_ERRSV();
2687         }
2688         break;
2689     case 1:
2690         STATUS_ALL_FAILURE;
2691         /* FALL THROUGH */
2692     case 2:
2693         /* my_exit() was called */
2694         PL_curstash = PL_defstash;
2695         FREETMPS;
2696         JMPENV_POP;
2697         if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
2698             Perl_croak(aTHX_ "Callback called exit");
2699         my_exit_jump();
2700         /* NOTREACHED */
2701     case 3:
2702         if (PL_restartop) {
2703             PL_op = PL_restartop;
2704             PL_restartop = 0;
2705             goto redo_body;
2706         }
2707         PL_stack_sp = PL_stack_base + oldmark;
2708         if ((flags & G_WANT) == G_ARRAY)
2709             retval = 0;
2710         else {
2711             retval = 1;
2712             *++PL_stack_sp = &PL_sv_undef;
2713         }
2714         break;
2715     }
2716
2717     JMPENV_POP;
2718     if (flags & G_DISCARD) {
2719         PL_stack_sp = PL_stack_base + oldmark;
2720         retval = 0;
2721         FREETMPS;
2722         LEAVE;
2723     }
2724     PL_op = oldop;
2725     return retval;
2726 }
2727
2728 /*
2729 =for apidoc p||eval_pv
2730
2731 Tells Perl to C<eval> the given string and return an SV* result.
2732
2733 =cut
2734 */
2735
2736 SV*
2737 Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error)
2738 {
2739     dVAR;
2740     dSP;
2741     SV* sv = newSVpv(p, 0);
2742
2743     PERL_ARGS_ASSERT_EVAL_PV;
2744
2745     eval_sv(sv, G_SCALAR);
2746     SvREFCNT_dec(sv);
2747
2748     SPAGAIN;
2749     sv = POPs;
2750     PUTBACK;
2751
2752     if (croak_on_error && SvTRUE(ERRSV)) {
2753         Perl_croak(aTHX_ "%s", SvPVx_nolen_const(ERRSV));
2754     }
2755
2756     return sv;
2757 }
2758
2759 /* Require a module. */
2760
2761 /*
2762 =head1 Embedding Functions
2763
2764 =for apidoc p||require_pv
2765
2766 Tells Perl to C<require> the file named by the string argument.  It is
2767 analogous to the Perl code C<eval "require '$file'">.  It's even
2768 implemented that way; consider using load_module instead.
2769
2770 =cut */
2771
2772 void
2773 Perl_require_pv(pTHX_ const char *pv)
2774 {
2775     dVAR;
2776     dSP;
2777     SV* sv;
2778
2779     PERL_ARGS_ASSERT_REQUIRE_PV;
2780
2781     PUSHSTACKi(PERLSI_REQUIRE);
2782     PUTBACK;
2783     sv = Perl_newSVpvf(aTHX_ "require q%c%s%c", 0, pv, 0);
2784     eval_sv(sv_2mortal(sv), G_DISCARD);
2785     SPAGAIN;
2786     POPSTACK;
2787 }
2788
2789 STATIC void
2790 S_usage(pTHX_ const char *name)         /* XXX move this out into a module ? */
2791 {
2792     /* This message really ought to be max 23 lines.
2793      * Removed -h because the user already knows that option. Others? */
2794
2795     static const char * const usage_msg[] = {
2796 "-0[octal]         specify record separator (\\0, if no argument)",
2797 "-a                autosplit mode with -n or -p (splits $_ into @F)",
2798 "-C[number/list]   enables the listed Unicode features",
2799 "-c                check syntax only (runs BEGIN and CHECK blocks)",
2800 "-d[:debugger]     run program under debugger",
2801 "-D[number/list]   set debugging flags (argument is a bit mask or alphabets)",
2802 "-e program        one line of program (several -e's allowed, omit programfile)",
2803 "-E program        like -e, but enables all optional features",
2804 "-f                don't do $sitelib/sitecustomize.pl at startup",
2805 "-F/pattern/       split() pattern for -a switch (//'s are optional)",
2806 "-i[extension]     edit <> files in place (makes backup if extension supplied)",
2807 "-Idirectory       specify @INC/#include directory (several -I's allowed)",
2808 "-l[octal]         enable line ending processing, specifies line terminator",
2809 "-[mM][-]module    execute \"use/no module...\" before executing program",
2810 "-n                assume \"while (<>) { ... }\" loop around program",
2811 "-p                assume loop like -n but print line also, like sed",
2812 "-s                enable rudimentary parsing for switches after programfile",
2813 "-S                look for programfile using PATH environment variable",
2814 "-t                enable tainting warnings",
2815 "-T                enable tainting checks",
2816 "-u                dump core after parsing program",
2817 "-U                allow unsafe operations",
2818 "-v                print version, subversion (includes VERY IMPORTANT perl info)",
2819 "-V[:variable]     print configuration summary (or a single Config.pm variable)",
2820 "-w                enable many useful warnings (RECOMMENDED)",
2821 "-W                enable all warnings",
2822 "-x[directory]     strip off text before #!perl line and perhaps cd to directory",
2823 "-X                disable all warnings",
2824 "\n",
2825 NULL
2826 };
2827     const char * const *p = usage_msg;
2828
2829     PERL_ARGS_ASSERT_USAGE;
2830
2831     PerlIO_printf(PerlIO_stdout(),
2832                   "\nUsage: %s [switches] [--] [programfile] [arguments]",
2833                   name);
2834     while (*p)
2835         PerlIO_printf(PerlIO_stdout(), "\n  %s", *p++);
2836 }
2837
2838 /* convert a string of -D options (or digits) into an int.
2839  * sets *s to point to the char after the options */
2840
2841 #ifdef DEBUGGING
2842 int
2843 Perl_get_debug_opts(pTHX_ const char **s, bool givehelp)
2844 {
2845     static const char * const usage_msgd[] = {
2846       " Debugging flag values: (see also -d)",
2847       "  p  Tokenizing and parsing (with v, displays parse stack)",
2848       "  s  Stack snapshots (with v, displays all stacks)",
2849       "  l  Context (loop) stack processing",
2850       "  t  Trace execution",
2851       "  o  Method and overloading resolution",
2852       "  c  String/numeric conversions",
2853       "  P  Print profiling info, source file input state",
2854       "  m  Memory and SV allocation",
2855       "  f  Format processing",
2856       "  r  Regular expression parsing and execution",
2857       "  x  Syntax tree dump",
2858       "  u  Tainting checks",
2859       "  H  Hash dump -- usurps values()",
2860       "  X  Scratchpad allocation",
2861       "  D  Cleaning up",
2862       "  T  Tokenising",
2863       "  R  Include reference counts of dumped variables (eg when using -Ds)",
2864       "  J  Do not s,t,P-debug (Jump over) opcodes within package DB",
2865       "  v  Verbose: use in conjunction with other flags",
2866       "  C  Copy On Write",
2867       "  A  Consistency checks on internal structures",
2868       "  q  quiet - currently only suppresses the 'EXECUTING' message",
2869       "  M  trace smart match resolution",
2870       "  B  dump suBroutine definitions, including special Blocks like BEGIN",
2871       NULL
2872     };
2873     int i = 0;
2874
2875     PERL_ARGS_ASSERT_GET_DEBUG_OPTS;
2876
2877     if (isALPHA(**s)) {
2878         /* if adding extra options, remember to update DEBUG_MASK */
2879         static const char debopts[] = "psltocPmfrxuUHXDSTRJvCAqMB";
2880
2881         for (; isALNUM(**s); (*s)++) {
2882             const char * const d = strchr(debopts,**s);
2883             if (d)
2884                 i |= 1 << (d - debopts);
2885             else if (ckWARN_d(WARN_DEBUGGING))
2886                 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
2887                     "invalid option -D%c, use -D'' to see choices\n", **s);
2888         }
2889     }
2890     else if (isDIGIT(**s)) {
2891         i = atoi(*s);
2892         for (; isALNUM(**s); (*s)++) ;
2893     }
2894     else if (givehelp) {
2895       const char *const *p = usage_msgd;
2896       while (*p) PerlIO_printf(PerlIO_stdout(), "%s\n", *p++);
2897     }
2898 #  ifdef EBCDIC
2899     if ((i & DEBUG_p_FLAG) && ckWARN_d(WARN_DEBUGGING))
2900         Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
2901                 "-Dp not implemented on this platform\n");
2902 #  endif
2903     return i;
2904 }
2905 #endif
2906
2907 /* This routine handles any switches that can be given during run */
2908
2909 const char *
2910 Perl_moreswitches(pTHX_ const char *s)
2911 {
2912     dVAR;
2913     UV rschar;
2914     const char option = *s; /* used to remember option in -m/-M code */
2915
2916     PERL_ARGS_ASSERT_MORESWITCHES;
2917
2918     switch (*s) {
2919     case '0':
2920     {
2921          I32 flags = 0;
2922          STRLEN numlen;
2923
2924          SvREFCNT_dec(PL_rs);
2925          if (s[1] == 'x' && s[2]) {
2926               const char *e = s+=2;
2927               U8 *tmps;
2928
2929               while (*e)
2930                 e++;
2931               numlen = e - s;
2932               flags = PERL_SCAN_SILENT_ILLDIGIT;
2933               rschar = (U32)grok_hex(s, &numlen, &flags, NULL);
2934               if (s + numlen < e) {
2935                    rschar = 0; /* Grandfather -0xFOO as -0 -xFOO. */
2936                    numlen = 0;
2937                    s--;
2938               }
2939               PL_rs = newSVpvs("");
2940               SvGROW(PL_rs, (STRLEN)(UNISKIP(rschar) + 1));
2941               tmps = (U8*)SvPVX(PL_rs);
2942               uvchr_to_utf8(tmps, rschar);
2943               SvCUR_set(PL_rs, UNISKIP(rschar));
2944               SvUTF8_on(PL_rs);
2945          }
2946          else {
2947               numlen = 4;
2948               rschar = (U32)grok_oct(s, &numlen, &flags, NULL);
2949               if (rschar & ~((U8)~0))
2950                    PL_rs = &PL_sv_undef;
2951               else if (!rschar && numlen >= 2)
2952                    PL_rs = newSVpvs("");
2953               else {
2954                    char ch = (char)rschar;
2955                    PL_rs = newSVpvn(&ch, 1);
2956               }
2957          }
2958          sv_setsv(get_sv("/", GV_ADD), PL_rs);
2959          return s + numlen;
2960     }
2961     case 'C':
2962         s++;
2963         PL_unicode = parse_unicode_opts( (const char **)&s );
2964         if (PL_unicode & PERL_UNICODE_UTF8CACHEASSERT_FLAG)
2965             PL_utf8cache = -1;
2966         return s;
2967     case 'F':
2968         PL_minus_F = TRUE;
2969         PL_splitstr = ++s;
2970         while (*s && !isSPACE(*s)) ++s;
2971         PL_splitstr = savepvn(PL_splitstr, s - PL_splitstr);
2972         return s;
2973     case 'a':
2974         PL_minus_a = TRUE;
2975         s++;
2976         return s;
2977     case 'c':
2978         PL_minus_c = TRUE;
2979         s++;
2980         return s;
2981     case 'd':
2982         forbid_setid('d', FALSE);
2983         s++;
2984
2985         /* -dt indicates to the debugger that threads will be used */
2986         if (*s == 't' && !isALNUM(s[1])) {
2987             ++s;
2988             my_setenv("PERL5DB_THREADED", "1");
2989         }
2990
2991         /* The following permits -d:Mod to accepts arguments following an =
2992            in the fashion that -MSome::Mod does. */
2993         if (*s == ':' || *s == '=') {
2994             const char *start = ++s;
2995             const char *const end = s + strlen(s);
2996             SV * const sv = newSVpvs("use Devel::");
2997
2998             /* We now allow -d:Module=Foo,Bar */
2999             while(isALNUM(*s) || *s==':') ++s;
3000             if (*s != '=')
3001                 sv_catpvn(sv, start, end - start);
3002             else {
3003                 sv_catpvn(sv, start, s-start);
3004                 /* Don't use NUL as q// delimiter here, this string goes in the
3005                  * environment. */
3006                 Perl_sv_catpvf(aTHX_ sv, " split(/,/,q{%s});", ++s);
3007             }
3008             s = end;
3009             my_setenv("PERL5DB", SvPV_nolen_const(sv));
3010             SvREFCNT_dec(sv);
3011         }
3012         if (!PL_perldb) {
3013             PL_perldb = PERLDB_ALL;
3014             init_debugger();
3015         }
3016         return s;
3017     case 'D':
3018     {
3019 #ifdef DEBUGGING
3020         forbid_setid('D', FALSE);
3021         s++;
3022         PL_debug = get_debug_opts( (const char **)&s, 1) | DEBUG_TOP_FLAG;
3023 #else /* !DEBUGGING */
3024         if (ckWARN_d(WARN_DEBUGGING))
3025             Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
3026                    "Recompile perl with -DDEBUGGING to use -D switch (did you mean -d ?)\n");
3027         for (s++; isALNUM(*s); s++) ;
3028 #endif
3029         return s;
3030     }
3031     case 'h':
3032         usage(PL_origargv[0]);
3033         my_exit(0);
3034     case 'i':
3035         Safefree(PL_inplace);
3036 #if defined(__CYGWIN__) /* do backup extension automagically */
3037         if (*(s+1) == '\0') {
3038         PL_inplace = savepvs(".bak");
3039         return s+1;
3040         }
3041 #endif /* __CYGWIN__ */
3042         {
3043             const char * const start = ++s;
3044             while (*s && !isSPACE(*s))
3045                 ++s;
3046
3047             PL_inplace = savepvn(start, s - start);
3048         }
3049         if (*s) {
3050             ++s;
3051             if (*s == '-')      /* Additional switches on #! line. */
3052                 s++;
3053         }
3054         return s;
3055     case 'I':   /* -I handled both here and in parse_body() */
3056         forbid_setid('I', FALSE);
3057         ++s;
3058         while (*s && isSPACE(*s))
3059             ++s;
3060         if (*s) {
3061             const char *e, *p;
3062             p = s;
3063             /* ignore trailing spaces (possibly followed by other switches) */
3064             do {
3065                 for (e = p; *e && !isSPACE(*e); e++) ;
3066                 p = e;
3067                 while (isSPACE(*p))
3068                     p++;
3069             } while (*p && *p != '-');
3070             incpush(s, e-s,
3071                     INCPUSH_ADD_SUB_DIRS|INCPUSH_ADD_OLD_VERS|INCPUSH_UNSHIFT);
3072             s = p;
3073             if (*s == '-')
3074                 s++;
3075         }
3076         else
3077             Perl_croak(aTHX_ "No directory specified for -I");
3078         return s;
3079     case 'l':
3080         PL_minus_l = TRUE;
3081         s++;
3082         if (PL_ors_sv) {
3083             SvREFCNT_dec(PL_ors_sv);
3084             PL_ors_sv = NULL;
3085         }
3086         if (isDIGIT(*s)) {
3087             I32 flags = 0;
3088             STRLEN numlen;
3089             PL_ors_sv = newSVpvs("\n");
3090             numlen = 3 + (*s == '0');
3091             *SvPVX(PL_ors_sv) = (char)grok_oct(s, &numlen, &flags, NULL);
3092             s += numlen;
3093         }
3094         else {
3095             if (RsPARA(PL_rs)) {
3096                 PL_ors_sv = newSVpvs("\n\n");
3097             }
3098             else {
3099                 PL_ors_sv = newSVsv(PL_rs);
3100             }
3101         }
3102         return s;
3103     case 'M':
3104         forbid_setid('M', FALSE);       /* XXX ? */
3105         /* FALL THROUGH */
3106     case 'm':
3107         forbid_setid('m', FALSE);       /* XXX ? */
3108         if (*++s) {
3109             const char *start;
3110             const char *end;
3111             SV *sv;
3112             const char *use = "use ";
3113             bool colon = FALSE;
3114             /* -M-foo == 'no foo'       */
3115             /* Leading space on " no " is deliberate, to make both
3116                possibilities the same length.  */
3117             if (*s == '-') { use = " no "; ++s; }
3118             sv = newSVpvn(use,4);
3119             start = s;
3120             /* We allow -M'Module qw(Foo Bar)'  */
3121             while(isALNUM(*s) || *s==':') {
3122                 if( *s++ == ':' ) {
3123                     if( *s == ':' )
3124                         s++;
3125                     else
3126                         colon = TRUE;
3127                 }
3128             }
3129             if (s == start)
3130                 Perl_croak(aTHX_ "Module name required with -%c option",
3131                                     option);
3132             if (colon)
3133                 Perl_croak(aTHX_ "Invalid module name %.*s with -%c option: "
3134                                     "contains single ':'",
3135                                     (int)(s - start), start, option);
3136             end = s + strlen(s);
3137             if (*s != '=') {
3138                 sv_catpvn(sv, start, end - start);
3139                 if (option == 'm') {
3140                     if (*s != '\0')
3141                         Perl_croak(aTHX_ "Can't use '%c' after -mname", *s);
3142                     sv_catpvs( sv, " ()");
3143                 }
3144             } else {
3145                 sv_catpvn(sv, start, s-start);
3146                 /* Use NUL as q''-delimiter.  */
3147                 sv_catpvs(sv, " split(/,/,q\0");
3148                 ++s;
3149                 sv_catpvn(sv, s, end - s);
3150                 sv_catpvs(sv,  "\0)");
3151             }
3152             s = end;
3153             Perl_av_create_and_push(aTHX_ &PL_preambleav, sv);
3154         }
3155         else
3156             Perl_croak(aTHX_ "Missing argument to -%c", option);
3157         return s;
3158     case 'n':
3159         PL_minus_n = TRUE;
3160         s++;
3161         return s;
3162     case 'p':
3163         PL_minus_p = TRUE;
3164         s++;
3165         return s;
3166     case 's':
3167         forbid_setid('s', FALSE);
3168         PL_doswitches = TRUE;
3169         s++;
3170         return s;
3171     case 't':
3172         if (!PL_tainting)
3173             TOO_LATE_FOR('t');
3174         s++;
3175         return s;
3176     case 'T':
3177         if (!PL_tainting)
3178             TOO_LATE_FOR('T');
3179         s++;
3180         return s;
3181     case 'u':
3182         PL_do_undump = TRUE;
3183         s++;
3184         return s;
3185     case 'U':
3186         PL_unsafe = TRUE;
3187         s++;
3188         return s;
3189     case 'v':
3190         if (!sv_derived_from(PL_patchlevel, "version"))
3191             upg_version(PL_patchlevel, TRUE);
3192 #if !defined(DGUX)
3193         {
3194             SV* level= vstringify(PL_patchlevel);
3195 #ifdef PERL_PATCHNUM
3196 #  ifdef PERL_GIT_UNCOMMITTED_CHANGES
3197             SV *num = newSVpvs(PERL_PATCHNUM "*");
3198 #  else
3199             SV *num = newSVpvs(PERL_PATCHNUM);
3200 #  endif
3201
3202             if (sv_len(num)>=sv_len(level) && strnEQ(SvPV_nolen(num),SvPV_nolen(level),sv_len(level))) {
3203                 SvREFCNT_dec(level);
3204                 level= num;
3205             } else {
3206                 Perl_sv_catpvf(aTHX_ level, " (%"SVf")", num);
3207                 SvREFCNT_dec(num);
3208             }
3209  #endif
3210             PerlIO_printf(PerlIO_stdout(),
3211                 "\nThis is perl, %"SVf
3212                 " built for %s",
3213                 level,
3214                 ARCHNAME);
3215             SvREFCNT_dec(level);
3216         }
3217 #else /* DGUX */
3218 /* Adjust verbose output as in the perl that ships with the DG/UX OS from EMC */
3219         PerlIO_printf(PerlIO_stdout(),
3220                 Perl_form(aTHX_ "\nThis is perl, %"SVf"\n",
3221                     SVfARG(vstringify(PL_patchlevel))));
3222         PerlIO_printf(PerlIO_stdout(),
3223                         Perl_form(aTHX_ "        built under %s at %s %s\n",
3224                                         OSNAME, __DATE__, __TIME__));
3225         PerlIO_printf(PerlIO_stdout(),
3226                         Perl_form(aTHX_ "        OS Specific Release: %s\n",
3227                                         OSVERS));
3228 #endif /* !DGUX */
3229 #if defined(LOCAL_PATCH_COUNT)
3230         if (LOCAL_PATCH_COUNT > 0)
3231             PerlIO_printf(PerlIO_stdout(),
3232                           "\n(with %d registered patch%s, "
3233                           "see perl -V for more detail)",
3234                           LOCAL_PATCH_COUNT,
3235                           (LOCAL_PATCH_COUNT!=1) ? "es" : "");
3236 #endif
3237
3238         PerlIO_printf(PerlIO_stdout(),
3239                       "\n\nCopyright 1987-2009, Larry Wall\n");
3240 #ifdef MSDOS
3241         PerlIO_printf(PerlIO_stdout(),
3242                       "\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
3243 #endif
3244 #ifdef DJGPP
3245         PerlIO_printf(PerlIO_stdout(),
3246                       "djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n"
3247                       "djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n");
3248 #endif
3249 #ifdef OS2
3250         PerlIO_printf(PerlIO_stdout(),
3251                       "\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
3252                       "Version 5 port Copyright (c) 1994-2002, Andreas Kaiser, Ilya Zakharevich\n");
3253 #endif
3254 #ifdef atarist
3255         PerlIO_printf(PerlIO_stdout(),
3256                       "atariST series port, ++jrb  bammi@cadence.com\n");
3257 #endif
3258 #ifdef __BEOS__
3259         PerlIO_printf(PerlIO_stdout(),
3260                       "BeOS port Copyright Tom Spindler, 1997-1999\n");
3261 #endif
3262 #ifdef MPE
3263         PerlIO_printf(PerlIO_stdout(),
3264                       "MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-2003\n");
3265 #endif
3266 #ifdef OEMVS
3267         PerlIO_printf(PerlIO_stdout(),
3268                       "MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
3269 #endif
3270 #ifdef __VOS__
3271         PerlIO_printf(PerlIO_stdout(),
3272                       "Stratus VOS port by Paul.Green@stratus.com, 1997-2002\n");
3273 #endif
3274 #ifdef __OPEN_VM
3275         PerlIO_printf(PerlIO_stdout(),
3276                       "VM/ESA port by Neale Ferguson, 1998-1999\n");
3277 #endif
3278 #ifdef POSIX_BC
3279         PerlIO_printf(PerlIO_stdout(),
3280                       "BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
3281 #endif
3282 #ifdef EPOC
3283         PerlIO_printf(PerlIO_stdout(),
3284                       "EPOC port by Olaf Flebbe, 1999-2002\n");
3285 #endif
3286 #ifdef UNDER_CE
3287         PerlIO_printf(PerlIO_stdout(),"WINCE port by Rainer Keuchel, 2001-2002\n");
3288         PerlIO_printf(PerlIO_stdout(),"Built on " __DATE__ " " __TIME__ "\n\n");
3289         wce_hitreturn();
3290 #endif
3291 #ifdef __SYMBIAN32__
3292         PerlIO_printf(PerlIO_stdout(),
3293                       "Symbian port by Nokia, 2004-2005\n");
3294 #endif
3295 #ifdef BINARY_BUILD_NOTICE
3296         BINARY_BUILD_NOTICE;
3297 #endif
3298         PerlIO_printf(PerlIO_stdout(),
3299                       "\n\
3300 Perl may be copied only under the terms of either the Artistic License or the\n\
3301 GNU General Public License, which may be found in the Perl 5 source kit.\n\n\
3302 Complete documentation for Perl, including FAQ lists, should be found on\n\
3303 this system using \"man perl\" or \"perldoc perl\".  If you have access to the\n\
3304 Internet, point your browser at http://www.perl.org/, the Perl Home Page.\n\n");
3305         my_exit(0);
3306     case 'w':
3307         if (! (PL_dowarn & G_WARN_ALL_MASK)) {
3308             PL_dowarn |= G_WARN_ON;
3309         }
3310         s++;
3311         return s;
3312     case 'W':
3313         PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
3314         if (!specialWARN(PL_compiling.cop_warnings))
3315             PerlMemShared_free(PL_compiling.cop_warnings);
3316         PL_compiling.cop_warnings = pWARN_ALL ;
3317         s++;
3318         return s;
3319     case 'X':
3320         PL_dowarn = G_WARN_ALL_OFF;
3321         if (!specialWARN(PL_compiling.cop_warnings))
3322             PerlMemShared_free(PL_compiling.cop_warnings);
3323         PL_compiling.cop_warnings = pWARN_NONE ;
3324         s++;
3325         return s;
3326     case '*':
3327     case ' ':
3328         while( *s == ' ' )
3329           ++s;
3330         if (s[0] == '-')        /* Additional switches on #! line. */
3331             return s+1;
3332         break;
3333     case '-':
3334     case 0:
3335 #if defined(WIN32) || !defined(PERL_STRICT_CR)
3336     case '\r':
3337 #endif
3338     case '\n':
3339     case '\t':
3340         break;
3341 #ifdef ALTERNATE_SHEBANG
3342     case 'S':                   /* OS/2 needs -S on "extproc" line. */
3343         break;
3344 #endif
3345     default:
3346         Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s);
3347     }
3348     return NULL;
3349 }
3350
3351 /* compliments of Tom Christiansen */
3352
3353 /* unexec() can be found in the Gnu emacs distribution */
3354 /* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
3355
3356 void
3357 Perl_my_unexec(pTHX)
3358 {
3359     PERL_UNUSED_CONTEXT;
3360 #ifdef UNEXEC
3361     SV *    prog = newSVpv(BIN_EXP, 0);
3362     SV *    file = newSVpv(PL_origfilename, 0);
3363     int    status = 1;
3364     extern int etext;
3365
3366     sv_catpvs(prog, "/perl");
3367     sv_catpvs(file, ".perldump");
3368
3369     unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
3370     /* unexec prints msg to stderr in case of failure */
3371     PerlProc_exit(status);
3372 #else
3373 #  ifdef VMS
3374 #    include <lib$routines.h>
3375      lib$signal(SS$_DEBUG);  /* ssdef.h #included from vmsish.h */
3376 #  elif defined(WIN32) || defined(__CYGWIN__)
3377     Perl_croak(aTHX_ "dump is not supported");
3378 #  else
3379     ABORT();            /* for use with undump */
3380 #  endif
3381 #endif
3382 }
3383
3384 /* initialize curinterp */
3385 STATIC void
3386 S_init_interp(pTHX)
3387 {
3388     dVAR;
3389 #ifdef MULTIPLICITY
3390 #  define PERLVAR(var,type)
3391 #  define PERLVARA(var,n,type)
3392 #  if defined(PERL_IMPLICIT_CONTEXT)
3393 #    define PERLVARI(var,type,init)             aTHX->var = init;
3394 #    define PERLVARIC(var,type,init)    aTHX->var = init;
3395 #  else
3396 #    define PERLVARI(var,type,init)     PERL_GET_INTERP->var = init;
3397 #    define PERLVARIC(var,type,init)    PERL_GET_INTERP->var = init;
3398 #  endif
3399 #  include "intrpvar.h"
3400 #  undef PERLVAR
3401 #  undef PERLVARA
3402 #  undef PERLVARI
3403 #  undef PERLVARIC
3404 #else
3405 #  define PERLVAR(var,type)
3406 #  define PERLVARA(var,n,type)
3407 #  define PERLVARI(var,type,init)       PL_##var = init;
3408 #  define PERLVARIC(var,type,init)      PL_##var = init;
3409 #  include "intrpvar.h"
3410 #  undef PERLVAR
3411 #  undef PERLVARA
3412 #  undef PERLVARI
3413 #  undef PERLVARIC
3414 #endif
3415
3416     /* As these are inside a structure, PERLVARI isn't capable of initialising
3417        them  */
3418     PL_reg_oldcurpm = PL_reg_curpm = NULL;
3419     PL_reg_poscache = PL_reg_starttry = NULL;
3420 }
3421
3422 STATIC void
3423 S_init_main_stash(pTHX)
3424 {
3425     dVAR;
3426     GV *gv;
3427
3428     PL_curstash = PL_defstash = newHV();
3429     /* We know that the string "main" will be in the global shared string
3430        table, so it's a small saving to use it rather than allocate another
3431        8 bytes.  */
3432     PL_curstname = newSVpvs_share("main");
3433     gv = gv_fetchpvs("main::", GV_ADD|GV_NOTQUAL, SVt_PVHV);
3434     /* If we hadn't caused another reference to "main" to be in the shared
3435        string table above, then it would be worth reordering these two,
3436        because otherwise all we do is delete "main" from it as a consequence
3437        of the SvREFCNT_dec, only to add it again with hv_name_set */
3438     SvREFCNT_dec(GvHV(gv));
3439     hv_name_set(PL_defstash, "main", 4, 0);
3440     GvHV(gv) = MUTABLE_HV(SvREFCNT_inc_simple(PL_defstash));
3441     SvREADONLY_on(gv);
3442     PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpvs("INC", GV_ADD|GV_NOTQUAL,
3443                                              SVt_PVAV)));
3444     SvREFCNT_inc_simple_void(PL_incgv); /* Don't allow it to be freed */
3445     GvMULTI_on(PL_incgv);
3446     PL_hintgv = gv_fetchpvs("\010", GV_ADD|GV_NOTQUAL, SVt_PV); /* ^H */
3447     GvMULTI_on(PL_hintgv);
3448     PL_defgv = gv_fetchpvs("_", GV_ADD|GV_NOTQUAL, SVt_PVAV);
3449     SvREFCNT_inc_simple_void(PL_defgv);
3450     PL_errgv = gv_HVadd(gv_fetchpvs("@", GV_ADD|GV_NOTQUAL, SVt_PV));
3451     SvREFCNT_inc_simple_void(PL_errgv);
3452     GvMULTI_on(PL_errgv);
3453     PL_replgv = gv_fetchpvs("\022", GV_ADD|GV_NOTQUAL, SVt_PV); /* ^R */
3454     GvMULTI_on(PL_replgv);
3455     (void)Perl_form(aTHX_ "%240s","");  /* Preallocate temp - for immediate signals. */
3456 #ifdef PERL_DONT_CREATE_GVSV
3457     gv_SVadd(PL_errgv);
3458 #endif
3459     sv_grow(ERRSV, 240);        /* Preallocate - for immediate signals. */
3460     CLEAR_ERRSV();
3461     PL_curstash = PL_defstash;
3462     CopSTASH_set(&PL_compiling, PL_defstash);
3463     PL_debstash = GvHV(gv_fetchpvs("DB::", GV_ADDMULTI, SVt_PVHV));
3464     PL_globalstash = GvHV(gv_fetchpvs("CORE::GLOBAL::", GV_ADDMULTI,
3465                                       SVt_PVHV));
3466     /* We must init $/ before switches are processed. */
3467     sv_setpvs(get_sv("/", GV_ADD), "\n");
3468 }
3469
3470 STATIC int
3471 S_open_script(pTHX_ const char *scriptname, bool dosearch,
3472               bool *suidscript, PerlIO **rsfpp)
3473 {
3474     int fdscript = -1;
3475     dVAR;
3476
3477     PERL_ARGS_ASSERT_OPEN_SCRIPT;
3478
3479     if (PL_e_script) {
3480         PL_origfilename = savepvs("-e");
3481     }
3482     else {
3483         /* if find_script() returns, it returns a malloc()-ed value */
3484         scriptname = PL_origfilename = find_script(scriptname, dosearch, NULL, 1);
3485
3486         if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
3487             const char *s = scriptname + 8;
3488             fdscript = atoi(s);
3489             while (isDIGIT(*s))
3490                 s++;
3491             if (*s) {
3492                 /* PSz 18 Feb 04
3493                  * Tell apart "normal" usage of fdscript, e.g.
3494                  * with bash on FreeBSD:
3495                  *   perl <( echo '#!perl -DA'; echo 'print "$0\n"')
3496                  * from usage in suidperl.
3497                  * Does any "normal" usage leave garbage after the number???
3498                  * Is it a mistake to use a similar /dev/fd/ construct for
3499                  * suidperl?
3500                  */
3501                 *suidscript = TRUE;
3502                 /* PSz 20 Feb 04
3503                  * Be supersafe and do some sanity-checks.
3504                  * Still, can we be sure we got the right thing?
3505                  */
3506                 if (*s != '/') {
3507                     Perl_croak(aTHX_ "Wrong syntax (suid) fd script name \"%s\"\n", s);
3508                 }
3509                 if (! *(s+1)) {
3510                     Perl_croak(aTHX_ "Missing (suid) fd script name\n");
3511                 }
3512                 scriptname = savepv(s + 1);
3513                 Safefree(PL_origfilename);
3514                 PL_origfilename = (char *)scriptname;
3515             }
3516         }
3517     }
3518
3519     CopFILE_free(PL_curcop);
3520     CopFILE_set(PL_curcop, PL_origfilename);
3521     if (*PL_origfilename == '-' && PL_origfilename[1] == '\0')
3522         scriptname = (char *)"";
3523     if (fdscript >= 0) {
3524         *rsfpp = PerlIO_fdopen(fdscript,PERL_SCRIPT_MODE);
3525 #       if defined(HAS_FCNTL) && defined(F_SETFD)
3526             if (*rsfpp)
3527                 /* ensure close-on-exec */
3528                 fcntl(PerlIO_fileno(*rsfpp),F_SETFD,1);
3529 #       endif
3530     }
3531     else if (!*scriptname) {
3532         forbid_setid(0, *suidscript);
3533         *rsfpp = PerlIO_stdin();
3534     }
3535     else {
3536 #ifdef FAKE_BIT_BUCKET
3537         /* This hack allows one not to have /dev/null (or BIT_BUCKET as it
3538          * is called) and still have the "-e" work.  (Believe it or not,
3539          * a /dev/null is required for the "-e" to work because source
3540          * filter magic is used to implement it. ) This is *not* a general
3541          * replacement for a /dev/null.  What we do here is create a temp
3542          * file (an empty file), open up that as the script, and then
3543          * immediately close and unlink it.  Close enough for jazz. */
3544 #define FAKE_BIT_BUCKET_PREFIX "/tmp/perlnull-"
3545 #define FAKE_BIT_BUCKET_SUFFIX "XXXXXXXX"
3546 #define FAKE_BIT_BUCKET_TEMPLATE FAKE_BIT_BUCKET_PREFIX FAKE_BIT_BUCKET_SUFFIX
3547         char tmpname[sizeof(FAKE_BIT_BUCKET_TEMPLATE)] = {
3548             FAKE_BIT_BUCKET_TEMPLATE
3549         };
3550         const char * const err = "Failed to create a fake bit bucket";
3551         if (strEQ(scriptname, BIT_BUCKET)) {
3552 #ifdef HAS_MKSTEMP /* Hopefully mkstemp() is safe here. */
3553             int tmpfd = mkstemp(tmpname);
3554             if (tmpfd > -1) {
3555                 scriptname = tmpname;
3556                 close(tmpfd);
3557             } else
3558                 Perl_croak(aTHX_ err);
3559 #else
3560 #  ifdef HAS_MKTEMP
3561             scriptname = mktemp(tmpname);
3562             if (!scriptname)
3563                 Perl_croak(aTHX_ err);
3564 #  endif
3565 #endif
3566         }
3567 #endif
3568         *rsfpp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
3569 #ifdef FAKE_BIT_BUCKET
3570         if (memEQ(scriptname, FAKE_BIT_BUCKET_PREFIX,
3571                   sizeof(FAKE_BIT_BUCKET_PREFIX) - 1)
3572             && strlen(scriptname) == sizeof(tmpname) - 1) {
3573             unlink(scriptname);
3574         }
3575         scriptname = BIT_BUCKET;
3576 #endif
3577 #       if defined(HAS_FCNTL) && defined(F_SETFD)
3578             if (*rsfpp)
3579                 /* ensure close-on-exec */
3580                 fcntl(PerlIO_fileno(*rsfpp),F_SETFD,1);
3581 #       endif
3582     }
3583     if (!*rsfpp) {
3584         /* PSz 16 Sep 03  Keep neat error message */
3585         if (PL_e_script)
3586             Perl_croak(aTHX_ "Can't open "BIT_BUCKET": %s\n", Strerror(errno));
3587         else
3588             Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
3589                     CopFILE(PL_curcop), Strerror(errno));
3590     }
3591     return fdscript;
3592 }
3593
3594 /* Mention
3595  * I_SYSSTATVFS HAS_FSTATVFS
3596  * I_SYSMOUNT
3597  * I_STATFS     HAS_FSTATFS     HAS_GETFSSTAT
3598  * I_MNTENT     HAS_GETMNTENT   HAS_HASMNTOPT
3599  * here so that metaconfig picks them up. */
3600
3601
3602 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
3603 /* Don't even need this function.  */
3604 #else
3605 STATIC void
3606 S_validate_suid(pTHX_ PerlIO *rsfp)
3607 {
3608     PERL_ARGS_ASSERT_VALIDATE_SUID;
3609
3610     if (PL_euid != PL_uid || PL_egid != PL_gid) {       /* (suidperl doesn't exist, in fact) */
3611         dVAR;
3612
3613         PerlLIO_fstat(PerlIO_fileno(rsfp),&PL_statbuf); /* may be either wrapped or real suid */
3614         if ((PL_euid != PL_uid && PL_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
3615             ||
3616             (PL_egid != PL_gid && PL_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
3617            )
3618             if (!PL_do_undump)
3619                 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
3620 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
3621         /* not set-id, must be wrapped */
3622     }
3623 }
3624 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
3625
3626 STATIC void
3627 S_find_beginning(pTHX_ SV* linestr_sv, PerlIO *rsfp)
3628 {
3629     dVAR;
3630     const char *s;
3631     register const char *s2;
3632
3633     PERL_ARGS_ASSERT_FIND_BEGINNING;
3634
3635     /* skip forward in input to the real script? */
3636
3637     while (PL_doextract) {
3638         if ((s = sv_gets(linestr_sv, rsfp, 0)) == NULL)
3639             Perl_croak(aTHX_ "No Perl script found in input\n");
3640         s2 = s;
3641         if (*s == '#' && s[1] == '!' && ((s = instr(s,"perl")) || (s = instr(s2,"PERL")))) {
3642             PerlIO_ungetc(rsfp, '\n');          /* to keep line count right */
3643             PL_doextract = FALSE;
3644             while (*s && !(isSPACE (*s) || *s == '#')) s++;
3645             s2 = s;
3646             while (*s == ' ' || *s == '\t') s++;
3647             if (*s++ == '-') {
3648                 while (isDIGIT(s2[-1]) || s2[-1] == '-' || s2[-1] == '.'
3649                        || s2[-1] == '_') s2--;
3650                 if (strnEQ(s2-4,"perl",4))
3651                     while ((s = moreswitches(s)))
3652                         ;
3653             }
3654         }
3655     }
3656 }
3657
3658
3659 STATIC void
3660 S_init_ids(pTHX)
3661 {
3662     dVAR;
3663     PL_uid = PerlProc_getuid();
3664     PL_euid = PerlProc_geteuid();
3665     PL_gid = PerlProc_getgid();
3666     PL_egid = PerlProc_getegid();
3667 #ifdef VMS
3668     PL_uid |= PL_gid << 16;
3669     PL_euid |= PL_egid << 16;
3670 #endif
3671     /* Should not happen: */
3672     CHECK_MALLOC_TAINT(PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
3673     PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
3674     /* BUG */
3675     /* PSz 27 Feb 04
3676      * Should go by suidscript, not uid!=euid: why disallow
3677      * system("ls") in scripts run from setuid things?
3678      * Or, is this run before we check arguments and set suidscript?
3679      * What about SETUID_SCRIPTS_ARE_SECURE_NOW: could we use fdscript then?
3680      * (We never have suidscript, can we be sure to have fdscript?)
3681      * Or must then go by UID checks? See comments in forbid_setid also.
3682      */
3683 }
3684
3685 /* This is used very early in the lifetime of the program,
3686  * before even the options are parsed, so PL_tainting has
3687  * not been initialized properly.  */
3688 bool
3689 Perl_doing_taint(int argc, char *argv[], char *envp[])
3690 {
3691 #ifndef PERL_IMPLICIT_SYS
3692     /* If we have PERL_IMPLICIT_SYS we can't call getuid() et alia
3693      * before we have an interpreter-- and the whole point of this
3694      * function is to be called at such an early stage.  If you are on
3695      * a system with PERL_IMPLICIT_SYS but you do have a concept of
3696      * "tainted because running with altered effective ids', you'll
3697      * have to add your own checks somewhere in here.  The two most
3698      * known samples of 'implicitness' are Win32 and NetWare, neither
3699      * of which has much of concept of 'uids'. */
3700     int uid  = PerlProc_getuid();
3701     int euid = PerlProc_geteuid();
3702     int gid  = PerlProc_getgid();
3703     int egid = PerlProc_getegid();
3704     (void)envp;
3705
3706 #ifdef VMS
3707     uid  |=  gid << 16;
3708     euid |= egid << 16;
3709 #endif
3710     if (uid && (euid != uid || egid != gid))
3711         return 1;
3712 #endif /* !PERL_IMPLICIT_SYS */
3713     /* This is a really primitive check; environment gets ignored only
3714      * if -T are the first chars together; otherwise one gets
3715      *  "Too late" message. */
3716     if ( argc > 1 && argv[1][0] == '-'
3717          && (argv[1][1] == 't' || argv[1][1] == 'T') )
3718         return 1;
3719     return 0;
3720 }
3721
3722 /* Passing the flag as a single char rather than a string is a slight space
3723    optimisation.  The only message that isn't /^-.$/ is
3724    "program input from stdin", which is substituted in place of '\0', which
3725    could never be a command line flag.  */
3726 STATIC void
3727 S_forbid_setid(pTHX_ const char flag, const bool suidscript) /* g */
3728 {
3729     dVAR;
3730     char string[3] = "-x";
3731     const char *message = "program input from stdin";
3732
3733     if (flag) {
3734         string[1] = flag;
3735         message = string;
3736     }
3737
3738 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
3739     if (PL_euid != PL_uid)
3740         Perl_croak(aTHX_ "No %s allowed while running setuid", message);
3741     if (PL_egid != PL_gid)
3742         Perl_croak(aTHX_ "No %s allowed while running setgid", message);
3743 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
3744     if (suidscript)
3745         Perl_croak(aTHX_ "No %s allowed with (suid) fdscript", message);
3746 }
3747
3748 void
3749 Perl_init_debugger(pTHX)
3750 {
3751     dVAR;
3752     HV * const ostash = PL_curstash;
3753
3754     PL_curstash = PL_debstash;
3755     PL_dbargs = GvAV(gv_AVadd((gv_fetchpvs("DB::args", GV_ADDMULTI,
3756                                            SVt_PVAV))));
3757     AvREAL_off(PL_dbargs);
3758     PL_DBgv = gv_fetchpvs("DB::DB", GV_ADDMULTI, SVt_PVGV);
3759     PL_DBline = gv_fetchpvs("DB::dbline", GV_ADDMULTI, SVt_PVAV);
3760     PL_DBsub = gv_HVadd(gv_fetchpvs("DB::sub", GV_ADDMULTI, SVt_PVHV));
3761     PL_DBsingle = GvSV((gv_fetchpvs("DB::single", GV_ADDMULTI, SVt_PV)));
3762     sv_setiv(PL_DBsingle, 0);
3763     PL_DBtrace = GvSV((gv_fetchpvs("DB::trace", GV_ADDMULTI, SVt_PV)));
3764     sv_setiv(PL_DBtrace, 0);
3765     PL_DBsignal = GvSV((gv_fetchpvs("DB::signal", GV_ADDMULTI, SVt_PV)));
3766     sv_setiv(PL_DBsignal, 0);
3767     PL_curstash = ostash;
3768 }
3769
3770 #ifndef STRESS_REALLOC
3771 #define REASONABLE(size) (size)
3772 #else
3773 #define REASONABLE(size) (1) /* unreasonable */
3774 #endif
3775
3776 void
3777 Perl_init_stacks(pTHX)
3778 {
3779     dVAR;
3780     /* start with 128-item stack and 8K cxstack */
3781     PL_curstackinfo = new_stackinfo(REASONABLE(128),
3782                                  REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
3783     PL_curstackinfo->si_type = PERLSI_MAIN;
3784     PL_curstack = PL_curstackinfo->si_stack;
3785     PL_mainstack = PL_curstack;         /* remember in case we switch stacks */
3786
3787     PL_stack_base = AvARRAY(PL_curstack);
3788     PL_stack_sp = PL_stack_base;
3789     PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
3790
3791     Newx(PL_tmps_stack,REASONABLE(128),SV*);
3792     PL_tmps_floor = -1;
3793     PL_tmps_ix = -1;
3794     PL_tmps_max = REASONABLE(128);
3795
3796     Newx(PL_markstack,REASONABLE(32),I32);
3797     PL_markstack_ptr = PL_markstack;
3798     PL_markstack_max = PL_markstack + REASONABLE(32);
3799
3800     SET_MARK_OFFSET;
3801
3802     Newx(PL_scopestack,REASONABLE(32),I32);
3803     PL_scopestack_ix = 0;
3804     PL_scopestack_max = REASONABLE(32);
3805
3806     Newx(PL_savestack,REASONABLE(128),ANY);
3807     PL_savestack_ix = 0;
3808     PL_savestack_max = REASONABLE(128);
3809 }
3810
3811 #undef REASONABLE
3812
3813 STATIC void
3814 S_nuke_stacks(pTHX)
3815 {
3816     dVAR;
3817     while (PL_curstackinfo->si_next)
3818         PL_curstackinfo = PL_curstackinfo->si_next;
3819     while (PL_curstackinfo) {
3820         PERL_SI *p = PL_curstackinfo->si_prev;
3821         /* curstackinfo->si_stack got nuked by sv_free_arenas() */
3822         Safefree(PL_curstackinfo->si_cxstack);
3823         Safefree(PL_curstackinfo);
3824         PL_curstackinfo = p;
3825     }
3826     Safefree(PL_tmps_stack);
3827     Safefree(PL_markstack);
3828     Safefree(PL_scopestack);
3829     Safefree(PL_savestack);
3830 }
3831
3832
3833 STATIC void
3834 S_init_predump_symbols(pTHX)
3835 {
3836     dVAR;
3837     GV *tmpgv;
3838     IO *io;
3839
3840     sv_setpvs(get_sv("\"", GV_ADD), " ");
3841     PL_ofsgv = (GV*)SvREFCNT_inc(gv_fetchpvs(",", GV_ADD|GV_NOTQUAL, SVt_PV));
3842
3843     PL_stdingv = gv_fetchpvs("STDIN", GV_ADD|GV_NOTQUAL, SVt_PVIO);
3844     GvMULTI_on(PL_stdingv);
3845     io = GvIOp(PL_stdingv);
3846     IoTYPE(io) = IoTYPE_RDONLY;
3847     IoIFP(io) = PerlIO_stdin();
3848     tmpgv = gv_fetchpvs("stdin", GV_ADD|GV_NOTQUAL, SVt_PV);
3849     GvMULTI_on(tmpgv);
3850     GvIOp(tmpgv) = MUTABLE_IO(SvREFCNT_inc_simple(io));
3851
3852     tmpgv = gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVIO);
3853     GvMULTI_on(tmpgv);
3854     io = GvIOp(tmpgv);
3855     IoTYPE(io) = IoTYPE_WRONLY;
3856     IoOFP(io) = IoIFP(io) = PerlIO_stdout();
3857     setdefout(tmpgv);
3858     tmpgv = gv_fetchpvs("stdout", GV_ADD|GV_NOTQUAL, SVt_PV);
3859     GvMULTI_on(tmpgv);
3860     GvIOp(tmpgv) = MUTABLE_IO(SvREFCNT_inc_simple(io));
3861
3862     PL_stderrgv = gv_fetchpvs("STDERR", GV_ADD|GV_NOTQUAL, SVt_PVIO);
3863     GvMULTI_on(PL_stderrgv);
3864     io = GvIOp(PL_stderrgv);
3865     IoTYPE(io) = IoTYPE_WRONLY;
3866     IoOFP(io) = IoIFP(io) = PerlIO_stderr();
3867     tmpgv = gv_fetchpvs("stderr", GV_ADD|GV_NOTQUAL, SVt_PV);
3868     GvMULTI_on(tmpgv);
3869     GvIOp(tmpgv) = MUTABLE_IO(SvREFCNT_inc_simple(io));
3870
3871     PL_statname = newSV(0);             /* last filename we did stat on */
3872
3873     Safefree(PL_osname);
3874     PL_osname = savepv(OSNAME);
3875 }
3876
3877 void
3878 Perl_init_argv_symbols(pTHX_ register int argc, register char **argv)
3879 {
3880     dVAR;
3881
3882     PERL_ARGS_ASSERT_INIT_ARGV_SYMBOLS;
3883
3884     argc--,argv++;      /* skip name of script */
3885     if (PL_doswitches) {
3886         for (; argc > 0 && **argv == '-'; argc--,argv++) {
3887             char *s;
3888             if (!argv[0][1])
3889                 break;
3890             if (argv[0][1] == '-' && !argv[0][2]) {
3891                 argc--,argv++;
3892                 break;
3893             }
3894             if ((s = strchr(argv[0], '='))) {
3895                 const char *const start_name = argv[0] + 1;
3896                 sv_setpv(GvSV(gv_fetchpvn_flags(start_name, s - start_name,
3897                                                 TRUE, SVt_PV)), s + 1);
3898             }
3899             else
3900                 sv_setiv(GvSV(gv_fetchpv(argv[0]+1, GV_ADD, SVt_PV)),1);
3901         }
3902     }
3903     if ((PL_argvgv = gv_fetchpvs("ARGV", GV_ADD|GV_NOTQUAL, SVt_PVAV))) {
3904         GvMULTI_on(PL_argvgv);
3905         (void)gv_AVadd(PL_argvgv);
3906         av_clear(GvAVn(PL_argvgv));
3907         for (; argc > 0; argc--,argv++) {
3908             SV * const sv = newSVpv(argv[0],0);
3909             av_push(GvAVn(PL_argvgv),sv);
3910             if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) {
3911                  if (PL_unicode & PERL_UNICODE_ARGV_FLAG)
3912                       SvUTF8_on(sv);
3913             }
3914             if (PL_unicode & PERL_UNICODE_WIDESYSCALLS_FLAG) /* Sarathy? */
3915                  (void)sv_utf8_decode(sv);
3916         }
3917     }
3918 }
3919
3920 STATIC void
3921 S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env)
3922 {
3923     dVAR;
3924     GV* tmpgv;
3925
3926     PERL_ARGS_ASSERT_INIT_POSTDUMP_SYMBOLS;
3927
3928     PL_toptarget = newSV_type(SVt_PVFM);
3929     sv_setpvs(PL_toptarget, "");
3930     PL_bodytarget = newSV_type(SVt_PVFM);
3931     sv_setpvs(PL_bodytarget, "");
3932     PL_formtarget = PL_bodytarget;
3933
3934     TAINT;
3935
3936     init_argv_symbols(argc,argv);
3937
3938     if ((tmpgv = gv_fetchpvs("0", GV_ADD|GV_NOTQUAL, SVt_PV))) {
3939         sv_setpv(GvSV(tmpgv),PL_origfilename);
3940     }
3941     if ((PL_envgv = gv_fetchpvs("ENV", GV_ADD|GV_NOTQUAL, SVt_PVHV))) {
3942         HV *hv;
3943         bool env_is_not_environ;
3944         GvMULTI_on(PL_envgv);
3945         hv = GvHVn(PL_envgv);
3946         hv_magic(hv, NULL, PERL_MAGIC_env);
3947 #ifndef PERL_MICRO
3948 #ifdef USE_ENVIRON_ARRAY
3949         /* Note that if the supplied env parameter is actually a copy
3950            of the global environ then it may now point to free'd memory
3951            if the environment has been modified since. To avoid this
3952            problem we treat env==NULL as meaning 'use the default'
3953         */
3954         if (!env)
3955             env = environ;
3956         env_is_not_environ = env != environ;
3957         if (env_is_not_environ
3958 #  ifdef USE_ITHREADS
3959             && PL_curinterp == aTHX
3960 #  endif
3961            )
3962         {
3963             environ[0] = NULL;
3964         }
3965         if (env) {
3966           char *s, *old_var;
3967           SV *sv;
3968           for (; *env; env++) {
3969             old_var = *env;
3970
3971             if (!(s = strchr(old_var,'=')) || s == old_var)
3972                 continue;
3973
3974 #if defined(MSDOS) && !defined(DJGPP)
3975             *s = '\0';
3976             (void)strupr(old_var);
3977             *s = '=';
3978 #endif
3979             sv = newSVpv(s+1, 0);
3980             (void)hv_store(hv, old_var, s - old_var, sv, 0);
3981             if (env_is_not_environ)
3982                 mg_set(sv);
3983           }
3984       }
3985 #endif /* USE_ENVIRON_ARRAY */
3986 #endif /* !PERL_MICRO */
3987     }
3988     TAINT_NOT;
3989     if ((tmpgv = gv_fetchpvs("$", GV_ADD|GV_NOTQUAL, SVt_PV))) {
3990         SvREADONLY_off(GvSV(tmpgv));
3991         sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
3992         SvREADONLY_on(GvSV(tmpgv));
3993     }
3994 #ifdef THREADS_HAVE_PIDS
3995     PL_ppid = (IV)getppid();
3996 #endif
3997
3998     /* touch @F array to prevent spurious warnings 20020415 MJD */
3999     if (PL_minus_a) {
4000       (void) get_av("main::F", GV_ADD | GV_ADDMULTI);
4001     }
4002 }
4003
4004 STATIC void
4005 S_init_perllib(pTHX)
4006 {
4007     dVAR;
4008 #ifndef VMS
4009     const char *perl5lib = NULL;
4010 #endif
4011     const char *s;
4012 #ifdef WIN32
4013     STRLEN len;
4014 #endif
4015
4016     if (!PL_tainting) {
4017 #ifndef VMS
4018         perl5lib = PerlEnv_getenv("PERL5LIB");
4019 /*
4020  * It isn't possible to delete an environment variable with
4021  * PERL_USE_SAFE_PUTENV set unless unsetenv() is also available, so in that
4022  * case we treat PERL5LIB as undefined if it has a zero-length value.
4023  */
4024 #if defined(PERL_USE_SAFE_PUTENV) && ! defined(HAS_UNSETENV)
4025         if (perl5lib && *perl5lib != '\0')
4026 #else
4027         if (perl5lib)
4028 #endif
4029             incpush_use_sep(perl5lib, 0, INCPUSH_ADD_SUB_DIRS);
4030         else {
4031             s = PerlEnv_getenv("PERLLIB");
4032             if (s)
4033                 incpush_use_sep(s, 0, 0);
4034         }
4035 #else /* VMS */
4036         /* Treat PERL5?LIB as a possible search list logical name -- the
4037          * "natural" VMS idiom for a Unix path string.  We allow each
4038          * element to be a set of |-separated directories for compatibility.
4039          */
4040         char buf[256];
4041         int idx = 0;
4042         if (my_trnlnm("PERL5LIB",buf,0))
4043             do {
4044                 incpush_use_sep(buf, 0, INCPUSH_ADD_SUB_DIRS);
4045             } while (my_trnlnm("PERL5LIB",buf,++idx));
4046         else {
4047             while (my_trnlnm("PERLLIB",buf,idx++))
4048                 incpush_use_sep(buf, 0, 0);
4049         }
4050 #endif /* VMS */
4051     }
4052
4053 /* Use the ~-expanded versions of APPLLIB (undocumented),
4054     ARCHLIB PRIVLIB SITEARCH SITELIB VENDORARCH and VENDORLIB
4055 */
4056 #ifdef APPLLIB_EXP
4057     S_incpush_use_sep(aTHX_ STR_WITH_LEN(APPLLIB_EXP),
4058                       INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE);
4059 #endif
4060
4061 #ifdef SITEARCH_EXP
4062     /* sitearch is always relative to sitelib on Windows for
4063      * DLL-based path intuition to work correctly */
4064 #  if !defined(WIN32)
4065         S_incpush_use_sep(aTHX_ STR_WITH_LEN(SITEARCH_EXP),
4066                           INCPUSH_CAN_RELOCATE);
4067 #  endif
4068 #endif
4069
4070 #ifdef SITELIB_EXP
4071 #  if defined(WIN32)
4072     /* this picks up sitearch as well */
4073         s = win32_get_sitelib(PERL_FS_VERSION, &len);
4074         if (s)
4075             incpush_use_sep(s, len, INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE);
4076 #  else
4077         S_incpush_use_sep(aTHX_ STR_WITH_LEN(SITELIB_EXP), INCPUSH_CAN_RELOCATE);
4078 #  endif
4079 #endif
4080
4081 #ifdef PERL_VENDORARCH_EXP
4082     /* vendorarch is always relative to vendorlib on Windows for
4083      * DLL-based path intuition to work correctly */
4084 #  if !defined(WIN32)
4085     S_incpush_use_sep(aTHX_ STR_WITH_LEN(PERL_VENDORARCH_EXP),
4086                       INCPUSH_CAN_RELOCATE);
4087 #  endif
4088 #endif
4089
4090 #ifdef PERL_VENDORLIB_EXP
4091 #  if defined(WIN32)
4092     /* this picks up vendorarch as well */
4093         s = win32_get_vendorlib(PERL_FS_VERSION, &len);
4094         if (s)
4095             incpush_use_sep(s, len, INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE);
4096 #  else
4097         S_incpush_use_sep(aTHX_ STR_WITH_LEN(PERL_VENDORLIB_EXP),
4098                           INCPUSH_CAN_RELOCATE);
4099 #  endif
4100 #endif
4101
4102 #ifdef ARCHLIB_EXP
4103     S_incpush_use_sep(aTHX_ STR_WITH_LEN(ARCHLIB_EXP), INCPUSH_CAN_RELOCATE);
4104 #endif
4105
4106 #ifndef PRIVLIB_EXP
4107 #  define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
4108 #endif
4109
4110 #if defined(WIN32)
4111     s = win32_get_privlib(PERL_FS_VERSION, &len);
4112     if (s)
4113         incpush_use_sep(s, len, INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE);
4114 #else
4115 #  ifdef NETWARE
4116     S_incpush_use_sep(aTHX_ PRIVLIB_EXP, 0, INCPUSH_CAN_RELOCATE);
4117 #  else
4118     S_incpush_use_sep(aTHX_ STR_WITH_LEN(PRIVLIB_EXP), INCPUSH_CAN_RELOCATE);
4119 #  endif
4120 #endif
4121
4122 #ifdef PERL_OTHERLIBDIRS
4123     S_incpush_use_sep(aTHX_ STR_WITH_LEN(PERL_OTHERLIBDIRS),
4124                       INCPUSH_ADD_VERSIONED_SUB_DIRS|INCPUSH_NOT_BASEDIR
4125                       |INCPUSH_CAN_RELOCATE);
4126 #endif
4127
4128     if (!PL_tainting) {
4129 #ifndef VMS
4130 /*
4131  * It isn't possible to delete an environment variable with
4132  * PERL_USE_SAFE_PUTENV set unless unsetenv() is also available, so in that
4133  * case we treat PERL5LIB as undefined if it has a zero-length value.
4134  */
4135 #if defined(PERL_USE_SAFE_PUTENV) && ! defined(HAS_UNSETENV)
4136         if (perl5lib && *perl5lib != '\0')
4137 #else
4138         if (perl5lib)
4139 #endif
4140             incpush_use_sep(perl5lib, 0,
4141                             INCPUSH_ADD_OLD_VERS|INCPUSH_NOT_BASEDIR);
4142 #else /* VMS */
4143         /* Treat PERL5?LIB as a possible search list logical name -- the
4144          * "natural" VMS idiom for a Unix path string.  We allow each
4145          * element to be a set of |-separated directories for compatibility.
4146          */
4147         char buf[256];
4148         int idx = 0;
4149         if (my_trnlnm("PERL5LIB",buf,0))
4150             do {
4151                 incpush_use_sep(buf, 0,
4152                                 INCPUSH_ADD_OLD_VERS|INCPUSH_NOT_BASEDIR);
4153             } while (my_trnlnm("PERL5LIB",buf,++idx));
4154 #endif /* VMS */
4155     }
4156
4157 /* Use the ~-expanded versions of APPLLIB (undocumented),
4158     ARCHLIB PRIVLIB SITEARCH SITELIB VENDORARCH and VENDORLIB
4159 */
4160 #ifdef APPLLIB_EXP
4161     S_incpush_use_sep(aTHX_ STR_WITH_LEN(APPLLIB_EXP), INCPUSH_ADD_OLD_VERS
4162                       |INCPUSH_NOT_BASEDIR|INCPUSH_CAN_RELOCATE);
4163 #endif
4164
4165 #if defined(SITELIB_STEM) && defined(PERL_INC_VERSION_LIST)
4166     /* Search for version-specific dirs below here */
4167     S_incpush_use_sep(aTHX_ STR_WITH_LEN(SITELIB_STEM),
4168                       INCPUSH_ADD_OLD_VERS|INCPUSH_CAN_RELOCATE);
4169 #endif
4170
4171
4172 #if defined(PERL_VENDORLIB_STEM) && defined(PERL_INC_VERSION_LIST)
4173     /* Search for version-specific dirs below here */
4174     S_incpush_use_sep(aTHX_ STR_WITH_LEN(PERL_VENDORLIB_STEM),
4175                       INCPUSH_ADD_OLD_VERS|INCPUSH_CAN_RELOCATE);
4176 #endif
4177
4178 #ifdef PERL_OTHERLIBDIRS
4179     S_incpush_use_sep(aTHX_ STR_WITH_LEN(PERL_OTHERLIBDIRS),
4180                       INCPUSH_ADD_OLD_VERS|INCPUSH_ADD_ARCHONLY_SUB_DIRS
4181                       |INCPUSH_CAN_RELOCATE);
4182 #endif
4183
4184     if (!PL_tainting)
4185         S_incpush(aTHX_ STR_WITH_LEN("."), 0);
4186 }
4187
4188 #if defined(DOSISH) || defined(EPOC) || defined(__SYMBIAN32__)
4189 #    define PERLLIB_SEP ';'
4190 #else
4191 #  if defined(VMS)
4192 #    define PERLLIB_SEP '|'
4193 #  else
4194 #    define PERLLIB_SEP ':'
4195 #  endif
4196 #endif
4197 #ifndef PERLLIB_MANGLE
4198 #  define PERLLIB_MANGLE(s,n) (s)
4199 #endif
4200
4201 /* Push a directory onto @INC if it exists.
4202    Generate a new SV if we do this, to save needing to copy the SV we push
4203    onto @INC  */
4204 STATIC SV *
4205 S_incpush_if_exists(pTHX_ AV *const av, SV *dir, SV *const stem)
4206 {
4207     dVAR;
4208     Stat_t tmpstatbuf;
4209
4210     PERL_ARGS_ASSERT_INCPUSH_IF_EXISTS;
4211
4212     if (PerlLIO_stat(SvPVX_const(dir), &tmpstatbuf) >= 0 &&
4213         S_ISDIR(tmpstatbuf.st_mode)) {
4214         av_push(av, dir);
4215         dir = newSVsv(stem);
4216     } else {
4217         /* Truncate dir back to stem.  */
4218         SvCUR_set(dir, SvCUR(stem));
4219     }
4220     return dir;
4221 }
4222
4223 STATIC void
4224 S_incpush(pTHX_ const char *const dir, STRLEN len, U32 flags)
4225 {
4226     dVAR;
4227     const U8 using_sub_dirs
4228         = (U8)flags & (INCPUSH_ADD_VERSIONED_SUB_DIRS
4229                        |INCPUSH_ADD_ARCHONLY_SUB_DIRS|INCPUSH_ADD_OLD_VERS);
4230     const U8 add_versioned_sub_dirs
4231         = (U8)flags & INCPUSH_ADD_VERSIONED_SUB_DIRS;
4232     const U8 add_archonly_sub_dirs
4233         = (U8)flags & INCPUSH_ADD_ARCHONLY_SUB_DIRS;
4234 #ifdef PERL_INC_VERSION_LIST
4235     const U8 addoldvers  = (U8)flags & INCPUSH_ADD_OLD_VERS;
4236 #endif
4237     const U8 canrelocate = (U8)flags & INCPUSH_CAN_RELOCATE;
4238     const U8 unshift     = (U8)flags & INCPUSH_UNSHIFT;
4239     const U8 push_basedir = (flags & INCPUSH_NOT_BASEDIR) ? 0 : 1;
4240     AV *const inc = GvAVn(PL_incgv);
4241
4242     PERL_ARGS_ASSERT_INCPUSH;
4243     assert(len > 0);
4244
4245     /* Could remove this vestigial extra block, if we don't mind a lot of
4246        re-indenting diff noise.  */
4247     {
4248         SV *libdir;
4249         /* Change 20189146be79a0596543441fa369c6bf7f85103f, to fix RT#6665,
4250            arranged to unshift #! line -I onto the front of @INC. However,
4251            -I can add version and architecture specific libraries, and they
4252            need to go first. The old code assumed that it was always
4253            pushing. Hence to make it work, need to push the architecture
4254            (etc) libraries onto a temporary array, then "unshift" that onto
4255            the front of @INC.  */
4256         AV *const av = (using_sub_dirs) ? (unshift ? newAV() : inc) : NULL;
4257
4258         if (len) {
4259             /* I am not convinced that this is valid when PERLLIB_MANGLE is
4260                defined to so something (in os2/os2.c), but the code has been
4261                this way, ignoring any possible changed of length, since
4262                760ac839baf413929cd31cc32ffd6dba6b781a81 (5.003_02) so I'll leave
4263                it be.  */
4264             libdir = newSVpvn(PERLLIB_MANGLE(dir, len), len);
4265         } else {
4266             libdir = newSVpv(PERLLIB_MANGLE(dir, 0), 0);
4267         }
4268
4269         /* Do the if() outside the #ifdef to avoid warnings about an unused
4270            parameter.  */
4271         if (canrelocate) {
4272 #ifdef PERL_RELOCATABLE_INC
4273         /*
4274          * Relocatable include entries are marked with a leading .../
4275          *
4276          * The algorithm is
4277          * 0: Remove that leading ".../"
4278          * 1: Remove trailing executable name (anything after the last '/')
4279          *    from the perl path to give a perl prefix
4280          * Then
4281          * While the @INC element starts "../" and the prefix ends with a real
4282          * directory (ie not . or ..) chop that real directory off the prefix
4283          * and the leading "../" from the @INC element. ie a logical "../"
4284          * cleanup
4285          * Finally concatenate the prefix and the remainder of the @INC element
4286          * The intent is that /usr/local/bin/perl and .../../lib/perl5
4287          * generates /usr/local/lib/perl5
4288          */
4289             const char *libpath = SvPVX(libdir);
4290             STRLEN libpath_len = SvCUR(libdir);
4291             if (libpath_len >= 4 && memEQ (libpath, ".../", 4)) {
4292                 /* Game on!  */
4293                 SV * const caret_X = get_sv("\030", 0);
4294                 /* Going to use the SV just as a scratch buffer holding a C
4295                    string:  */
4296                 SV *prefix_sv;
4297                 char *prefix;
4298                 char *lastslash;
4299
4300                 /* $^X is *the* source of taint if tainting is on, hence
4301                    SvPOK() won't be true.  */
4302                 assert(caret_X);
4303                 assert(SvPOKp(caret_X));
4304                 prefix_sv = newSVpvn_flags(SvPVX(caret_X), SvCUR(caret_X),
4305                                            SvUTF8(caret_X));
4306                 /* Firstly take off the leading .../
4307                    If all else fail we'll do the paths relative to the current
4308                    directory.  */
4309                 sv_chop(libdir, libpath + 4);
4310                 /* Don't use SvPV as we're intentionally bypassing taining,
4311                    mortal copies that the mg_get of tainting creates, and
4312                    corruption that seems to come via the save stack.
4313                    I guess that the save stack isn't correctly set up yet.  */
4314                 libpath = SvPVX(libdir);
4315                 libpath_len = SvCUR(libdir);
4316
4317                 /* This would work more efficiently with memrchr, but as it's
4318                    only a GNU extension we'd need to probe for it and
4319                    implement our own. Not hard, but maybe not worth it?  */
4320
4321                 prefix = SvPVX(prefix_sv);
4322                 lastslash = strrchr(prefix, '/');
4323
4324                 /* First time in with the *lastslash = '\0' we just wipe off
4325                    the trailing /perl from (say) /usr/foo/bin/perl
4326                 */
4327                 if (lastslash) {
4328                     SV *tempsv;
4329                     while ((*lastslash = '\0'), /* Do that, come what may.  */
4330                            (libpath_len >= 3 && memEQ(libpath, "../", 3)
4331                             && (lastslash = strrchr(prefix, '/')))) {
4332                         if (lastslash[1] == '\0'
4333                             || (lastslash[1] == '.'
4334                                 && (lastslash[2] == '/' /* ends "/."  */
4335                                     || (lastslash[2] == '/'
4336                                         && lastslash[3] == '/' /* or "/.."  */
4337                                         )))) {
4338                             /* Prefix ends "/" or "/." or "/..", any of which
4339                                are fishy, so don't do any more logical cleanup.
4340                             */
4341                             break;
4342                         }
4343                         /* Remove leading "../" from path  */
4344                         libpath += 3;
4345                         libpath_len -= 3;
4346                         /* Next iteration round the loop removes the last
4347                            directory name from prefix by writing a '\0' in
4348                            the while clause.  */
4349                     }
4350                     /* prefix has been terminated with a '\0' to the correct
4351                        length. libpath points somewhere into the libdir SV.
4352                        We need to join the 2 with '/' and drop the result into
4353                        libdir.  */
4354                     tempsv = Perl_newSVpvf(aTHX_ "%s/%s", prefix, libpath);
4355                     SvREFCNT_dec(libdir);
4356                     /* And this is the new libdir.  */
4357                     libdir = tempsv;
4358                     if (PL_tainting &&
4359                         (PL_uid != PL_euid || PL_gid != PL_egid)) {
4360                         /* Need to taint reloccated paths if running set ID  */
4361                         SvTAINTED_on(libdir);
4362                     }
4363                 }
4364                 SvREFCNT_dec(prefix_sv);
4365             }
4366 #endif
4367         }
4368         /*
4369          * BEFORE pushing libdir onto @INC we may first push version- and
4370          * archname-specific sub-directories.
4371          */
4372         if (using_sub_dirs) {
4373             SV *subdir;
4374 #ifdef PERL_INC_VERSION_LIST
4375             /* Configure terminates PERL_INC_VERSION_LIST with a NULL */
4376             const char * const incverlist[] = { PERL_INC_VERSION_LIST };
4377             const char * const *incver;
4378 #endif
4379 #ifdef VMS
4380             char *unix;
4381             STRLEN len;
4382
4383
4384             if ((unix = tounixspec_ts(SvPV(libdir,len),NULL)) != NULL) {
4385                 len = strlen(unix);
4386                 while (unix[len-1] == '/') len--;  /* Cosmetic */
4387                 sv_usepvn(libdir,unix,len);
4388             }
4389             else
4390                 PerlIO_printf(Perl_error_log,
4391                               "Failed to unixify @INC element \"%s\"\n",
4392                               SvPV(libdir,len));
4393 #endif
4394
4395             subdir = newSVsv(libdir);
4396
4397             if (add_versioned_sub_dirs) {
4398                 /* .../version/archname if -d .../version/archname */
4399                 sv_catpvs(subdir, "/" PERL_FS_VERSION "/" ARCHNAME);
4400                 subdir = S_incpush_if_exists(aTHX_ av, subdir, libdir);
4401
4402                 /* .../version if -d .../version */
4403                 sv_catpvs(subdir, "/" PERL_FS_VERSION);
4404                 subdir = S_incpush_if_exists(aTHX_ av, subdir, libdir);
4405             }
4406
4407 #ifdef PERL_INC_VERSION_LIST
4408             if (addoldvers) {
4409                 for (incver = incverlist; *incver; incver++) {
4410                     /* .../xxx if -d .../xxx */
4411                     Perl_sv_catpvf(aTHX_ subdir, "/%s", *incver);
4412                     subdir = S_incpush_if_exists(aTHX_ av, subdir, libdir);
4413                 }
4414             }
4415 #endif
4416
4417             if (add_archonly_sub_dirs) {
4418                 /* .../archname if -d .../archname */
4419                 sv_catpvs(subdir, "/" ARCHNAME);
4420                 subdir = S_incpush_if_exists(aTHX_ av, subdir, libdir);
4421
4422             }
4423
4424             assert (SvREFCNT(subdir) == 1);
4425             SvREFCNT_dec(subdir);
4426         }
4427
4428         /* finally add this lib directory at the end of @INC */
4429         if (unshift) {
4430             U32 extra = av_len(av) + 1;
4431             av_unshift(inc, extra + push_basedir);
4432             if (push_basedir)
4433                 av_store(inc, extra, libdir);
4434             while (extra--) {
4435                 /* av owns a reference, av_store() expects to be donated a
4436                    reference, and av expects to be sane when it's cleared.
4437                    If I wanted to be naughty and wrong, I could peek inside the
4438                    implementation of av_clear(), realise that it uses
4439                    SvREFCNT_dec() too, so av's array could be a run of NULLs,
4440                    and so directly steal from it (with a memcpy() to inc, and
4441                    then memset() to NULL them out. But people copy code from the
4442                    core expecting it to be best practise, so let's use the API.
4443                    Although studious readers will note that I'm not checking any
4444                    return codes.  */
4445                 av_store(inc, extra, SvREFCNT_inc(*av_fetch(av, extra, FALSE)));
4446             }
4447             SvREFCNT_dec(av);
4448         }
4449         else if (push_basedir) {
4450             av_push(inc, libdir);
4451         }
4452
4453         if (!push_basedir) {
4454             assert (SvREFCNT(libdir) == 1);
4455             SvREFCNT_dec(libdir);
4456         }
4457     }
4458 }
4459
4460 STATIC void
4461 S_incpush_use_sep(pTHX_ const char *p, STRLEN len, U32 flags)
4462 {
4463     const char *s;
4464     const char *end;
4465     /* This logic has been broken out from S_incpush(). It may be possible to
4466        simplify it.  */
4467
4468     PERL_ARGS_ASSERT_INCPUSH_USE_SEP;
4469
4470     if (!len)
4471         len = strlen(p);
4472
4473     end = p + len;
4474
4475     /* Break at all separators */
4476     while ((s = (const char*)memchr(p, PERLLIB_SEP, end - p))) {
4477         if (s == p) {
4478             /* skip any consecutive separators */
4479
4480             /* Uncomment the next line for PATH semantics */
4481             /* But you'll need to write tests */
4482             /* av_push(GvAVn(PL_incgv), newSVpvs(".")); */
4483         } else {
4484             incpush(p, (STRLEN)(s - p), flags);
4485         }
4486         p = s + 1;
4487     }
4488     if (p != end)
4489         incpush(p, (STRLEN)(end - p), flags);
4490
4491 }
4492
4493 void
4494 Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
4495 {
4496     dVAR;
4497     SV *atsv;
4498     volatile const line_t oldline = PL_curcop ? CopLINE(PL_curcop) : 0;
4499     CV *cv;
4500     STRLEN len;
4501     int ret;
4502     dJMPENV;
4503
4504     PERL_ARGS_ASSERT_CALL_LIST;
4505
4506     while (av_len(paramList) >= 0) {
4507         cv = MUTABLE_CV(av_shift(paramList));
4508         if (PL_savebegin) {
4509             if (paramList == PL_beginav) {
4510                 /* save PL_beginav for compiler */
4511                 Perl_av_create_and_push(aTHX_ &PL_beginav_save, MUTABLE_SV(cv));
4512             }
4513             else if (paramList == PL_checkav) {
4514                 /* save PL_checkav for compiler */
4515                 Perl_av_create_and_push(aTHX_ &PL_checkav_save, MUTABLE_SV(cv));
4516             }
4517             else if (paramList == PL_unitcheckav) {
4518                 /* save PL_unitcheckav for compiler */
4519                 Perl_av_create_and_push(aTHX_ &PL_unitcheckav_save, MUTABLE_SV(cv));
4520             }
4521         } else {
4522             if (!PL_madskills)
4523                 SAVEFREESV(cv);
4524         }
4525         JMPENV_PUSH(ret);
4526         switch (ret) {
4527         case 0:
4528 #ifdef PERL_MAD
4529             if (PL_madskills)
4530                 PL_madskills |= 16384;
4531 #endif
4532             CALL_LIST_BODY(cv);
4533 #ifdef PERL_MAD
4534             if (PL_madskills)
4535                 PL_madskills &= ~16384;
4536 #endif
4537             atsv = ERRSV;
4538             (void)SvPV_const(atsv, len);
4539             if (len) {
4540                 PL_curcop = &PL_compiling;
4541                 CopLINE_set(PL_curcop, oldline);
4542                 if (paramList == PL_beginav)
4543                     sv_catpvs(atsv, "BEGIN failed--compilation aborted");
4544                 else
4545                     Perl_sv_catpvf(aTHX_ atsv,
4546                                    "%s failed--call queue aborted",
4547                                    paramList == PL_checkav ? "CHECK"
4548                                    : paramList == PL_initav ? "INIT"
4549                                    : paramList == PL_unitcheckav ? "UNITCHECK"
4550                                    : "END");
4551                 while (PL_scopestack_ix > oldscope)
4552                     LEAVE;
4553                 JMPENV_POP;
4554                 Perl_croak(aTHX_ "%"SVf"", SVfARG(atsv));
4555             }
4556             break;
4557         case 1:
4558             STATUS_ALL_FAILURE;
4559             /* FALL THROUGH */
4560         case 2:
4561             /* my_exit() was called */
4562             while (PL_scopestack_ix > oldscope)
4563                 LEAVE;
4564             FREETMPS;
4565             PL_curstash = PL_defstash;
4566             PL_curcop = &PL_compiling;
4567             CopLINE_set(PL_curcop, oldline);
4568             JMPENV_POP;
4569             if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED)) {
4570                 if (paramList == PL_beginav)
4571                     Perl_croak(aTHX_ "BEGIN failed--compilation aborted");
4572                 else
4573                     Perl_croak(aTHX_ "%s failed--call queue aborted",
4574                                paramList == PL_checkav ? "CHECK"
4575                                : paramList == PL_initav ? "INIT"
4576                                : paramList == PL_unitcheckav ? "UNITCHECK"
4577                                : "END");
4578             }
4579             my_exit_jump();
4580             /* NOTREACHED */
4581         case 3:
4582             if (PL_restartop) {
4583                 PL_curcop = &PL_compiling;
4584                 CopLINE_set(PL_curcop, oldline);
4585                 JMPENV_JUMP(3);
4586             }
4587             PerlIO_printf(Perl_error_log, "panic: restartop\n");
4588             FREETMPS;
4589             break;
4590         }
4591         JMPENV_POP;
4592     }
4593 }
4594
4595 void
4596 Perl_my_exit(pTHX_ U32 status)
4597 {
4598     dVAR;
4599     switch (status) {
4600     case 0:
4601         STATUS_ALL_SUCCESS;
4602         break;
4603     case 1:
4604         STATUS_ALL_FAILURE;
4605         break;
4606     default:
4607         STATUS_EXIT_SET(status);
4608         break;
4609     }
4610     my_exit_jump();
4611 }
4612
4613 void
4614 Perl_my_failure_exit(pTHX)
4615 {
4616     dVAR;
4617 #ifdef VMS
4618      /* We have been called to fall on our sword.  The desired exit code
4619       * should be already set in STATUS_UNIX, but could be shifted over
4620       * by 8 bits.  STATUS_UNIX_EXIT_SET will handle the cases where a
4621       * that code is set.
4622       *
4623       * If an error code has not been set, then force the issue.
4624       */
4625     if (MY_POSIX_EXIT) {
4626
4627         /* According to the die_exit.t tests, if errno is non-zero */
4628         /* It should be used for the error status. */
4629
4630         if (errno == EVMSERR) {
4631             STATUS_NATIVE = vaxc$errno;
4632         } else {
4633
4634             /* According to die_exit.t tests, if the child_exit code is */
4635             /* also zero, then we need to exit with a code of 255 */
4636             if ((errno != 0) && (errno < 256))
4637                 STATUS_UNIX_EXIT_SET(errno);
4638             else if (STATUS_UNIX < 255) {
4639                 STATUS_UNIX_EXIT_SET(255);
4640             }
4641
4642         }
4643
4644         /* The exit code could have been set by $? or vmsish which
4645          * means that it may not have fatal set.  So convert
4646          * success/warning codes to fatal with out changing
4647          * the POSIX status code.  The severity makes VMS native
4648          * status handling work, while UNIX mode programs use the
4649          * the POSIX exit codes.
4650          */
4651          if ((STATUS_NATIVE & (STS$K_SEVERE|STS$K_ERROR)) == 0) {
4652             STATUS_NATIVE &= STS$M_COND_ID;
4653             STATUS_NATIVE |= STS$K_ERROR | STS$M_INHIB_MSG;
4654          }
4655     }
4656     else {
4657         /* Traditionally Perl on VMS always expects a Fatal Error. */
4658         if (vaxc$errno & 1) {
4659
4660             /* So force success status to failure */
4661             if (STATUS_NATIVE & 1)
4662                 STATUS_ALL_FAILURE;
4663         }
4664         else {
4665             if (!vaxc$errno) {
4666                 STATUS_UNIX = EINTR; /* In case something cares */
4667                 STATUS_ALL_FAILURE;
4668             }
4669             else {
4670                 int severity;
4671                 STATUS_NATIVE = vaxc$errno; /* Should already be this */
4672
4673                 /* Encode the severity code */
4674                 severity = STATUS_NATIVE & STS$M_SEVERITY;
4675                 STATUS_UNIX = (severity ? severity : 1) << 8;
4676
4677                 /* Perl expects this to be a fatal error */
4678                 if (severity != STS$K_SEVERE)
4679                     STATUS_ALL_FAILURE;
4680             }
4681         }
4682     }
4683
4684 #else
4685     int exitstatus;
4686     if (errno & 255)
4687         STATUS_UNIX_SET(errno);
4688     else {
4689         exitstatus = STATUS_UNIX >> 8;
4690         if (exitstatus & 255)
4691             STATUS_UNIX_SET(exitstatus);
4692         else
4693             STATUS_UNIX_SET(255);
4694     }
4695 #endif
4696     my_exit_jump();
4697 }
4698
4699 STATIC void
4700 S_my_exit_jump(pTHX)
4701 {
4702     dVAR;
4703
4704     if (PL_e_script) {
4705         SvREFCNT_dec(PL_e_script);
4706         PL_e_script = NULL;
4707     }
4708
4709     POPSTACK_TO(PL_mainstack);
4710     dounwind(-1);
4711     LEAVE_SCOPE(0);
4712
4713     JMPENV_JUMP(2);
4714 }
4715
4716 static I32
4717 read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen)
4718 {
4719     dVAR;
4720     const char * const p  = SvPVX_const(PL_e_script);
4721     const char *nl = strchr(p, '\n');
4722
4723     PERL_UNUSED_ARG(idx);
4724     PERL_UNUSED_ARG(maxlen);
4725
4726     nl = (nl) ? nl+1 : SvEND(PL_e_script);
4727     if (nl-p == 0) {
4728         filter_del(read_e_script);
4729         return 0;
4730     }
4731     sv_catpvn(buf_sv, p, nl-p);
4732     sv_chop(PL_e_script, nl);
4733     return 1;
4734 }
4735
4736 /*
4737  * Local variables:
4738  * c-indentation-style: bsd
4739  * c-basic-offset: 4
4740  * indent-tabs-mode: t
4741  * End:
4742  *
4743  * ex: set ts=8 sts=4 sw=4 noet:
4744  */