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