perl.c

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