perl.c

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