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