perl.c

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