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);
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
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                                 Perl_sv_catpvf(aTHX_ opts_prog,"q%c\t%s\n%c,",
1912                                                0, PL_localpatches[i], 0);
1913                         }
1914                     }
1915 #endif
1916                     Perl_sv_catpvf(aTHX_ opts_prog,
1917                                    "\"  Built under %s\\n",OSNAME);
1918 #ifdef __DATE__
1919 #  ifdef __TIME__
1920                     sv_catpvs(opts_prog,
1921                               "  Compiled at " __DATE__ " " __TIME__ "\\n\"");
1922 #  else
1923                     sv_catpvs(opts_prog, "  Compiled on " __DATE__ "\\n\"");
1924 #  endif
1925 #endif
1926                     sv_catpvs(opts_prog, "; $\"=\"\\n    \"; "
1927                              "@env = map { \"$_=\\\"$ENV{$_}\\\"\" } "
1928                              "sort grep {/^PERL/} keys %ENV; ");
1929 #ifdef __CYGWIN__
1930                     sv_catpvs(opts_prog,
1931                              "push @env, \"CYGWIN=\\\"$ENV{CYGWIN}\\\"\";");
1932 #endif
1933                     sv_catpvs(opts_prog,
1934                              "print \"  \\%ENV:\\n    @env\\n\" if @env;"
1935                              "print \"  \\@INC:\\n    @INC\\n\";");
1936                 }
1937                 else {
1938                     ++s;
1939                     opts_prog = Perl_newSVpvf(aTHX_
1940                                               "Config::config_vars(qw%c%s%c)",
1941                                               0, s, 0);
1942                     s += strlen(s);
1943                 }
1944                 av_push(PL_preambleav, opts_prog);
1945                 /* don't look for script or read stdin */
1946                 scriptname = BIT_BUCKET;
1947                 goto reswitch;
1948             }
1949         case 'x':
1950             PL_doextract = TRUE;
1951             s++;
1952             if (*s)
1953                 cddir = s;
1954             break;
1955         case 0:
1956             break;
1957         case '-':
1958             if (!*++s || isSPACE(*s)) {
1959                 argc--,argv++;
1960                 goto switch_end;
1961             }
1962             /* catch use of gnu style long options */
1963             if (strEQ(s, "version")) {
1964                 s = (char *)"v";
1965                 goto reswitch;
1966             }
1967             if (strEQ(s, "help")) {
1968                 s = (char *)"h";
1969                 goto reswitch;
1970             }
1971             s--;
1972             /* FALL THROUGH */
1973         default:
1974             Perl_croak(aTHX_ "Unrecognized switch: -%s  (-h will show valid options)",s);
1975         }
1976     }
1977     }
1978
1979   switch_end:
1980
1981     {
1982         char *s;
1983
1984     if (
1985 #ifndef SECURE_INTERNAL_GETENV
1986         !PL_tainting &&
1987 #endif
1988         (s = PerlEnv_getenv("PERL5OPT")))
1989     {
1990         while (isSPACE(*s))
1991             s++;
1992         if (*s == '-' && *(s+1) == 'T') {
1993             CHECK_MALLOC_TOO_LATE_FOR('T');
1994             PL_tainting = TRUE;
1995             PL_taint_warn = FALSE;
1996         }
1997         else {
1998             char *popt_copy = NULL;
1999             while (s && *s) {
2000                 const char *d;
2001                 while (isSPACE(*s))
2002                     s++;
2003                 if (*s == '-') {
2004                     s++;
2005                     if (isSPACE(*s))
2006                         continue;
2007                 }
2008                 d = s;
2009                 if (!*s)
2010                     break;
2011                 if (!strchr("CDIMUdmtw", *s))
2012                     Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s);
2013                 while (++s && *s) {
2014                     if (isSPACE(*s)) {
2015                         if (!popt_copy) {
2016                             popt_copy = SvPVX(sv_2mortal(newSVpv(d,0)));
2017                             s = popt_copy + (s - d);
2018                             d = popt_copy;
2019                         }
2020                         *s++ = '\0';
2021                         break;
2022                     }
2023                 }
2024                 if (*d == 't') {
2025                     if( !PL_tainting ) {
2026                         PL_taint_warn = TRUE;
2027                         PL_tainting = TRUE;
2028                     }
2029                 } else {
2030                     moreswitches(d);
2031                 }
2032             }
2033         }
2034     }
2035     }
2036
2037 #ifdef USE_SITECUSTOMIZE
2038     if (!minus_f) {
2039         (void)Perl_av_create_and_unshift_one(aTHX_ &PL_preambleav,
2040                                              Perl_newSVpvf(aTHX_ "BEGIN { do '%s/sitecustomize.pl' }", SITELIB_EXP));
2041     }
2042 #endif
2043
2044     if (!scriptname)
2045         scriptname = argv[0];
2046     if (PL_e_script) {
2047         argc++,argv--;
2048         scriptname = BIT_BUCKET;        /* don't look for script or read stdin */
2049     }
2050     else if (scriptname == NULL) {
2051 #ifdef MSDOS
2052         if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) )
2053             moreswitches("h");
2054 #endif
2055         scriptname = "-";
2056     }
2057
2058     /* Set $^X early so that it can be used for relocatable paths in @INC  */
2059     assert (!PL_tainted);
2060     TAINT;
2061     S_set_caret_X(aTHX);
2062     TAINT_NOT;
2063     init_perllib();
2064
2065     {
2066         bool suidscript = FALSE;
2067
2068 #ifdef DOSUID
2069         const int fdscript =
2070 #endif
2071             open_script(scriptname, dosearch, &suidscript, &rsfp);
2072
2073         validate_suid(validarg, scriptname, fdscript, suidscript,
2074                 linestr_sv, rsfp);
2075
2076 #ifndef PERL_MICRO
2077 #  if defined(SIGCHLD) || defined(SIGCLD)
2078         {
2079 #  ifndef SIGCHLD
2080 #    define SIGCHLD SIGCLD
2081 #  endif
2082             Sighandler_t sigstate = rsignal_state(SIGCHLD);
2083             if (sigstate == (Sighandler_t) SIG_IGN) {
2084                 if (ckWARN(WARN_SIGNAL))
2085                     Perl_warner(aTHX_ packWARN(WARN_SIGNAL),
2086                                 "Can't ignore signal CHLD, forcing to default");
2087                 (void)rsignal(SIGCHLD, (Sighandler_t)SIG_DFL);
2088             }
2089         }
2090 #  endif
2091 #endif
2092
2093         if (PL_doextract
2094 #ifdef MACOS_TRADITIONAL
2095             || gMacPerl_AlwaysExtract
2096 #endif
2097             ) {
2098
2099             /* This will croak if suidscript is true, as -x cannot be used with
2100                setuid scripts.  */
2101             forbid_setid('x', suidscript);
2102             /* Hence you can't get here if suidscript is true */
2103
2104             find_beginning(linestr_sv, rsfp);
2105             if (cddir && PerlDir_chdir( (char *)cddir ) < 0)
2106                 Perl_croak(aTHX_ "Can't chdir to %s",cddir);
2107         }
2108     }
2109
2110     PL_main_cv = PL_compcv = MUTABLE_CV(newSV_type(SVt_PVCV));
2111     CvUNIQUE_on(PL_compcv);
2112
2113     CvPADLIST(PL_compcv) = pad_new(0);
2114
2115     PL_isarev = newHV();
2116
2117     boot_core_PerlIO();
2118     boot_core_UNIVERSAL();
2119     boot_core_xsutils();
2120     boot_core_mro();
2121
2122     if (xsinit)
2123         (*xsinit)(aTHX);        /* in case linked C routines want magical variables */
2124 #ifndef PERL_MICRO
2125 #if defined(VMS) || defined(WIN32) || defined(DJGPP) || defined(__CYGWIN__) || defined(EPOC) || defined(SYMBIAN)
2126     init_os_extras();
2127 #endif
2128 #endif
2129
2130 #ifdef USE_SOCKS
2131 #   ifdef HAS_SOCKS5_INIT
2132     socks5_init(argv[0]);
2133 #   else
2134     SOCKSinit(argv[0]);
2135 #   endif
2136 #endif
2137
2138     init_predump_symbols();
2139     /* init_postdump_symbols not currently designed to be called */
2140     /* more than once (ENV isn't cleared first, for example)     */
2141     /* But running with -u leaves %ENV & @ARGV undefined!    XXX */
2142     if (!PL_do_undump)
2143         init_postdump_symbols(argc,argv,env);
2144
2145     /* PL_unicode is turned on by -C, or by $ENV{PERL_UNICODE},
2146      * or explicitly in some platforms.
2147      * locale.c:Perl_init_i18nl10n() if the environment
2148      * look like the user wants to use UTF-8. */
2149 #if defined(__SYMBIAN32__)
2150     PL_unicode = PERL_UNICODE_STD_FLAG; /* See PERL_SYMBIAN_CONSOLE_UTF8. */
2151 #endif
2152     if (PL_unicode) {
2153          /* Requires init_predump_symbols(). */
2154          if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) {
2155               IO* io;
2156               PerlIO* fp;
2157               SV* sv;
2158
2159               /* Turn on UTF-8-ness on STDIN, STDOUT, STDERR
2160                * and the default open disciplines. */
2161               if ((PL_unicode & PERL_UNICODE_STDIN_FLAG) &&
2162                   PL_stdingv  && (io = GvIO(PL_stdingv)) &&
2163                   (fp = IoIFP(io)))
2164                    PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
2165               if ((PL_unicode & PERL_UNICODE_STDOUT_FLAG) &&
2166                   PL_defoutgv && (io = GvIO(PL_defoutgv)) &&
2167                   (fp = IoOFP(io)))
2168                    PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
2169               if ((PL_unicode & PERL_UNICODE_STDERR_FLAG) &&
2170                   PL_stderrgv && (io = GvIO(PL_stderrgv)) &&
2171                   (fp = IoOFP(io)))
2172                    PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
2173               if ((PL_unicode & PERL_UNICODE_INOUT_FLAG) &&
2174                   (sv = GvSV(gv_fetchpvs("\017PEN", GV_ADD|GV_NOTQUAL,
2175                                          SVt_PV)))) {
2176                    U32 in  = PL_unicode & PERL_UNICODE_IN_FLAG;
2177                    U32 out = PL_unicode & PERL_UNICODE_OUT_FLAG;
2178                    if (in) {
2179                         if (out)
2180                              sv_setpvs(sv, ":utf8\0:utf8");
2181                         else
2182                              sv_setpvs(sv, ":utf8\0");
2183                    }
2184                    else if (out)
2185                         sv_setpvs(sv, "\0:utf8");
2186                    SvSETMAGIC(sv);
2187               }
2188          }
2189     }
2190
2191     {
2192         const char *s;
2193     if ((s = PerlEnv_getenv("PERL_SIGNALS"))) {
2194          if (strEQ(s, "unsafe"))
2195               PL_signals |=  PERL_SIGNALS_UNSAFE_FLAG;
2196          else if (strEQ(s, "safe"))
2197               PL_signals &= ~PERL_SIGNALS_UNSAFE_FLAG;
2198          else
2199               Perl_croak(aTHX_ "PERL_SIGNALS illegal: \"%s\"", s);
2200     }
2201     }
2202
2203 #ifdef PERL_MAD
2204     {
2205         const char *s;
2206     if ((s = PerlEnv_getenv("PERL_XMLDUMP"))) {
2207         PL_madskills = 1;
2208         PL_minus_c = 1;
2209         if (!s || !s[0])
2210             PL_xmlfp = PerlIO_stdout();
2211         else {
2212             PL_xmlfp = PerlIO_open(s, "w");
2213             if (!PL_xmlfp)
2214                 Perl_croak(aTHX_ "Can't open %s", s);
2215         }
2216         my_setenv("PERL_XMLDUMP", NULL);        /* hide from subprocs */
2217     }
2218     }
2219
2220     {
2221         const char *s;
2222     if ((s = PerlEnv_getenv("PERL_MADSKILLS"))) {
2223         PL_madskills = atoi(s);
2224         my_setenv("PERL_MADSKILLS", NULL);      /* hide from subprocs */
2225     }
2226     }
2227 #endif
2228
2229     lex_start(linestr_sv, rsfp, TRUE);
2230     PL_subname = newSVpvs("main");
2231
2232     if (add_read_e_script)
2233         filter_add(read_e_script, NULL);
2234
2235     /* now parse the script */
2236
2237     SETERRNO(0,SS_NORMAL);
2238 #ifdef MACOS_TRADITIONAL
2239     if (gMacPerl_SyntaxError = (yyparse() || PL_parser->error_count)) {
2240         if (PL_minus_c)
2241             Perl_croak(aTHX_ "%s had compilation errors.\n", MacPerl_MPWFileName(PL_origfilename));
2242         else {
2243             Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
2244                        MacPerl_MPWFileName(PL_origfilename));
2245         }
2246     }
2247 #else
2248     if (yyparse() || PL_parser->error_count) {
2249         if (PL_minus_c)
2250             Perl_croak(aTHX_ "%s had compilation errors.\n", PL_origfilename);
2251         else {
2252             Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
2253                        PL_origfilename);
2254         }
2255     }
2256 #endif
2257     CopLINE_set(PL_curcop, 0);
2258     PL_curstash = PL_defstash;
2259     if (PL_e_script) {
2260         SvREFCNT_dec(PL_e_script);
2261         PL_e_script = NULL;
2262     }
2263
2264     if (PL_do_undump)
2265         my_unexec();
2266
2267     if (isWARN_ONCE) {
2268         SAVECOPFILE(PL_curcop);
2269         SAVECOPLINE(PL_curcop);
2270         gv_check(PL_defstash);
2271     }
2272
2273     LEAVE;
2274     FREETMPS;
2275
2276 #ifdef MYMALLOC
2277     {
2278         const char *s;
2279     if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
2280         dump_mstats("after compilation:");
2281     }
2282 #endif
2283
2284     ENTER;
2285     PL_restartop = 0;
2286     return NULL;
2287 }
2288
2289 /*
2290 =for apidoc perl_run
2291
2292 Tells a Perl interpreter to run.  See L<perlembed>.
2293
2294 =cut
2295 */
2296
2297 int
2298 perl_run(pTHXx)
2299 {
2300     dVAR;
2301     I32 oldscope;
2302     int ret = 0;
2303     dJMPENV;
2304
2305     PERL_ARGS_ASSERT_PERL_RUN;
2306 #ifndef MULTIPLICITY
2307     PERL_UNUSED_ARG(my_perl);
2308 #endif
2309
2310     oldscope = PL_scopestack_ix;
2311 #ifdef VMS
2312     VMSISH_HUSHED = 0;
2313 #endif
2314
2315     JMPENV_PUSH(ret);
2316     switch (ret) {
2317     case 1:
2318         cxstack_ix = -1;                /* start context stack again */
2319         goto redo_body;
2320     case 0:                             /* normal completion */
2321  redo_body:
2322         run_body(oldscope);
2323         /* FALL THROUGH */
2324     case 2:                             /* my_exit() */
2325         while (PL_scopestack_ix > oldscope)
2326             LEAVE;
2327         FREETMPS;
2328         PL_curstash = PL_defstash;
2329         if (!(PL_exit_flags & PERL_EXIT_DESTRUCT_END) &&
2330             PL_endav && !PL_minus_c)
2331             call_list(oldscope, PL_endav);
2332 #ifdef MYMALLOC
2333         if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
2334             dump_mstats("after execution:  ");
2335 #endif
2336         ret = STATUS_EXIT;
2337         break;
2338     case 3:
2339         if (PL_restartop) {
2340             POPSTACK_TO(PL_mainstack);
2341             goto redo_body;
2342         }
2343         PerlIO_printf(Perl_error_log, "panic: restartop\n");
2344         FREETMPS;
2345         ret = 1;
2346         break;
2347     }
2348
2349     JMPENV_POP;
2350     return ret;
2351 }
2352
2353 STATIC void
2354 S_run_body(pTHX_ I32 oldscope)
2355 {
2356     dVAR;
2357     DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
2358                     PL_sawampersand ? "Enabling" : "Omitting"));
2359
2360     if (!PL_restartop) {
2361 #ifdef PERL_MAD
2362         if (PL_xmlfp) {
2363             xmldump_all();
2364             exit(0);    /* less likely to core dump than my_exit(0) */
2365         }
2366 #endif
2367         DEBUG_x(dump_all());
2368 #ifdef DEBUGGING
2369         if (!DEBUG_q_TEST)
2370           PERL_DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
2371 #endif
2372
2373         if (PL_minus_c) {
2374 #ifdef MACOS_TRADITIONAL
2375             PerlIO_printf(Perl_error_log, "%s%s syntax OK\n",
2376                 (gMacPerl_ErrorFormat ? "# " : ""),
2377                 MacPerl_MPWFileName(PL_origfilename));
2378 #else
2379             PerlIO_printf(Perl_error_log, "%s syntax OK\n", PL_origfilename);
2380 #endif
2381             my_exit(0);
2382         }
2383         if (PERLDB_SINGLE && PL_DBsingle)
2384             sv_setiv(PL_DBsingle, 1);
2385         if (PL_initav)
2386             call_list(oldscope, PL_initav);
2387 #ifdef PERL_DEBUG_READONLY_OPS
2388         Perl_pending_Slabs_to_ro(aTHX);
2389 #endif
2390     }
2391
2392     /* do it */
2393
2394     if (PL_restartop) {
2395         PL_op = PL_restartop;
2396         PL_restartop = 0;
2397         CALLRUNOPS(aTHX);
2398     }
2399     else if (PL_main_start) {
2400         CvDEPTH(PL_main_cv) = 1;
2401         PL_op = PL_main_start;
2402         CALLRUNOPS(aTHX);
2403     }
2404     my_exit(0);
2405     /* NOTREACHED */
2406 }
2407
2408 /*
2409 =head1 SV Manipulation Functions
2410
2411 =for apidoc p||get_sv
2412
2413 Returns the SV of the specified Perl scalar.  If C<create> is set and the
2414 Perl variable does not exist then it will be created.  If C<create> is not
2415 set and the variable does not exist then NULL is returned.
2416
2417 =cut
2418 */
2419
2420 SV*
2421 Perl_get_sv(pTHX_ const char *name, I32 create)
2422 {
2423     GV *gv;
2424
2425     PERL_ARGS_ASSERT_GET_SV;
2426
2427     gv = gv_fetchpv(name, create, SVt_PV);
2428     if (gv)
2429         return GvSV(gv);
2430     return NULL;
2431 }
2432
2433 /*
2434 =head1 Array Manipulation Functions
2435
2436 =for apidoc p||get_av
2437
2438 Returns the AV of the specified Perl array.  If C<create> is set and the
2439 Perl variable does not exist then it will be created.  If C<create> is not
2440 set and the variable does not exist then NULL is returned.
2441
2442 =cut
2443 */
2444
2445 AV*
2446 Perl_get_av(pTHX_ const char *name, I32 create)
2447 {
2448     GV* const gv = gv_fetchpv(name, create, SVt_PVAV);
2449
2450     PERL_ARGS_ASSERT_GET_AV;
2451
2452     if (create)
2453         return GvAVn(gv);
2454     if (gv)
2455         return GvAV(gv);
2456     return NULL;
2457 }
2458
2459 /*
2460 =head1 Hash Manipulation Functions
2461
2462 =for apidoc p||get_hv
2463
2464 Returns the HV of the specified Perl hash.  If C<create> is set and the
2465 Perl variable does not exist then it will be created.  If C<create> is not
2466 set and the variable does not exist then NULL is returned.
2467
2468 =cut
2469 */
2470
2471 HV*
2472 Perl_get_hv(pTHX_ const char *name, I32 create)
2473 {
2474     GV* const gv = gv_fetchpv(name, create, SVt_PVHV);
2475
2476     PERL_ARGS_ASSERT_GET_HV;
2477
2478     if (create)
2479         return GvHVn(gv);
2480     if (gv)
2481         return GvHV(gv);
2482     return NULL;
2483 }
2484
2485 /*
2486 =head1 CV Manipulation Functions
2487
2488 =for apidoc p||get_cvn_flags
2489
2490 Returns the CV of the specified Perl subroutine.  C<flags> are passed to
2491 C<gv_fetchpvn_flags>. If C<GV_ADD> is set and the Perl subroutine does not
2492 exist then it will be declared (which has the same effect as saying
2493 C<sub name;>).  If C<GV_ADD> is not set and the subroutine does not exist
2494 then NULL is returned.
2495
2496 =for apidoc p||get_cv
2497
2498 Uses C<strlen> to get the length of C<name>, then calls C<get_cvn_flags>.
2499
2500 =cut
2501 */
2502
2503 CV*
2504 Perl_get_cvn_flags(pTHX_ const char *name, STRLEN len, I32 flags)
2505 {
2506     GV* const gv = gv_fetchpvn_flags(name, len, flags, SVt_PVCV);
2507     /* XXX this is probably not what they think they're getting.
2508      * It has the same effect as "sub name;", i.e. just a forward
2509      * declaration! */
2510
2511     PERL_ARGS_ASSERT_GET_CVN_FLAGS;
2512
2513     if ((flags & ~GV_NOADD_MASK) && !GvCVu(gv)) {
2514         SV *const sv = newSVpvn_flags(name, len, flags & SVf_UTF8);
2515         return newSUB(start_subparse(FALSE, 0),
2516                       newSVOP(OP_CONST, 0, sv),
2517                       NULL, NULL);
2518     }
2519     if (gv)
2520         return GvCVu(gv);
2521     return NULL;
2522 }
2523
2524 CV*
2525 Perl_get_cv(pTHX_ const char *name, I32 flags)
2526 {
2527     PERL_ARGS_ASSERT_GET_CV;
2528
2529     return get_cvn_flags(name, strlen(name), flags);
2530 }
2531
2532 /* Be sure to refetch the stack pointer after calling these routines. */
2533
2534 /*
2535
2536 =head1 Callback Functions
2537
2538 =for apidoc p||call_argv
2539
2540 Performs a callback to the specified Perl sub.  See L<perlcall>.
2541
2542 =cut
2543 */
2544
2545 I32
2546 Perl_call_argv(pTHX_ const char *sub_name, I32 flags, register char **argv)
2547
2548                         /* See G_* flags in cop.h */
2549                         /* null terminated arg list */
2550 {
2551     dVAR;
2552     dSP;
2553
2554     PERL_ARGS_ASSERT_CALL_ARGV;
2555
2556     PUSHMARK(SP);
2557     if (argv) {
2558         while (*argv) {
2559             mXPUSHs(newSVpv(*argv,0));
2560             argv++;
2561         }
2562         PUTBACK;
2563     }
2564     return call_pv(sub_name, flags);
2565 }
2566
2567 /*
2568 =for apidoc p||call_pv
2569
2570 Performs a callback to the specified Perl sub.  See L<perlcall>.
2571
2572 =cut
2573 */
2574
2575 I32
2576 Perl_call_pv(pTHX_ const char *sub_name, I32 flags)
2577                         /* name of the subroutine */
2578                         /* See G_* flags in cop.h */
2579 {
2580     PERL_ARGS_ASSERT_CALL_PV;
2581
2582     return call_sv(MUTABLE_SV(get_cv(sub_name, TRUE)), flags);
2583 }
2584
2585 /*
2586 =for apidoc p||call_method
2587
2588 Performs a callback to the specified Perl method.  The blessed object must
2589 be on the stack.  See L<perlcall>.
2590
2591 =cut
2592 */
2593
2594 I32
2595 Perl_call_method(pTHX_ const char *methname, I32 flags)
2596                         /* name of the subroutine */
2597                         /* See G_* flags in cop.h */
2598 {
2599     PERL_ARGS_ASSERT_CALL_METHOD;
2600
2601     return call_sv(sv_2mortal(newSVpv(methname,0)), flags | G_METHOD);
2602 }
2603
2604 /* May be called with any of a CV, a GV, or an SV containing the name. */
2605 /*
2606 =for apidoc p||call_sv
2607
2608 Performs a callback to the Perl sub whose name is in the SV.  See
2609 L<perlcall>.
2610
2611 =cut
2612 */
2613
2614 I32
2615 Perl_call_sv(pTHX_ SV *sv, VOL I32 flags)
2616                         /* See G_* flags in cop.h */
2617 {
2618     dVAR; dSP;
2619     LOGOP myop;         /* fake syntax tree node */
2620     UNOP method_op;
2621     I32 oldmark;
2622     VOL I32 retval = 0;
2623     I32 oldscope;
2624     bool oldcatch = CATCH_GET;
2625     int ret;
2626     OP* const oldop = PL_op;
2627     dJMPENV;
2628
2629     PERL_ARGS_ASSERT_CALL_SV;
2630
2631     if (flags & G_DISCARD) {
2632         ENTER;
2633         SAVETMPS;
2634     }
2635     if (!(flags & G_WANT)) {
2636         /* Backwards compatibility - as G_SCALAR was 0, it could be omitted.
2637          */
2638         flags |= G_SCALAR;
2639     }
2640
2641     Zero(&myop, 1, LOGOP);
2642     myop.op_next = NULL;
2643     if (!(flags & G_NOARGS))
2644         myop.op_flags |= OPf_STACKED;
2645     myop.op_flags |= OP_GIMME_REVERSE(flags);
2646     SAVEOP();
2647     PL_op = (OP*)&myop;
2648
2649     EXTEND(PL_stack_sp, 1);
2650     *++PL_stack_sp = sv;
2651     oldmark = TOPMARK;
2652     oldscope = PL_scopestack_ix;
2653
2654     if (PERLDB_SUB && PL_curstash != PL_debstash
2655            /* Handle first BEGIN of -d. */
2656           && (PL_DBcv || (PL_DBcv = GvCV(PL_DBsub)))
2657            /* Try harder, since this may have been a sighandler, thus
2658             * curstash may be meaningless. */
2659           && (SvTYPE(sv) != SVt_PVCV || CvSTASH((const CV *)sv) != PL_debstash)
2660           && !(flags & G_NODEBUG))
2661         PL_op->op_private |= OPpENTERSUB_DB;
2662
2663     if (flags & G_METHOD) {
2664         Zero(&method_op, 1, UNOP);
2665         method_op.op_next = PL_op;
2666         method_op.op_ppaddr = PL_ppaddr[OP_METHOD];
2667         method_op.op_type = OP_METHOD;
2668         myop.op_ppaddr = PL_ppaddr[OP_ENTERSUB];
2669         myop.op_type = OP_ENTERSUB;
2670         PL_op = (OP*)&method_op;
2671     }
2672
2673     if (!(flags & G_EVAL)) {
2674         CATCH_SET(TRUE);
2675         CALL_BODY_SUB((OP*)&myop);
2676         retval = PL_stack_sp - (PL_stack_base + oldmark);
2677         CATCH_SET(oldcatch);
2678     }
2679     else {
2680         myop.op_other = (OP*)&myop;
2681         PL_markstack_ptr--;
2682         create_eval_scope(flags|G_FAKINGEVAL);
2683         PL_markstack_ptr++;
2684
2685         JMPENV_PUSH(ret);
2686
2687         switch (ret) {
2688         case 0:
2689  redo_body:
2690             CALL_BODY_SUB((OP*)&myop);
2691             retval = PL_stack_sp - (PL_stack_base + oldmark);
2692             if (!(flags & G_KEEPERR)) {
2693                 CLEAR_ERRSV();
2694             }
2695             break;
2696         case 1:
2697             STATUS_ALL_FAILURE;
2698             /* FALL THROUGH */
2699         case 2:
2700             /* my_exit() was called */
2701             PL_curstash = PL_defstash;
2702             FREETMPS;
2703             JMPENV_POP;
2704             if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
2705                 Perl_croak(aTHX_ "Callback called exit");
2706             my_exit_jump();
2707             /* NOTREACHED */
2708         case 3:
2709             if (PL_restartop) {
2710                 PL_op = PL_restartop;
2711                 PL_restartop = 0;
2712                 goto redo_body;
2713             }
2714             PL_stack_sp = PL_stack_base + oldmark;
2715             if ((flags & G_WANT) == G_ARRAY)
2716                 retval = 0;
2717             else {
2718                 retval = 1;
2719                 *++PL_stack_sp = &PL_sv_undef;
2720             }
2721             break;
2722         }
2723
2724         if (PL_scopestack_ix > oldscope)
2725             delete_eval_scope();
2726         JMPENV_POP;
2727     }
2728
2729     if (flags & G_DISCARD) {
2730         PL_stack_sp = PL_stack_base + oldmark;
2731         retval = 0;
2732         FREETMPS;
2733         LEAVE;
2734     }
2735     PL_op = oldop;
2736     return retval;
2737 }
2738
2739 /* Eval a string. The G_EVAL flag is always assumed. */
2740
2741 /*
2742 =for apidoc p||eval_sv
2743
2744 Tells Perl to C<eval> the string in the SV.
2745
2746 =cut
2747 */
2748
2749 I32
2750 Perl_eval_sv(pTHX_ SV *sv, I32 flags)
2751
2752                         /* See G_* flags in cop.h */
2753 {
2754     dVAR;
2755     dSP;
2756     UNOP myop;          /* fake syntax tree node */
2757     VOL I32 oldmark = SP - PL_stack_base;
2758     VOL I32 retval = 0;
2759     int ret;
2760     OP* const oldop = PL_op;
2761     dJMPENV;
2762
2763     PERL_ARGS_ASSERT_EVAL_SV;
2764
2765     if (flags & G_DISCARD) {
2766         ENTER;
2767         SAVETMPS;
2768     }
2769
2770     SAVEOP();
2771     PL_op = (OP*)&myop;
2772     Zero(PL_op, 1, UNOP);
2773     EXTEND(PL_stack_sp, 1);
2774     *++PL_stack_sp = sv;
2775
2776     if (!(flags & G_NOARGS))
2777         myop.op_flags = OPf_STACKED;
2778     myop.op_next = NULL;
2779     myop.op_type = OP_ENTEREVAL;
2780     myop.op_flags |= OP_GIMME_REVERSE(flags);
2781     if (flags & G_KEEPERR)
2782         myop.op_flags |= OPf_SPECIAL;
2783
2784     /* fail now; otherwise we could fail after the JMPENV_PUSH but
2785      * before a PUSHEVAL, which corrupts the stack after a croak */
2786     TAINT_PROPER("eval_sv()");
2787
2788     JMPENV_PUSH(ret);
2789     switch (ret) {
2790     case 0:
2791  redo_body:
2792         CALL_BODY_EVAL((OP*)&myop);
2793         retval = PL_stack_sp - (PL_stack_base + oldmark);
2794         if (!(flags & G_KEEPERR)) {
2795             CLEAR_ERRSV();
2796         }
2797         break;
2798     case 1:
2799         STATUS_ALL_FAILURE;
2800         /* FALL THROUGH */
2801     case 2:
2802         /* my_exit() was called */
2803         PL_curstash = PL_defstash;
2804         FREETMPS;
2805         JMPENV_POP;
2806         if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
2807             Perl_croak(aTHX_ "Callback called exit");
2808         my_exit_jump();
2809         /* NOTREACHED */
2810     case 3:
2811         if (PL_restartop) {
2812             PL_op = PL_restartop;
2813             PL_restartop = 0;
2814             goto redo_body;
2815         }
2816         PL_stack_sp = PL_stack_base + oldmark;
2817         if ((flags & G_WANT) == G_ARRAY)
2818             retval = 0;
2819         else {
2820             retval = 1;
2821             *++PL_stack_sp = &PL_sv_undef;
2822         }
2823         break;
2824     }
2825
2826     JMPENV_POP;
2827     if (flags & G_DISCARD) {
2828         PL_stack_sp = PL_stack_base + oldmark;
2829         retval = 0;
2830         FREETMPS;
2831         LEAVE;
2832     }
2833     PL_op = oldop;
2834     return retval;
2835 }
2836
2837 /*
2838 =for apidoc p||eval_pv
2839
2840 Tells Perl to C<eval> the given string and return an SV* result.
2841
2842 =cut
2843 */
2844
2845 SV*
2846 Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error)
2847 {
2848     dVAR;
2849     dSP;
2850     SV* sv = newSVpv(p, 0);
2851
2852     PERL_ARGS_ASSERT_EVAL_PV;
2853
2854     eval_sv(sv, G_SCALAR);
2855     SvREFCNT_dec(sv);
2856
2857     SPAGAIN;
2858     sv = POPs;
2859     PUTBACK;
2860
2861     if (croak_on_error && SvTRUE(ERRSV)) {
2862         Perl_croak(aTHX_ "%s", SvPVx_nolen_const(ERRSV));
2863     }
2864
2865     return sv;
2866 }
2867
2868 /* Require a module. */
2869
2870 /*
2871 =head1 Embedding Functions
2872
2873 =for apidoc p||require_pv
2874
2875 Tells Perl to C<require> the file named by the string argument.  It is
2876 analogous to the Perl code C<eval "require '$file'">.  It's even
2877 implemented that way; consider using load_module instead.
2878
2879 =cut */
2880
2881 void
2882 Perl_require_pv(pTHX_ const char *pv)
2883 {
2884     dVAR;
2885     dSP;
2886     SV* sv;
2887
2888     PERL_ARGS_ASSERT_REQUIRE_PV;
2889
2890     PUSHSTACKi(PERLSI_REQUIRE);
2891     PUTBACK;
2892     sv = Perl_newSVpvf(aTHX_ "require q%c%s%c", 0, pv, 0);
2893     eval_sv(sv_2mortal(sv), G_DISCARD);
2894     SPAGAIN;
2895     POPSTACK;
2896 }
2897
2898 STATIC void
2899 S_usage(pTHX_ const char *name)         /* XXX move this out into a module ? */
2900 {
2901     /* This message really ought to be max 23 lines.
2902      * Removed -h because the user already knows that option. Others? */
2903
2904     static const char * const usage_msg[] = {
2905 "-0[octal]         specify record separator (\\0, if no argument)",
2906 "-a                autosplit mode with -n or -p (splits $_ into @F)",
2907 "-C[number/list]   enables the listed Unicode features",
2908 "-c                check syntax only (runs BEGIN and CHECK blocks)",
2909 "-d[:debugger]     run program under debugger",
2910 "-D[number/list]   set debugging flags (argument is a bit mask or alphabets)",
2911 "-e program        one line of program (several -e's allowed, omit programfile)",
2912 "-E program        like -e, but enables all optional features",
2913 "-f                don't do $sitelib/sitecustomize.pl at startup",
2914 "-F/pattern/       split() pattern for -a switch (//'s are optional)",
2915 "-i[extension]     edit <> files in place (makes backup if extension supplied)",
2916 "-Idirectory       specify @INC/#include directory (several -I's allowed)",
2917 "-l[octal]         enable line ending processing, specifies line terminator",
2918 "-[mM][-]module    execute \"use/no module...\" before executing program",
2919 "-n                assume \"while (<>) { ... }\" loop around program",
2920 "-p                assume loop like -n but print line also, like sed",
2921 "-s                enable rudimentary parsing for switches after programfile",
2922 "-S                look for programfile using PATH environment variable",
2923 "-t                enable tainting warnings",
2924 "-T                enable tainting checks",
2925 "-u                dump core after parsing program",
2926 "-U                allow unsafe operations",
2927 "-v                print version, subversion (includes VERY IMPORTANT perl info)",
2928 "-V[:variable]     print configuration summary (or a single Config.pm variable)",
2929 "-w                enable many useful warnings (RECOMMENDED)",
2930 "-W                enable all warnings",
2931 "-x[directory]     strip off text before #!perl line and perhaps cd to directory",
2932 "-X                disable all warnings",
2933 "\n",
2934 NULL
2935 };
2936     const char * const *p = usage_msg;
2937
2938     PERL_ARGS_ASSERT_USAGE;
2939
2940     PerlIO_printf(PerlIO_stdout(),
2941                   "\nUsage: %s [switches] [--] [programfile] [arguments]",
2942                   name);
2943     while (*p)
2944         PerlIO_printf(PerlIO_stdout(), "\n  %s", *p++);
2945 }
2946
2947 /* convert a string of -D options (or digits) into an int.
2948  * sets *s to point to the char after the options */
2949
2950 #ifdef DEBUGGING
2951 int
2952 Perl_get_debug_opts(pTHX_ const char **s, bool givehelp)
2953 {
2954     static const char * const usage_msgd[] = {
2955       " Debugging flag values: (see also -d)",
2956       "  p  Tokenizing and parsing (with v, displays parse stack)",
2957       "  s  Stack snapshots (with v, displays all stacks)",
2958       "  l  Context (loop) stack processing",
2959       "  t  Trace execution",
2960       "  o  Method and overloading resolution",
2961       "  c  String/numeric conversions",
2962       "  P  Print profiling info, source file input state",
2963       "  m  Memory and SV allocation",
2964       "  f  Format processing",
2965       "  r  Regular expression parsing and execution",
2966       "  x  Syntax tree dump",
2967       "  u  Tainting checks",
2968       "  H  Hash dump -- usurps values()",
2969       "  X  Scratchpad allocation",
2970       "  D  Cleaning up",
2971       "  T  Tokenising",
2972       "  R  Include reference counts of dumped variables (eg when using -Ds)",
2973       "  J  Do not s,t,P-debug (Jump over) opcodes within package DB",
2974       "  v  Verbose: use in conjunction with other flags",
2975       "  C  Copy On Write",
2976       "  A  Consistency checks on internal structures",
2977       "  q  quiet - currently only suppresses the 'EXECUTING' message",
2978       NULL
2979     };
2980     int i = 0;
2981
2982     PERL_ARGS_ASSERT_GET_DEBUG_OPTS;
2983
2984     if (isALPHA(**s)) {
2985         /* if adding extra options, remember to update DEBUG_MASK */
2986         static const char debopts[] = "psltocPmfrxuUHXDSTRJvCAq";
2987
2988         for (; isALNUM(**s); (*s)++) {
2989             const char * const d = strchr(debopts,**s);
2990             if (d)
2991                 i |= 1 << (d - debopts);
2992             else if (ckWARN_d(WARN_DEBUGGING))
2993                 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
2994                     "invalid option -D%c, use -D'' to see choices\n", **s);
2995         }
2996     }
2997     else if (isDIGIT(**s)) {
2998         i = atoi(*s);
2999         for (; isALNUM(**s); (*s)++) ;
3000     }
3001     else if (givehelp) {
3002       const char *const *p = usage_msgd;
3003       while (*p) PerlIO_printf(PerlIO_stdout(), "%s\n", *p++);
3004     }
3005 #  ifdef EBCDIC
3006     if ((i & DEBUG_p_FLAG) && ckWARN_d(WARN_DEBUGGING))
3007         Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
3008                 "-Dp not implemented on this platform\n");
3009 #  endif
3010     return i;
3011 }
3012 #endif
3013
3014 /* This routine handles any switches that can be given during run */
3015
3016 const char *
3017 Perl_moreswitches(pTHX_ const char *s)
3018 {
3019     dVAR;
3020     UV rschar;
3021     const char option = *s; /* used to remember option in -m/-M code */
3022
3023     PERL_ARGS_ASSERT_MORESWITCHES;
3024
3025     switch (*s) {
3026     case '0':
3027     {
3028          I32 flags = 0;
3029          STRLEN numlen;
3030
3031          SvREFCNT_dec(PL_rs);
3032          if (s[1] == 'x' && s[2]) {
3033               const char *e = s+=2;
3034               U8 *tmps;
3035
3036               while (*e)
3037                 e++;
3038               numlen = e - s;
3039               flags = PERL_SCAN_SILENT_ILLDIGIT;
3040               rschar = (U32)grok_hex(s, &numlen, &flags, NULL);
3041               if (s + numlen < e) {
3042                    rschar = 0; /* Grandfather -0xFOO as -0 -xFOO. */
3043                    numlen = 0;
3044                    s--;
3045               }
3046               PL_rs = newSVpvs("");
3047               SvGROW(PL_rs, (STRLEN)(UNISKIP(rschar) + 1));
3048               tmps = (U8*)SvPVX(PL_rs);
3049               uvchr_to_utf8(tmps, rschar);
3050               SvCUR_set(PL_rs, UNISKIP(rschar));
3051               SvUTF8_on(PL_rs);
3052          }
3053          else {
3054               numlen = 4;
3055               rschar = (U32)grok_oct(s, &numlen, &flags, NULL);
3056               if (rschar & ~((U8)~0))
3057                    PL_rs = &PL_sv_undef;
3058               else if (!rschar && numlen >= 2)
3059                    PL_rs = newSVpvs("");
3060               else {
3061                    char ch = (char)rschar;
3062                    PL_rs = newSVpvn(&ch, 1);
3063               }
3064          }
3065          sv_setsv(get_sv("/", TRUE), PL_rs);
3066          return s + numlen;
3067     }
3068     case 'C':
3069         s++;
3070         PL_unicode = parse_unicode_opts( (const char **)&s );
3071         if (PL_unicode & PERL_UNICODE_UTF8CACHEASSERT_FLAG)
3072             PL_utf8cache = -1;
3073         return s;
3074     case 'F':
3075         PL_minus_F = TRUE;
3076         PL_splitstr = ++s;
3077         while (*s && !isSPACE(*s)) ++s;
3078         PL_splitstr = savepvn(PL_splitstr, s - PL_splitstr);
3079         return s;
3080     case 'a':
3081         PL_minus_a = TRUE;
3082         s++;
3083         return s;
3084     case 'c':
3085         PL_minus_c = TRUE;
3086         s++;
3087         return s;
3088     case 'd':
3089         forbid_setid('d', FALSE);
3090         s++;
3091
3092         /* -dt indicates to the debugger that threads will be used */
3093         if (*s == 't' && !isALNUM(s[1])) {
3094             ++s;
3095             my_setenv("PERL5DB_THREADED", "1");
3096         }
3097
3098         /* The following permits -d:Mod to accepts arguments following an =
3099            in the fashion that -MSome::Mod does. */
3100         if (*s == ':' || *s == '=') {
3101             const char *start = ++s;
3102             const char *const end = s + strlen(s);
3103             SV * const sv = newSVpvs("use Devel::");
3104
3105             /* We now allow -d:Module=Foo,Bar */
3106             while(isALNUM(*s) || *s==':') ++s;
3107             if (*s != '=')
3108                 sv_catpvn(sv, start, end - start);
3109             else {
3110                 sv_catpvn(sv, start, s-start);
3111                 /* Don't use NUL as q// delimiter here, this string goes in the
3112                  * environment. */
3113                 Perl_sv_catpvf(aTHX_ sv, " split(/,/,q{%s});", ++s);
3114             }
3115             s = end;
3116             my_setenv("PERL5DB", SvPV_nolen_const(sv));
3117             SvREFCNT_dec(sv);
3118         }
3119         if (!PL_perldb) {
3120             PL_perldb = PERLDB_ALL;
3121             init_debugger();
3122         }
3123         return s;
3124     case 'D':
3125     {
3126 #ifdef DEBUGGING
3127         forbid_setid('D', FALSE);
3128         s++;
3129         PL_debug = get_debug_opts( (const char **)&s, 1) | DEBUG_TOP_FLAG;
3130 #else /* !DEBUGGING */
3131         if (ckWARN_d(WARN_DEBUGGING))
3132             Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
3133                    "Recompile perl with -DDEBUGGING to use -D switch (did you mean -d ?)\n");
3134         for (s++; isALNUM(*s); s++) ;
3135 #endif
3136         return s;
3137     }
3138     case 'h':
3139         usage(PL_origargv[0]);
3140         my_exit(0);
3141     case 'i':
3142         Safefree(PL_inplace);
3143 #if defined(__CYGWIN__) /* do backup extension automagically */
3144         if (*(s+1) == '\0') {
3145         PL_inplace = savepvs(".bak");
3146         return s+1;
3147         }
3148 #endif /* __CYGWIN__ */
3149         {
3150             const char * const start = ++s;
3151             while (*s && !isSPACE(*s))
3152                 ++s;
3153
3154             PL_inplace = savepvn(start, s - start);
3155         }
3156         if (*s) {
3157             ++s;
3158             if (*s == '-')      /* Additional switches on #! line. */
3159                 s++;
3160         }
3161         return s;
3162     case 'I':   /* -I handled both here and in parse_body() */
3163         forbid_setid('I', FALSE);
3164         ++s;
3165         while (*s && isSPACE(*s))
3166             ++s;
3167         if (*s) {
3168             const char *e, *p;
3169             p = s;
3170             /* ignore trailing spaces (possibly followed by other switches) */
3171             do {
3172                 for (e = p; *e && !isSPACE(*e); e++) ;
3173                 p = e;
3174                 while (isSPACE(*p))
3175                     p++;
3176             } while (*p && *p != '-');
3177             e = savepvn(s, e-s);
3178             incpush(e, TRUE, TRUE, FALSE, FALSE);
3179             Safefree(e);
3180             s = p;
3181             if (*s == '-')
3182                 s++;
3183         }
3184         else
3185             Perl_croak(aTHX_ "No directory specified for -I");
3186         return s;
3187     case 'l':
3188         PL_minus_l = TRUE;
3189         s++;
3190         if (PL_ors_sv) {
3191             SvREFCNT_dec(PL_ors_sv);
3192             PL_ors_sv = NULL;
3193         }
3194         if (isDIGIT(*s)) {
3195             I32 flags = 0;
3196             STRLEN numlen;
3197             PL_ors_sv = newSVpvs("\n");
3198             numlen = 3 + (*s == '0');
3199             *SvPVX(PL_ors_sv) = (char)grok_oct(s, &numlen, &flags, NULL);
3200             s += numlen;
3201         }
3202         else {
3203             if (RsPARA(PL_rs)) {
3204                 PL_ors_sv = newSVpvs("\n\n");
3205             }
3206             else {
3207                 PL_ors_sv = newSVsv(PL_rs);
3208             }
3209         }
3210         return s;
3211     case 'M':
3212         forbid_setid('M', FALSE);       /* XXX ? */
3213         /* FALL THROUGH */
3214     case 'm':
3215         forbid_setid('m', FALSE);       /* XXX ? */
3216         if (*++s) {
3217             const char *start;
3218             const char *end;
3219             SV *sv;
3220             const char *use = "use ";
3221             bool colon = FALSE;
3222             /* -M-foo == 'no foo'       */
3223             /* Leading space on " no " is deliberate, to make both
3224                possibilities the same length.  */
3225             if (*s == '-') { use = " no "; ++s; }
3226             sv = newSVpvn(use,4);
3227             start = s;
3228             /* We allow -M'Module qw(Foo Bar)'  */
3229             while(isALNUM(*s) || *s==':') {
3230                 if( *s++ == ':' ) {
3231                     if( *s == ':' )
3232                         s++;
3233                     else
3234                         colon = TRUE;
3235                 }
3236             }
3237             if (s == start)
3238                 Perl_croak(aTHX_ "Module name required with -%c option",
3239                                     option);
3240             if (colon)
3241                 Perl_croak(aTHX_ "Invalid module name %.*s with -%c option: "
3242                                     "contains single ':'",
3243                                     (int)(s - start), start, option);
3244             end = s + strlen(s);
3245             if (*s != '=') {
3246                 sv_catpvn(sv, start, end - start);
3247                 if (option == 'm') {
3248                     if (*s != '\0')
3249                         Perl_croak(aTHX_ "Can't use '%c' after -mname", *s);
3250                     sv_catpvs( sv, " ()");
3251                 }
3252             } else {
3253                 sv_catpvn(sv, start, s-start);
3254                 /* Use NUL as q''-delimiter.  */
3255                 sv_catpvs(sv, " split(/,/,q\0");
3256                 ++s;
3257                 sv_catpvn(sv, s, end - s);
3258                 sv_catpvs(sv,  "\0)");
3259             }
3260             s = end;
3261             Perl_av_create_and_push(aTHX_ &PL_preambleav, sv);
3262         }
3263         else
3264             Perl_croak(aTHX_ "Missing argument to -%c", option);
3265         return s;
3266     case 'n':
3267         PL_minus_n = TRUE;
3268         s++;
3269         return s;
3270     case 'p':
3271         PL_minus_p = TRUE;
3272         s++;
3273         return s;
3274     case 's':
3275         forbid_setid('s', FALSE);
3276         PL_doswitches = TRUE;
3277         s++;
3278         return s;
3279     case 't':
3280         if (!PL_tainting)
3281             TOO_LATE_FOR('t');
3282         s++;
3283         return s;
3284     case 'T':
3285         if (!PL_tainting)
3286             TOO_LATE_FOR('T');
3287         s++;
3288         return s;
3289     case 'u':
3290 #ifdef MACOS_TRADITIONAL
3291         Perl_croak(aTHX_ "Believe me, you don't want to use \"-u\" on a Macintosh");
3292 #endif
3293         PL_do_undump = TRUE;
3294         s++;
3295         return s;
3296     case 'U':
3297         PL_unsafe = TRUE;
3298         s++;
3299         return s;
3300     case 'v':
3301         if (!sv_derived_from(PL_patchlevel, "version"))
3302             upg_version(PL_patchlevel, TRUE);
3303 #if !defined(DGUX)
3304         PerlIO_printf(PerlIO_stdout(),
3305                 "\nThis is perl, %"SVf
3306 #ifdef PERL_PATCHNUM
3307                 " DEVEL" STRINGIFY(PERL_PATCHNUM)
3308 #endif
3309                 " built for %s",
3310                 SVfARG(vstringify(PL_patchlevel)),
3311                 ARCHNAME);
3312 #else /* DGUX */
3313 /* Adjust verbose output as in the perl that ships with the DG/UX OS from EMC */
3314         PerlIO_printf(PerlIO_stdout(),
3315                 Perl_form(aTHX_ "\nThis is perl, %"SVf"\n",
3316                     SVfARG(vstringify(PL_patchlevel))));
3317         PerlIO_printf(PerlIO_stdout(),
3318                         Perl_form(aTHX_ "        built under %s at %s %s\n",
3319                                         OSNAME, __DATE__, __TIME__));
3320         PerlIO_printf(PerlIO_stdout(),
3321                         Perl_form(aTHX_ "        OS Specific Release: %s\n",
3322                                         OSVERS));
3323 #endif /* !DGUX */
3324
3325 #if defined(LOCAL_PATCH_COUNT)
3326         if (LOCAL_PATCH_COUNT > 0)
3327             PerlIO_printf(PerlIO_stdout(),
3328                           "\n(with %d registered patch%s, "
3329                           "see perl -V for more detail)",
3330                           LOCAL_PATCH_COUNT,
3331                           (LOCAL_PATCH_COUNT!=1) ? "es" : "");
3332 #endif
3333
3334         PerlIO_printf(PerlIO_stdout(),
3335                       "\n\nCopyright 1987-2008, Larry Wall\n");
3336 #ifdef MACOS_TRADITIONAL
3337         PerlIO_printf(PerlIO_stdout(),
3338                       "\nMac OS port Copyright 1991-2002, Matthias Neeracher;\n"
3339                       "maintained by Chris Nandor\n");
3340 #endif
3341 #ifdef MSDOS
3342         PerlIO_printf(PerlIO_stdout(),
3343                       "\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
3344 #endif
3345 #ifdef DJGPP
3346         PerlIO_printf(PerlIO_stdout(),
3347                       "djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n"
3348                       "djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n");
3349 #endif
3350 #ifdef OS2
3351         PerlIO_printf(PerlIO_stdout(),
3352                       "\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
3353                       "Version 5 port Copyright (c) 1994-2002, Andreas Kaiser, Ilya Zakharevich\n");
3354 #endif
3355 #ifdef atarist
3356         PerlIO_printf(PerlIO_stdout(),
3357                       "atariST series port, ++jrb  bammi@cadence.com\n");
3358 #endif
3359 #ifdef __BEOS__
3360         PerlIO_printf(PerlIO_stdout(),
3361                       "BeOS port Copyright Tom Spindler, 1997-1999\n");
3362 #endif
3363 #ifdef MPE
3364         PerlIO_printf(PerlIO_stdout(),
3365                       "MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-2003\n");
3366 #endif
3367 #ifdef OEMVS
3368         PerlIO_printf(PerlIO_stdout(),
3369                       "MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
3370 #endif
3371 #ifdef __VOS__
3372         PerlIO_printf(PerlIO_stdout(),
3373                       "Stratus VOS port by Paul.Green@stratus.com, 1997-2002\n");
3374 #endif
3375 #ifdef __OPEN_VM
3376         PerlIO_printf(PerlIO_stdout(),
3377                       "VM/ESA port by Neale Ferguson, 1998-1999\n");
3378 #endif
3379 #ifdef POSIX_BC
3380         PerlIO_printf(PerlIO_stdout(),
3381                       "BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
3382 #endif
3383 #ifdef __MINT__
3384         PerlIO_printf(PerlIO_stdout(),
3385                       "MiNT port by Guido Flohr, 1997-1999\n");
3386 #endif
3387 #ifdef EPOC
3388         PerlIO_printf(PerlIO_stdout(),
3389                       "EPOC port by Olaf Flebbe, 1999-2002\n");
3390 #endif
3391 #ifdef UNDER_CE
3392         PerlIO_printf(PerlIO_stdout(),"WINCE port by Rainer Keuchel, 2001-2002\n");
3393         PerlIO_printf(PerlIO_stdout(),"Built on " __DATE__ " " __TIME__ "\n\n");
3394         wce_hitreturn();
3395 #endif
3396 #ifdef __SYMBIAN32__
3397         PerlIO_printf(PerlIO_stdout(),
3398                       "Symbian port by Nokia, 2004-2005\n");
3399 #endif
3400 #ifdef BINARY_BUILD_NOTICE
3401         BINARY_BUILD_NOTICE;
3402 #endif
3403         PerlIO_printf(PerlIO_stdout(),
3404                       "\n\
3405 Perl may be copied only under the terms of either the Artistic License or the\n\
3406 GNU General Public License, which may be found in the Perl 5 source kit.\n\n\
3407 Complete documentation for Perl, including FAQ lists, should be found on\n\
3408 this system using \"man perl\" or \"perldoc perl\".  If you have access to the\n\
3409 Internet, point your browser at http://www.perl.org/, the Perl Home Page.\n\n");
3410         my_exit(0);
3411     case 'w':
3412         if (! (PL_dowarn & G_WARN_ALL_MASK)) {
3413             PL_dowarn |= G_WARN_ON;
3414         }
3415         s++;
3416         return s;
3417     case 'W':
3418         PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
3419         if (!specialWARN(PL_compiling.cop_warnings))
3420             PerlMemShared_free(PL_compiling.cop_warnings);
3421         PL_compiling.cop_warnings = pWARN_ALL ;
3422         s++;
3423         return s;
3424     case 'X':
3425         PL_dowarn = G_WARN_ALL_OFF;
3426         if (!specialWARN(PL_compiling.cop_warnings))
3427             PerlMemShared_free(PL_compiling.cop_warnings);
3428         PL_compiling.cop_warnings = pWARN_NONE ;
3429         s++;
3430         return s;
3431     case '*':
3432     case ' ':
3433         while( *s == ' ' )
3434           ++s;
3435         if (s[0] == '-')        /* Additional switches on #! line. */
3436             return s+1;
3437         break;
3438     case '-':
3439     case 0:
3440 #if defined(WIN32) || !defined(PERL_STRICT_CR)
3441     case '\r':
3442 #endif
3443     case '\n':
3444     case '\t':
3445         break;
3446 #ifdef ALTERNATE_SHEBANG
3447     case 'S':                   /* OS/2 needs -S on "extproc" line. */
3448         break;
3449 #endif
3450     default:
3451         Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s);
3452     }
3453     return NULL;
3454 }
3455
3456 /* compliments of Tom Christiansen */
3457
3458 /* unexec() can be found in the Gnu emacs distribution */
3459 /* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
3460
3461 void
3462 Perl_my_unexec(pTHX)
3463 {
3464     PERL_UNUSED_CONTEXT;
3465 #ifdef UNEXEC
3466     SV *    prog = newSVpv(BIN_EXP, 0);
3467     SV *    file = newSVpv(PL_origfilename, 0);
3468     int    status = 1;
3469     extern int etext;
3470
3471     sv_catpvs(prog, "/perl");
3472     sv_catpvs(file, ".perldump");
3473
3474     unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
3475     /* unexec prints msg to stderr in case of failure */
3476     PerlProc_exit(status);
3477 #else
3478 #  ifdef VMS
3479 #    include <lib$routines.h>
3480      lib$signal(SS$_DEBUG);  /* ssdef.h #included from vmsish.h */
3481 #  elif defined(WIN32) || defined(__CYGWIN__)
3482     Perl_croak(aTHX_ "dump is not supported");
3483 #  else
3484     ABORT();            /* for use with undump */
3485 #  endif
3486 #endif
3487 }
3488
3489 /* initialize curinterp */
3490 STATIC void
3491 S_init_interp(pTHX)
3492 {
3493     dVAR;
3494 #ifdef MULTIPLICITY
3495 #  define PERLVAR(var,type)
3496 #  define PERLVARA(var,n,type)
3497 #  if defined(PERL_IMPLICIT_CONTEXT)
3498 #    define PERLVARI(var,type,init)             aTHX->var = init;
3499 #    define PERLVARIC(var,type,init)    aTHX->var = init;
3500 #  else
3501 #    define PERLVARI(var,type,init)     PERL_GET_INTERP->var = init;
3502 #    define PERLVARIC(var,type,init)    PERL_GET_INTERP->var = init;
3503 #  endif
3504 #  include "intrpvar.h"
3505 #  undef PERLVAR
3506 #  undef PERLVARA
3507 #  undef PERLVARI
3508 #  undef PERLVARIC
3509 #else
3510 #  define PERLVAR(var,type)
3511 #  define PERLVARA(var,n,type)
3512 #  define PERLVARI(var,type,init)       PL_##var = init;
3513 #  define PERLVARIC(var,type,init)      PL_##var = init;
3514 #  include "intrpvar.h"
3515 #  undef PERLVAR
3516 #  undef PERLVARA
3517 #  undef PERLVARI
3518 #  undef PERLVARIC
3519 #endif
3520
3521     /* As these are inside a structure, PERLVARI isn't capable of initialising
3522        them  */
3523     PL_reg_oldcurpm = PL_reg_curpm = NULL;
3524     PL_reg_poscache = PL_reg_starttry = NULL;
3525 }
3526
3527 STATIC void
3528 S_init_main_stash(pTHX)
3529 {
3530     dVAR;
3531     GV *gv;
3532
3533     PL_curstash = PL_defstash = newHV();
3534     /* We know that the string "main" will be in the global shared string
3535        table, so it's a small saving to use it rather than allocate another
3536        8 bytes.  */
3537     PL_curstname = newSVpvs_share("main");
3538     gv = gv_fetchpvs("main::", GV_ADD|GV_NOTQUAL, SVt_PVHV);
3539     /* If we hadn't caused another reference to "main" to be in the shared
3540        string table above, then it would be worth reordering these two,
3541        because otherwise all we do is delete "main" from it as a consequence
3542        of the SvREFCNT_dec, only to add it again with hv_name_set */
3543     SvREFCNT_dec(GvHV(gv));
3544     hv_name_set(PL_defstash, "main", 4, 0);
3545     GvHV(gv) = MUTABLE_HV(SvREFCNT_inc_simple(PL_defstash));
3546     SvREADONLY_on(gv);
3547     PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpvs("INC", GV_ADD|GV_NOTQUAL,
3548                                              SVt_PVAV)));
3549     SvREFCNT_inc_simple_void(PL_incgv); /* Don't allow it to be freed */
3550     GvMULTI_on(PL_incgv);
3551     PL_hintgv = gv_fetchpvs("\010", GV_ADD|GV_NOTQUAL, SVt_PV); /* ^H */
3552     GvMULTI_on(PL_hintgv);
3553     PL_defgv = gv_fetchpvs("_", GV_ADD|GV_NOTQUAL, SVt_PVAV);
3554     SvREFCNT_inc_simple_void(PL_defgv);
3555     PL_errgv = gv_HVadd(gv_fetchpvs("@", GV_ADD|GV_NOTQUAL, SVt_PV));
3556     SvREFCNT_inc_simple_void(PL_errgv);
3557     GvMULTI_on(PL_errgv);
3558     PL_replgv = gv_fetchpvs("\022", GV_ADD|GV_NOTQUAL, SVt_PV); /* ^R */
3559     GvMULTI_on(PL_replgv);
3560     (void)Perl_form(aTHX_ "%240s","");  /* Preallocate temp - for immediate signals. */
3561 #ifdef PERL_DONT_CREATE_GVSV
3562     gv_SVadd(PL_errgv);
3563 #endif
3564     sv_grow(ERRSV, 240);        /* Preallocate - for immediate signals. */
3565     CLEAR_ERRSV();
3566     PL_curstash = PL_defstash;
3567     CopSTASH_set(&PL_compiling, PL_defstash);
3568     PL_debstash = GvHV(gv_fetchpvs("DB::", GV_ADDMULTI, SVt_PVHV));
3569     PL_globalstash = GvHV(gv_fetchpvs("CORE::GLOBAL::", GV_ADDMULTI,
3570                                       SVt_PVHV));
3571     /* We must init $/ before switches are processed. */
3572     sv_setpvs(get_sv("/", TRUE), "\n");
3573 }
3574
3575 STATIC int
3576 S_open_script(pTHX_ const char *scriptname, bool dosearch,
3577               bool *suidscript, PerlIO **rsfpp)
3578 {
3579     int fdscript = -1;
3580     dVAR;
3581
3582     PERL_ARGS_ASSERT_OPEN_SCRIPT;
3583
3584     if (PL_e_script) {
3585         PL_origfilename = savepvs("-e");
3586     }
3587     else {
3588         /* if find_script() returns, it returns a malloc()-ed value */
3589         scriptname = PL_origfilename = find_script(scriptname, dosearch, NULL, 1);
3590
3591         if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
3592             const char *s = scriptname + 8;
3593             fdscript = atoi(s);
3594             while (isDIGIT(*s))
3595                 s++;
3596             if (*s) {
3597                 /* PSz 18 Feb 04
3598                  * Tell apart "normal" usage of fdscript, e.g.
3599                  * with bash on FreeBSD:
3600                  *   perl <( echo '#!perl -DA'; echo 'print "$0\n"')
3601                  * from usage in suidperl.
3602                  * Does any "normal" usage leave garbage after the number???
3603                  * Is it a mistake to use a similar /dev/fd/ construct for
3604                  * suidperl?
3605                  */
3606                 *suidscript = TRUE;
3607                 /* PSz 20 Feb 04
3608                  * Be supersafe and do some sanity-checks.
3609                  * Still, can we be sure we got the right thing?
3610                  */
3611                 if (*s != '/') {
3612                     Perl_croak(aTHX_ "Wrong syntax (suid) fd script name \"%s\"\n", s);
3613                 }
3614                 if (! *(s+1)) {
3615                     Perl_croak(aTHX_ "Missing (suid) fd script name\n");
3616                 }
3617                 scriptname = savepv(s + 1);
3618                 Safefree(PL_origfilename);
3619                 PL_origfilename = (char *)scriptname;
3620             }
3621         }
3622     }
3623
3624     CopFILE_free(PL_curcop);
3625     CopFILE_set(PL_curcop, PL_origfilename);
3626     if (*PL_origfilename == '-' && PL_origfilename[1] == '\0')
3627         scriptname = (char *)"";
3628     if (fdscript >= 0) {
3629         *rsfpp = PerlIO_fdopen(fdscript,PERL_SCRIPT_MODE);
3630 #       if defined(HAS_FCNTL) && defined(F_SETFD)
3631             if (*rsfpp)
3632                 /* ensure close-on-exec */
3633                 fcntl(PerlIO_fileno(*rsfpp),F_SETFD,1);
3634 #       endif
3635     }
3636 #ifdef IAMSUID
3637     else {
3638         Perl_croak(aTHX_ "sperl needs fd script\n"
3639                    "You should not call sperl directly; do you need to "
3640                    "change a #! line\nfrom sperl to perl?\n");
3641
3642 /* PSz 11 Nov 03
3643  * Do not open (or do other fancy stuff) while setuid.
3644  * Perl does the open, and hands script to suidperl on a fd;
3645  * suidperl only does some checks, sets up UIDs and re-execs
3646  * perl with that fd as it has always done.
3647  */
3648     }
3649     if (*suidscript) {
3650         Perl_croak(aTHX_ "suidperl needs (suid) fd script\n");
3651     }
3652 #else /* IAMSUID */
3653     else if (!*scriptname) {
3654         forbid_setid(0, *suidscript);
3655         *rsfpp = PerlIO_stdin();
3656     }
3657     else {
3658 #ifdef FAKE_BIT_BUCKET
3659         /* This hack allows one not to have /dev/null (or BIT_BUCKET as it
3660          * is called) and still have the "-e" work.  (Believe it or not,
3661          * a /dev/null is required for the "-e" to work because source
3662          * filter magic is used to implement it. ) This is *not* a general
3663          * replacement for a /dev/null.  What we do here is create a temp
3664          * file (an empty file), open up that as the script, and then
3665          * immediately close and unlink it.  Close enough for jazz. */
3666 #define FAKE_BIT_BUCKET_PREFIX "/tmp/perlnull-"
3667 #define FAKE_BIT_BUCKET_SUFFIX "XXXXXXXX"
3668 #define FAKE_BIT_BUCKET_TEMPLATE FAKE_BIT_BUCKET_PREFIX FAKE_BIT_BUCKET_SUFFIX
3669         char tmpname[sizeof(FAKE_BIT_BUCKET_TEMPLATE)] = {
3670             FAKE_BIT_BUCKET_TEMPLATE
3671         };
3672         const char * const err = "Failed to create a fake bit bucket";
3673         if (strEQ(scriptname, BIT_BUCKET)) {
3674 #ifdef HAS_MKSTEMP /* Hopefully mkstemp() is safe here. */
3675             int tmpfd = mkstemp(tmpname);
3676             if (tmpfd > -1) {
3677                 scriptname = tmpname;
3678                 close(tmpfd);
3679             } else
3680                 Perl_croak(aTHX_ err);
3681 #else
3682 #  ifdef HAS_MKTEMP
3683             scriptname = mktemp(tmpname);
3684             if (!scriptname)
3685                 Perl_croak(aTHX_ err);
3686 #  endif
3687 #endif
3688         }
3689 #endif
3690         *rsfpp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
3691 #ifdef FAKE_BIT_BUCKET
3692         if (memEQ(scriptname, FAKE_BIT_BUCKET_PREFIX,
3693                   sizeof(FAKE_BIT_BUCKET_PREFIX) - 1)
3694             && strlen(scriptname) == sizeof(tmpname) - 1) {
3695             unlink(scriptname);
3696         }
3697         scriptname = BIT_BUCKET;
3698 #endif
3699 #       if defined(HAS_FCNTL) && defined(F_SETFD)
3700             if (*rsfpp)
3701                 /* ensure close-on-exec */
3702                 fcntl(PerlIO_fileno(*rsfpp),F_SETFD,1);
3703 #       endif
3704     }
3705 #endif /* IAMSUID */
3706     if (!*rsfpp) {
3707         /* PSz 16 Sep 03  Keep neat error message */
3708         if (PL_e_script)
3709             Perl_croak(aTHX_ "Can't open "BIT_BUCKET": %s\n", Strerror(errno));
3710         else
3711             Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
3712                     CopFILE(PL_curcop), Strerror(errno));
3713     }
3714     return fdscript;
3715 }
3716
3717 /* Mention
3718  * I_SYSSTATVFS HAS_FSTATVFS
3719  * I_SYSMOUNT
3720  * I_STATFS     HAS_FSTATFS     HAS_GETFSSTAT
3721  * I_MNTENT     HAS_GETMNTENT   HAS_HASMNTOPT
3722  * here so that metaconfig picks them up. */
3723
3724 #ifdef IAMSUID
3725 STATIC int
3726 S_fd_on_nosuid_fs(pTHX_ int fd)
3727 {
3728 /* PSz 27 Feb 04
3729  * We used to do this as "plain" user (after swapping UIDs with setreuid);
3730  * but is needed also on machines without setreuid.
3731  * Seems safe enough to run as root.
3732  */
3733     int check_okay = 0; /* able to do all the required sys/libcalls */
3734     int on_nosuid  = 0; /* the fd is on a nosuid fs */
3735     /* PSz 12 Nov 03
3736      * Need to check noexec also: nosuid might not be set, the average
3737      * sysadmin would say that nosuid is irrelevant once he sets noexec.
3738      */
3739     int on_noexec  = 0; /* the fd is on a noexec fs */
3740
3741 /*
3742  * Preferred order: fstatvfs(), fstatfs(), ustat()+getmnt(), getmntent().
3743  * fstatvfs() is UNIX98.
3744  * fstatfs() is 4.3 BSD.
3745  * ustat()+getmnt() is pre-4.3 BSD.
3746  * getmntent() is O(number-of-mounted-filesystems) and can hang on
3747  * an irrelevant filesystem while trying to reach the right one.
3748  */
3749
3750 #undef FD_ON_NOSUID_CHECK_OKAY  /* found the syscalls to do the check? */
3751
3752 #   if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
3753         defined(HAS_FSTATVFS)
3754 #   define FD_ON_NOSUID_CHECK_OKAY
3755     struct statvfs stfs;
3756
3757     check_okay = fstatvfs(fd, &stfs) == 0;
3758     on_nosuid  = check_okay && (stfs.f_flag  & ST_NOSUID);
3759 #ifdef ST_NOEXEC
3760     /* ST_NOEXEC certainly absent on AIX 5.1, and doesn't seem to be documented
3761        on platforms where it is present.  */
3762     on_noexec  = check_okay && (stfs.f_flag  & ST_NOEXEC);
3763 #endif
3764 #   endif /* fstatvfs */
3765
3766 #   if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
3767         defined(PERL_MOUNT_NOSUID)      && \
3768         defined(PERL_MOUNT_NOEXEC)      && \
3769         defined(HAS_FSTATFS)            && \
3770         defined(HAS_STRUCT_STATFS)      && \
3771         defined(HAS_STRUCT_STATFS_F_FLAGS)
3772 #   define FD_ON_NOSUID_CHECK_OKAY
3773     struct statfs  stfs;
3774
3775     check_okay = fstatfs(fd, &stfs)  == 0;
3776     on_nosuid  = check_okay && (stfs.f_flags & PERL_MOUNT_NOSUID);
3777     on_noexec  = check_okay && (stfs.f_flags & PERL_MOUNT_NOEXEC);
3778 #   endif /* fstatfs */
3779
3780 #   if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
3781         defined(PERL_MOUNT_NOSUID)      && \
3782         defined(PERL_MOUNT_NOEXEC)      && \
3783         defined(HAS_FSTAT)              && \
3784         defined(HAS_USTAT)              && \
3785         defined(HAS_GETMNT)             && \
3786         defined(HAS_STRUCT_FS_DATA)     && \
3787         defined(NOSTAT_ONE)
3788 #   define FD_ON_NOSUID_CHECK_OKAY
3789     Stat_t fdst;
3790
3791     if (fstat(fd, &fdst) == 0) {
3792         struct ustat us;
3793         if (ustat(fdst.st_dev, &us) == 0) {
3794             struct fs_data fsd;
3795             /* NOSTAT_ONE here because we're not examining fields which
3796              * vary between that case and STAT_ONE. */
3797             if (getmnt((int*)0, &fsd, (int)0, NOSTAT_ONE, us.f_fname) == 0) {
3798                 size_t cmplen = sizeof(us.f_fname);
3799                 if (sizeof(fsd.fd_req.path) < cmplen)
3800                     cmplen = sizeof(fsd.fd_req.path);
3801                 if (strnEQ(fsd.fd_req.path, us.f_fname, cmplen) &&
3802                     fdst.st_dev == fsd.fd_req.dev) {
3803                     check_okay = 1;
3804                     on_nosuid = fsd.fd_req.flags & PERL_MOUNT_NOSUID;
3805                     on_noexec = fsd.fd_req.flags & PERL_MOUNT_NOEXEC;
3806                 }
3807             }
3808         }
3809     }
3810 #   endif /* fstat+ustat+getmnt */
3811
3812 #   if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
3813         defined(HAS_GETMNTENT)          && \
3814         defined(HAS_HASMNTOPT)          && \
3815         defined(MNTOPT_NOSUID)          && \
3816         defined(MNTOPT_NOEXEC)
3817 #   define FD_ON_NOSUID_CHECK_OKAY
3818     FILE                *mtab = fopen("/etc/mtab", "r");
3819     struct mntent       *entry;
3820     Stat_t              stb, fsb;
3821
3822     if (mtab && (fstat(fd, &stb) == 0)) {
3823         while (entry = getmntent(mtab)) {
3824             if (stat(entry->mnt_dir, &fsb) == 0
3825                 && fsb.st_dev == stb.st_dev)
3826             {
3827                 /* found the filesystem */
3828                 check_okay = 1;
3829                 if (hasmntopt(entry, MNTOPT_NOSUID))
3830                     on_nosuid = 1;
3831                 if (hasmntopt(entry, MNTOPT_NOEXEC))
3832                     on_noexec = 1;
3833                 break;
3834             } /* A single fs may well fail its stat(). */
3835         }
3836     }
3837     if (mtab)
3838         fclose(mtab);
3839 #   endif /* getmntent+hasmntopt */
3840
3841     if (!check_okay)
3842         Perl_croak(aTHX_ "Can't check filesystem of script \"%s\" for nosuid/noexec", PL_origfilename);
3843     if (on_nosuid)
3844         Perl_croak(aTHX_ "Setuid script \"%s\" on nosuid filesystem", PL_origfilename);
3845     if (on_noexec)
3846         Perl_croak(aTHX_ "Setuid script \"%s\" on noexec filesystem", PL_origfilename);
3847     return ((!check_okay) || on_nosuid || on_noexec);
3848 }
3849 #endif /* IAMSUID */
3850
3851 #ifdef DOSUID
3852 STATIC void
3853 S_validate_suid(pTHX_ const char *validarg,
3854 #  ifndef IAMSUID
3855                 const char *scriptname,
3856 #  endif
3857                 int fdscript,
3858 #  ifdef IAMSUID
3859                 bool suidscript,
3860 #  endif
3861                 SV *linestr_sv, PerlIO *rsfp)
3862 {
3863     dVAR;
3864     const char *s, *s2;
3865
3866     PERL_ARGS_ASSERT_VALIDATE_SUID;
3867
3868     /* do we need to emulate setuid on scripts? */
3869
3870     /* This code is for those BSD systems that have setuid #! scripts disabled
3871      * in the kernel because of a security problem.  Merely defining DOSUID
3872      * in perl will not fix that problem, but if you have disabled setuid
3873      * scripts in the kernel, this will attempt to emulate setuid and setgid
3874      * on scripts that have those now-otherwise-useless bits set.  The setuid
3875      * root version must be called suidperl or sperlN.NNN.  If regular perl
3876      * discovers that it has opened a setuid script, it calls suidperl with
3877      * the same argv that it had.  If suidperl finds that the script it has
3878      * just opened is NOT setuid root, it sets the effective uid back to the
3879      * uid.  We don't just make perl setuid root because that loses the
3880      * effective uid we had before invoking perl, if it was different from the
3881      * uid.
3882      * PSz 27 Feb 04
3883      * Description/comments above do not match current workings:
3884      *   suidperl must be hardlinked to sperlN.NNN (that is what we exec);
3885      *   suidperl called with script open and name changed to /dev/fd/N/X;
3886      *   suidperl croaks if script is not setuid;
3887      *   making perl setuid would be a huge security risk (and yes, that
3888      *     would lose any euid we might have had).
3889      *
3890      * DOSUID must be defined in both perl and suidperl, and IAMSUID must
3891      * be defined in suidperl only.  suidperl must be setuid root.  The
3892      * Configure script will set this up for you if you want it.
3893      */
3894
3895     if (PerlLIO_fstat(PerlIO_fileno(rsfp),&PL_statbuf) < 0)     /* normal stat is insecure */
3896         Perl_croak(aTHX_ "Can't stat script \"%s\"",PL_origfilename);
3897     if (PL_statbuf.st_mode & (S_ISUID|S_ISGID)) {
3898         I32 len;
3899         const char *linestr;
3900         const char *s_end;
3901
3902 #  ifdef IAMSUID
3903         if (fdscript < 0 || !suidscript)
3904             Perl_croak(aTHX_ "Need (suid) fdscript in suidperl\n");     /* We already checked this */
3905         /* PSz 11 Nov 03
3906          * Since the script is opened by perl, not suidperl, some of these
3907          * checks are superfluous. Leaving them in probably does not lower
3908          * security(?!).
3909          */
3910         /* PSz 27 Feb 04
3911          * Do checks even for systems with no HAS_SETREUID.
3912          * We used to swap, then re-swap UIDs with
3913 #    ifdef HAS_SETREUID
3914             if (setreuid(PL_euid,PL_uid) < 0
3915                 || PerlProc_getuid() != PL_euid || PerlProc_geteuid() != PL_uid)
3916                 Perl_croak(aTHX_ "Can't swap uid and euid");
3917 #    endif
3918 #    ifdef HAS_SETREUID
3919             if (setreuid(PL_uid,PL_euid) < 0
3920                 || PerlProc_getuid() != PL_uid || PerlProc_geteuid() != PL_euid)
3921                 Perl_croak(aTHX_ "Can't reswap uid and euid");
3922 #    endif
3923          */
3924
3925         /* On this access check to make sure the directories are readable,
3926          * there is actually a small window that the user could use to make
3927          * filename point to an accessible directory.  So there is a faint
3928          * chance that someone could execute a setuid script down in a
3929          * non-accessible directory.  I don't know what to do about that.
3930          * But I don't think it's too important.  The manual lies when
3931          * it says access() is useful in setuid programs.
3932          *
3933          * So, access() is pretty useless... but not harmful... do anyway.
3934          */
3935         if (PerlLIO_access(CopFILE(PL_curcop),1)) { /*double check*/
3936             Perl_croak(aTHX_ "Can't access() script\n");
3937         }
3938
3939         /* If we can swap euid and uid, then we can determine access rights
3940          * with a simple stat of the file, and then compare device and
3941          * inode to make sure we did stat() on the same file we opened.
3942          * Then we just have to make sure he or she can execute it.
3943          *
3944          * PSz 24 Feb 04
3945          * As the script is opened by perl, not suidperl, we do not need to
3946          * care much about access rights.
3947          *
3948          * The 'script changed' check is needed, or we can get lied to
3949          * about $0 with e.g.
3950          *  suidperl /dev/fd/4//bin/x 4<setuidscript
3951          * Without HAS_SETREUID, is it safe to stat() as root?
3952          *
3953          * Are there any operating systems that pass /dev/fd/xxx for setuid
3954          * scripts, as suggested/described in perlsec(1)? Surely they do not
3955          * pass the script name as we do, so the "script changed" test would
3956          * fail for them... but we never get here with
3957          * SETUID_SCRIPTS_ARE_SECURE_NOW defined.
3958          *
3959          * This is one place where we must "lie" about return status: not
3960          * say if the stat() failed. We are doing this as root, and could
3961          * be tricked into reporting existence or not of files that the
3962          * "plain" user cannot even see.
3963          */
3964         {
3965             Stat_t tmpstatbuf;
3966             if (PerlLIO_stat(CopFILE(PL_curcop),&tmpstatbuf) < 0 ||
3967                 tmpstatbuf.st_dev != PL_statbuf.st_dev ||
3968                 tmpstatbuf.st_ino != PL_statbuf.st_ino) {
3969                 Perl_croak(aTHX_ "Setuid script changed\n");
3970             }
3971
3972         }
3973         if (!cando(S_IXUSR,FALSE,&PL_statbuf))          /* can real uid exec? */
3974             Perl_croak(aTHX_ "Real UID cannot exec script\n");
3975
3976         /* PSz 27 Feb 04
3977          * We used to do this check as the "plain" user (after swapping
3978          * UIDs). But the check for nosuid and noexec filesystem is needed,
3979          * and should be done even without HAS_SETREUID. (Maybe those
3980          * operating systems do not have such mount options anyway...)
3981          * Seems safe enough to do as root.
3982          */
3983 #    if !defined(NO_NOSUID_CHECK)
3984         if (fd_on_nosuid_fs(PerlIO_fileno(rsfp))) {
3985             Perl_croak(aTHX_ "Setuid script on nosuid or noexec filesystem\n");
3986         }
3987 #    endif
3988 #  endif /* IAMSUID */
3989
3990         if (!S_ISREG(PL_statbuf.st_mode)) {
3991             Perl_croak(aTHX_ "Setuid script not plain file\n");
3992         }
3993         if (PL_statbuf.st_mode & S_IWOTH)
3994             Perl_croak(aTHX_ "Setuid/gid script is writable by world");
3995         PL_doswitches = FALSE;          /* -s is insecure in suid */
3996         /* PSz 13 Nov 03  But -s was caught elsewhere ... so unsetting it here is useless(?!) */
3997         CopLINE_inc(PL_curcop);
3998         if (sv_gets(linestr_sv, rsfp, 0) == NULL)
3999             Perl_croak(aTHX_ "No #! line");
4000         linestr = SvPV_nolen_const(linestr_sv);
4001         /* required even on Sys V */
4002         if (!*linestr || !linestr[1] || strnNE(linestr,"#!",2))
4003             Perl_croak(aTHX_ "No #! line");
4004         linestr += 2;
4005         s = linestr;
4006         /* PSz 27 Feb 04 */
4007         /* Sanity check on line length */
4008         s_end = s + strlen(s);
4009         if (s_end == s || (s_end - s) > 4000)
4010             Perl_croak(aTHX_ "Very long #! line");
4011         /* Allow more than a single space after #! */
4012         while (isSPACE(*s)) s++;
4013         /* Sanity check on buffer end */
4014         while ((*s) && !isSPACE(*s)) s++;
4015         for (s2 = s;  (s2 > linestr &&
4016                        (isDIGIT(s2[-1]) || s2[-1] == '.' || s2[-1] == '_'
4017                         || s2[-1] == '-'));  s2--) ;
4018         /* Sanity check on buffer start */
4019         if ( (s2-4 < linestr || strnNE(s2-4,"perl",4)) &&
4020               (s-9 < linestr || strnNE(s-9,"perl",4)) )
4021             Perl_croak(aTHX_ "Not a perl script");
4022         while (*s == ' ' || *s == '\t') s++;
4023         /*
4024          * #! arg must be what we saw above.  They can invoke it by
4025          * mentioning suidperl explicitly, but they may not add any strange
4026          * arguments beyond what #! says if they do invoke suidperl that way.
4027          */
4028         /*
4029          * The way validarg was set up, we rely on the kernel to start
4030          * scripts with argv[1] set to contain all #! line switches (the
4031          * whole line).
4032          */
4033         /*
4034          * Check that we got all the arguments listed in the #! line (not
4035          * just that there are no extraneous arguments). Might not matter
4036          * much, as switches from #! line seem to be acted upon (also), and
4037          * so may be checked and trapped in perl. But, security checks must
4038          * be done in suidperl and not deferred to perl. Note that suidperl
4039          * does not get around to parsing (and checking) the switches on
4040          * the #! line (but execs perl sooner).
4041          * Allow (require) a trailing newline (which may be of two
4042          * characters on some architectures?) (but no other trailing
4043          * whitespace).
4044          */
4045         len = strlen(validarg);
4046         if (strEQ(validarg," PHOOEY ") ||
4047             strnNE(s,validarg,len) || !isSPACE(s[len]) ||
4048             !((s_end - s) == len+1
4049               || ((s_end - s) == len+2 && isSPACE(s[len+1]))))
4050             Perl_croak(aTHX_ "Args must match #! line");
4051
4052 #  ifndef IAMSUID
4053         if (fdscript < 0 &&
4054             PL_euid != PL_uid && (PL_statbuf.st_mode & S_ISUID) &&
4055             PL_euid == PL_statbuf.st_uid)
4056             if (!PL_do_undump)
4057                 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
4058 FIX YOUR KERNEL, OR PUT A C WRAPPER AROUND THIS SCRIPT!\n");
4059 #  endif /* IAMSUID */
4060
4061         if (fdscript < 0 &&
4062             PL_euid) {  /* oops, we're not the setuid root perl */
4063             /* PSz 18 Feb 04
4064              * When root runs a setuid script, we do not go through the same
4065              * steps of execing sperl and then perl with fd scripts, but
4066              * simply set up UIDs within the same perl invocation; so do
4067              * not have the same checks (on options, whatever) that we have
4068              * for plain users. No problem really: would have to be a script
4069              * that does not actually work for plain users; and if root is
4070              * foolish and can be persuaded to run such an unsafe script, he
4071              * might run also non-setuid ones, and deserves what he gets.
4072              *
4073              * Or, we might drop the PL_euid check above (and rely just on
4074              * fdscript to avoid loops), and do the execs
4075              * even for root.
4076              */
4077 #  ifndef IAMSUID
4078             int which;
4079             /* PSz 11 Nov 03
4080              * Pass fd script to suidperl.
4081              * Exec suidperl, substituting fd script for scriptname.
4082              * Pass script name as "subdir" of fd, which perl will grok;
4083              * in fact will use that to distinguish this from "normal"
4084              * usage, see comments above.
4085              */
4086             PerlIO_rewind(rsfp);
4087             PerlLIO_lseek(PerlIO_fileno(rsfp),(Off_t)0,0);  /* just in case rewind didn't */
4088             /* PSz 27 Feb 04  Sanity checks on scriptname */
4089             if ((!scriptname) || (!*scriptname) ) {
4090                 Perl_croak(aTHX_ "No setuid script name\n");
4091             }
4092             if (*scriptname == '-') {
4093                 Perl_croak(aTHX_ "Setuid script name may not begin with dash\n");
4094                 /* Or we might confuse it with an option when replacing
4095                  * name in argument list, below (though we do pointer, not
4096                  * string, comparisons).
4097                  */
4098             }
4099             for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ;
4100             if (!PL_origargv[which]) {
4101                 Perl_croak(aTHX_ "Can't change argv to have fd script\n");
4102             }
4103             PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s",
4104                                           PerlIO_fileno(rsfp), PL_origargv[which]));
4105 #    if defined(HAS_FCNTL) && defined(F_SETFD)
4106             fcntl(PerlIO_fileno(rsfp),F_SETFD,0);       /* ensure no close-on-exec */
4107 #    endif
4108             PERL_FPU_PRE_EXEC
4109             PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT, BIN_EXP,
4110                                      (int)PERL_REVISION, (int)PERL_VERSION,
4111                                      (int)PERL_SUBVERSION), PL_origargv);
4112             PERL_FPU_POST_EXEC
4113 #  endif /* IAMSUID */
4114             Perl_croak(aTHX_ "Can't do setuid (cannot exec sperl)\n");
4115         }
4116
4117         if (PL_statbuf.st_mode & S_ISGID && PL_statbuf.st_gid != PL_egid) {
4118 /* PSz 26 Feb 04
4119  * This seems back to front: we try HAS_SETEGID first; if not available
4120  * then try HAS_SETREGID; as a last chance we try HAS_SETRESGID. May be OK
4121  * in the sense that we only want to set EGID; but are there any machines
4122  * with either of the latter, but not the former? Same with UID, later.
4123  */
4124 #  ifdef HAS_SETEGID
4125             (void)setegid(PL_statbuf.st_gid);
4126 #  else
4127 #    ifdef HAS_SETREGID
4128            (void)setregid((Gid_t)-1,PL_statbuf.st_gid);
4129 #    else
4130 #      ifdef HAS_SETRESGID
4131            (void)setresgid((Gid_t)-1,PL_statbuf.st_gid,(Gid_t)-1);
4132 #      else
4133             PerlProc_setgid(PL_statbuf.st_gid);
4134 #      endif
4135 #    endif
4136 #  endif
4137             if (PerlProc_getegid() != PL_statbuf.st_gid)
4138                 Perl_croak(aTHX_ "Can't do setegid!\n");
4139         }
4140         if (PL_statbuf.st_mode & S_ISUID) {
4141             if (PL_statbuf.st_uid != PL_euid)
4142 #  ifdef HAS_SETEUID
4143                 (void)seteuid(PL_statbuf.st_uid);       /* all that for this */
4144 #  else
4145 #    ifdef HAS_SETREUID
4146                 (void)setreuid((Uid_t)-1,PL_statbuf.st_uid);
4147 #    else
4148 #      ifdef HAS_SETRESUID
4149                 (void)setresuid((Uid_t)-1,PL_statbuf.st_uid,(Uid_t)-1);
4150 #      else
4151                 PerlProc_setuid(PL_statbuf.st_uid);
4152 #      endif
4153 #    endif
4154 #  endif
4155             if (PerlProc_geteuid() != PL_statbuf.st_uid)
4156                 Perl_croak(aTHX_ "Can't do seteuid!\n");
4157         }
4158         else if (PL_uid) {                      /* oops, mustn't run as root */
4159 #  ifdef HAS_SETEUID
4160           (void)seteuid((Uid_t)PL_uid);
4161 #  else
4162 #    ifdef HAS_SETREUID
4163           (void)setreuid((Uid_t)-1,(Uid_t)PL_uid);
4164 #    else
4165 #      ifdef HAS_SETRESUID
4166           (void)setresuid((Uid_t)-1,(Uid_t)PL_uid,(Uid_t)-1);
4167 #      else
4168           PerlProc_setuid((Uid_t)PL_uid);
4169 #      endif
4170 #    endif
4171 #  endif
4172             if (PerlProc_geteuid() != PL_uid)
4173                 Perl_croak(aTHX_ "Can't do seteuid!\n");
4174         }
4175         init_ids();
4176         if (!cando(S_IXUSR,TRUE,&PL_statbuf))
4177             Perl_croak(aTHX_ "Effective UID cannot exec script\n");     /* they can't do this */
4178     }
4179 #  ifdef IAMSUID
4180     else if (fdscript < 0 || !suidscript)
4181         /* PSz 13 Nov 03  Caught elsewhere, useless(?!) here */
4182         Perl_croak(aTHX_ "(suid) fdscript needed in suidperl\n");
4183     else {
4184 /* PSz 16 Sep 03  Keep neat error message */
4185         Perl_croak(aTHX_ "Script is not setuid/setgid in suidperl\n");
4186     }
4187
4188     /* We absolutely must clear out any saved ids here, so we */
4189     /* exec the real perl, substituting fd script for scriptname. */
4190     /* (We pass script name as "subdir" of fd, which perl will grok.) */
4191     /*
4192      * It might be thought that using setresgid and/or setresuid (changed to
4193      * set the saved IDs) above might obviate the need to exec, and we could
4194      * go on to "do the perl thing".
4195      *
4196      * Is there such a thing as "saved GID", and is that set for setuid (but
4197      * not setgid) execution like suidperl? Without exec, it would not be
4198      * cleared for setuid (but not setgid) scripts (or might need a dummy
4199      * setresgid).
4200      *
4201      * We need suidperl to do the exact same argument checking that perl
4202      * does. Thus it cannot be very small; while it could be significantly
4203      * smaller, it is safer (simpler?) to make it essentially the same
4204      * binary as perl (but they are not identical). - Maybe could defer that
4205      * check to the invoked perl, and suidperl be a tiny wrapper instead;
4206      * but prefer to do thorough checks in suidperl itself. Such deferral
4207      * would make suidperl security rely on perl, a design no-no.
4208      *
4209      * Setuid things should be short and simple, thus easy to understand and
4210      * verify. They should do their "own thing", without influence by
4211      * attackers. It may help if their internal execution flow is fixed,
4212      * regardless of platform: it may be best to exec anyway.
4213      *
4214      * Suidperl should at least be conceptually simple: a wrapper only,
4215      * never to do any real perl. Maybe we should put
4216      * #ifdef IAMSUID
4217      *         Perl_croak(aTHX_ "Suidperl should never do real perl\n");
4218      * #endif
4219      * into the perly bits.
4220      */
4221     PerlIO_rewind(rsfp);
4222     PerlLIO_lseek(PerlIO_fileno(rsfp),(Off_t)0,0);  /* just in case rewind didn't */
4223     /* PSz 11 Nov 03
4224      * Keep original arguments: suidperl already has fd script.
4225      */
4226 #  if defined(HAS_FCNTL) && defined(F_SETFD)
4227     fcntl(PerlIO_fileno(rsfp),F_SETFD,0);       /* ensure no close-on-exec */
4228 #  endif
4229     PERL_FPU_PRE_EXEC
4230     PerlProc_execv(Perl_form(aTHX_ "%s/perl"PERL_FS_VER_FMT, BIN_EXP,
4231                              (int)PERL_REVISION, (int)PERL_VERSION,
4232                              (int)PERL_SUBVERSION), PL_origargv);/* try again */
4233     PERL_FPU_POST_EXEC
4234     Perl_croak(aTHX_ "Can't do setuid (suidperl cannot exec perl)\n");
4235 #  endif /* IAMSUID */
4236 }
4237
4238 #else /* !DOSUID */
4239
4240 #  ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
4241 /* Don't even need this function.  */
4242 #  else
4243 STATIC void
4244 S_validate_suid(pTHX_ PerlIO *rsfp)
4245 {
4246     PERL_ARGS_ASSERT_VALIDATE_SUID;
4247
4248     if (PL_euid != PL_uid || PL_egid != PL_gid) {       /* (suidperl doesn't exist, in fact) */
4249 #  ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
4250         dVAR;
4251
4252         PerlLIO_fstat(PerlIO_fileno(rsfp),&PL_statbuf); /* may be either wrapped or real suid */
4253         if ((PL_euid != PL_uid && PL_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
4254             ||
4255             (PL_egid != PL_gid && PL_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
4256            )
4257             if (!PL_do_undump)
4258                 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
4259 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
4260 #  endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
4261         /* not set-id, must be wrapped */
4262     }
4263 }
4264 #  endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
4265 #endif /* DOSUID */
4266
4267 STATIC void
4268 S_find_beginning(pTHX_ SV* linestr_sv, PerlIO *rsfp)
4269 {
4270     dVAR;
4271     const char *s;
4272     register const char *s2;
4273 #ifdef MACOS_TRADITIONAL
4274     int maclines = 0;
4275 #endif
4276
4277     PERL_ARGS_ASSERT_FIND_BEGINNING;
4278
4279     /* skip forward in input to the real script? */
4280
4281 #ifdef MACOS_TRADITIONAL
4282     /* Since the Mac OS does not honor #! arguments for us, we do it ourselves */
4283
4284     while (PL_doextract || gMacPerl_AlwaysExtract) {
4285         if ((s = sv_gets(linestr_sv, rsfp, 0)) == NULL) {
4286             if (!gMacPerl_AlwaysExtract)
4287                 Perl_croak(aTHX_ "No Perl script found in input\n");
4288
4289             if (PL_doextract)                   /* require explicit override ? */
4290                 if (!OverrideExtract(PL_origfilename))
4291                     Perl_croak(aTHX_ "User aborted script\n");
4292                 else
4293                     PL_doextract = FALSE;
4294
4295             /* Pater peccavi, file does not have #! */
4296             PerlIO_rewind(rsfp);
4297
4298             break;
4299         }
4300 #else
4301     while (PL_doextract) {
4302         if ((s = sv_gets(linestr_sv, rsfp, 0)) == NULL)
4303             Perl_croak(aTHX_ "No Perl script found in input\n");
4304 #endif
4305         s2 = s;
4306         if (*s == '#' && s[1] == '!' && ((s = instr(s,"perl")) || (s = instr(s2,"PERL")))) {
4307             PerlIO_ungetc(rsfp, '\n');          /* to keep line count right */
4308             PL_doextract = FALSE;
4309             while (*s && !(isSPACE (*s) || *s == '#')) s++;
4310             s2 = s;
4311             while (*s == ' ' || *s == '\t') s++;
4312             if (*s++ == '-') {
4313                 while (isDIGIT(s2[-1]) || s2[-1] == '-' || s2[-1] == '.'
4314                        || s2[-1] == '_') s2--;
4315                 if (strnEQ(s2-4,"perl",4))
4316                     while ((s = moreswitches(s)))
4317                         ;
4318             }
4319 #ifdef MACOS_TRADITIONAL
4320             /* We are always searching for the #!perl line in MacPerl,
4321              * so if we find it, still keep the line count correct
4322              * by counting lines we already skipped over
4323              */
4324             for (; maclines > 0 ; maclines--)
4325                 PerlIO_ungetc(rsfp, '\n');
4326
4327             break;
4328
4329         /* gMacPerl_AlwaysExtract is false in MPW tool */
4330         } else if (gMacPerl_AlwaysExtract) {
4331             ++maclines;
4332 #endif
4333         }
4334     }
4335 }
4336
4337
4338 STATIC void
4339 S_init_ids(pTHX)
4340 {
4341     dVAR;
4342     PL_uid = PerlProc_getuid();
4343     PL_euid = PerlProc_geteuid();
4344     PL_gid = PerlProc_getgid();
4345     PL_egid = PerlProc_getegid();
4346 #ifdef VMS
4347     PL_uid |= PL_gid << 16;
4348     PL_euid |= PL_egid << 16;
4349 #endif
4350     /* Should not happen: */
4351     CHECK_MALLOC_TAINT(PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
4352     PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
4353     /* BUG */
4354     /* PSz 27 Feb 04
4355      * Should go by suidscript, not uid!=euid: why disallow
4356      * system("ls") in scripts run from setuid things?
4357      * Or, is this run before we check arguments and set suidscript?
4358      * What about SETUID_SCRIPTS_ARE_SECURE_NOW: could we use fdscript then?
4359      * (We never have suidscript, can we be sure to have fdscript?)
4360      * Or must then go by UID checks? See comments in forbid_setid also.
4361      */
4362 }
4363
4364 /* This is used very early in the lifetime of the program,
4365  * before even the options are parsed, so PL_tainting has
4366  * not been initialized properly.  */
4367 bool
4368 Perl_doing_taint(int argc, char *argv[], char *envp[])
4369 {
4370 #ifndef PERL_IMPLICIT_SYS
4371     /* If we have PERL_IMPLICIT_SYS we can't call getuid() et alia
4372      * before we have an interpreter-- and the whole point of this
4373      * function is to be called at such an early stage.  If you are on
4374      * a system with PERL_IMPLICIT_SYS but you do have a concept of
4375      * "tainted because running with altered effective ids', you'll
4376      * have to add your own checks somewhere in here.  The two most
4377      * known samples of 'implicitness' are Win32 and NetWare, neither
4378      * of which has much of concept of 'uids'. */
4379     int uid  = PerlProc_getuid();
4380     int euid = PerlProc_geteuid();
4381     int gid  = PerlProc_getgid();
4382     int egid = PerlProc_getegid();
4383     (void)envp;
4384
4385 #ifdef VMS
4386     uid  |=  gid << 16;
4387     euid |= egid << 16;
4388 #endif
4389     if (uid && (euid != uid || egid != gid))
4390         return 1;
4391 #endif /* !PERL_IMPLICIT_SYS */
4392     /* This is a really primitive check; environment gets ignored only
4393      * if -T are the first chars together; otherwise one gets
4394      *  "Too late" message. */
4395     if ( argc > 1 && argv[1][0] == '-'
4396          && (argv[1][1] == 't' || argv[1][1] == 'T') )
4397         return 1;
4398     return 0;
4399 }
4400
4401 /* Passing the flag as a single char rather than a string is a slight space
4402    optimisation.  The only message that isn't /^-.$/ is
4403    "program input from stdin", which is substituted in place of '\0', which
4404    could never be a command line flag.  */
4405 STATIC void
4406 S_forbid_setid(pTHX_ const char flag, const bool suidscript) /* g */
4407 {
4408     dVAR;
4409     char string[3] = "-x";
4410     const char *message = "program input from stdin";
4411
4412     if (flag) {
4413         string[1] = flag;
4414         message = string;
4415     }
4416
4417 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
4418     if (PL_euid != PL_uid)
4419         Perl_croak(aTHX_ "No %s allowed while running setuid", message);
4420     if (PL_egid != PL_gid)
4421         Perl_croak(aTHX_ "No %s allowed while running setgid", message);
4422 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
4423     /* PSz 29 Feb 04
4424      * Checks for UID/GID above "wrong": why disallow
4425      *   perl -e 'print "Hello\n"'
4426      * from within setuid things?? Simply drop them: replaced by
4427      * fdscript/suidscript and #ifdef IAMSUID checks below.
4428      *
4429      * This may be too late for command-line switches. Will catch those on
4430      * the #! line, after finding the script name and setting up
4431      * fdscript/suidscript. Note that suidperl does not get around to
4432      * parsing (and checking) the switches on the #! line, but checks that
4433      * the two sets are identical.
4434      *
4435      * With SETUID_SCRIPTS_ARE_SECURE_NOW, could we use fdscript, also or
4436      * instead, or would that be "too late"? (We never have suidscript, can
4437      * we be sure to have fdscript?)
4438      *
4439      * Catch things with suidscript (in descendant of suidperl), even with
4440      * right UID/GID. Was already checked in suidperl, with #ifdef IAMSUID,
4441      * below; but I am paranoid.
4442      *
4443      * Also see comments about root running a setuid script, elsewhere.
4444      */
4445     if (suidscript)
4446         Perl_croak(aTHX_ "No %s allowed with (suid) fdscript", message);
4447 #ifdef IAMSUID
4448     /* PSz 11 Nov 03  Catch it in suidperl, always! */
4449     Perl_croak(aTHX_ "No %s allowed in suidperl", message);
4450 #endif /* IAMSUID */
4451 }
4452
4453 void
4454 Perl_init_debugger(pTHX)
4455 {
4456     dVAR;
4457     HV * const ostash = PL_curstash;
4458
4459     PL_curstash = PL_debstash;
4460     PL_dbargs = GvAV(gv_AVadd((gv_fetchpvs("DB::args", GV_ADDMULTI,
4461                                            SVt_PVAV))));
4462     AvREAL_off(PL_dbargs);
4463     PL_DBgv = gv_fetchpvs("DB::DB", GV_ADDMULTI, SVt_PVGV);
4464     PL_DBline = gv_fetchpvs("DB::dbline", GV_ADDMULTI, SVt_PVAV);
4465     PL_DBsub = gv_HVadd(gv_fetchpvs("DB::sub", GV_ADDMULTI, SVt_PVHV));
4466     PL_DBsingle = GvSV((gv_fetchpvs("DB::single", GV_ADDMULTI, SVt_PV)));
4467     sv_setiv(PL_DBsingle, 0);
4468     PL_DBtrace = GvSV((gv_fetchpvs("DB::trace", GV_ADDMULTI, SVt_PV)));
4469     sv_setiv(PL_DBtrace, 0);
4470     PL_DBsignal = GvSV((gv_fetchpvs("DB::signal", GV_ADDMULTI, SVt_PV)));
4471     sv_setiv(PL_DBsignal, 0);
4472     PL_curstash = ostash;
4473 }
4474
4475 #ifndef STRESS_REALLOC
4476 #define REASONABLE(size) (size)
4477 #else
4478 #define REASONABLE(size) (1) /* unreasonable */
4479 #endif
4480
4481 void
4482 Perl_init_stacks(pTHX)
4483 {
4484     dVAR;
4485     /* start with 128-item stack and 8K cxstack */
4486     PL_curstackinfo = new_stackinfo(REASONABLE(128),
4487                                  REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
4488     PL_curstackinfo->si_type = PERLSI_MAIN;
4489     PL_curstack = PL_curstackinfo->si_stack;
4490     PL_mainstack = PL_curstack;         /* remember in case we switch stacks */
4491
4492     PL_stack_base = AvARRAY(PL_curstack);
4493     PL_stack_sp = PL_stack_base;
4494     PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
4495
4496     Newx(PL_tmps_stack,REASONABLE(128),SV*);
4497     PL_tmps_floor = -1;
4498     PL_tmps_ix = -1;
4499     PL_tmps_max = REASONABLE(128);
4500
4501     Newx(PL_markstack,REASONABLE(32),I32);
4502     PL_markstack_ptr = PL_markstack;
4503     PL_markstack_max = PL_markstack + REASONABLE(32);
4504
4505     SET_MARK_OFFSET;
4506
4507     Newx(PL_scopestack,REASONABLE(32),I32);
4508     PL_scopestack_ix = 0;
4509     PL_scopestack_max = REASONABLE(32);
4510
4511     Newx(PL_savestack,REASONABLE(128),ANY);
4512     PL_savestack_ix = 0;
4513     PL_savestack_max = REASONABLE(128);
4514 }
4515
4516 #undef REASONABLE
4517
4518 STATIC void
4519 S_nuke_stacks(pTHX)
4520 {
4521     dVAR;
4522     while (PL_curstackinfo->si_next)
4523         PL_curstackinfo = PL_curstackinfo->si_next;
4524     while (PL_curstackinfo) {
4525         PERL_SI *p = PL_curstackinfo->si_prev;
4526         /* curstackinfo->si_stack got nuked by sv_free_arenas() */
4527         Safefree(PL_curstackinfo->si_cxstack);
4528         Safefree(PL_curstackinfo);
4529         PL_curstackinfo = p;
4530     }
4531     Safefree(PL_tmps_stack);
4532     Safefree(PL_markstack);
4533     Safefree(PL_scopestack);
4534     Safefree(PL_savestack);
4535 }
4536
4537
4538 STATIC void
4539 S_init_predump_symbols(pTHX)
4540 {
4541     dVAR;
4542     GV *tmpgv;
4543     IO *io;
4544
4545     sv_setpvs(get_sv("\"", TRUE), " ");
4546     PL_ofsgv = (GV*)SvREFCNT_inc(gv_fetchpvs(",", GV_ADD|GV_NOTQUAL, SVt_PV));
4547
4548     PL_stdingv = gv_fetchpvs("STDIN", GV_ADD|GV_NOTQUAL, SVt_PVIO);
4549     GvMULTI_on(PL_stdingv);
4550     io = GvIOp(PL_stdingv);
4551     IoTYPE(io) = IoTYPE_RDONLY;
4552     IoIFP(io) = PerlIO_stdin();
4553     tmpgv = gv_fetchpvs("stdin", GV_ADD|GV_NOTQUAL, SVt_PV);
4554     GvMULTI_on(tmpgv);
4555     GvIOp(tmpgv) = MUTABLE_IO(SvREFCNT_inc_simple(io));
4556
4557     tmpgv = gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVIO);
4558     GvMULTI_on(tmpgv);
4559     io = GvIOp(tmpgv);
4560     IoTYPE(io) = IoTYPE_WRONLY;
4561     IoOFP(io) = IoIFP(io) = PerlIO_stdout();
4562     setdefout(tmpgv);
4563     tmpgv = gv_fetchpvs("stdout", GV_ADD|GV_NOTQUAL, SVt_PV);
4564     GvMULTI_on(tmpgv);
4565     GvIOp(tmpgv) = MUTABLE_IO(SvREFCNT_inc_simple(io));
4566
4567     PL_stderrgv = gv_fetchpvs("STDERR", GV_ADD|GV_NOTQUAL, SVt_PVIO);
4568     GvMULTI_on(PL_stderrgv);
4569     io = GvIOp(PL_stderrgv);
4570     IoTYPE(io) = IoTYPE_WRONLY;
4571     IoOFP(io) = IoIFP(io) = PerlIO_stderr();
4572     tmpgv = gv_fetchpvs("stderr", GV_ADD|GV_NOTQUAL, SVt_PV);
4573     GvMULTI_on(tmpgv);
4574     GvIOp(tmpgv) = MUTABLE_IO(SvREFCNT_inc_simple(io));
4575
4576     PL_statname = newSV(0);             /* last filename we did stat on */
4577
4578     Safefree(PL_osname);
4579     PL_osname = savepv(OSNAME);
4580 }
4581
4582 void
4583 Perl_init_argv_symbols(pTHX_ register int argc, register char **argv)
4584 {
4585     dVAR;
4586
4587     PERL_ARGS_ASSERT_INIT_ARGV_SYMBOLS;
4588
4589     argc--,argv++;      /* skip name of script */
4590     if (PL_doswitches) {
4591         for (; argc > 0 && **argv == '-'; argc--,argv++) {
4592             char *s;
4593             if (!argv[0][1])
4594                 break;
4595             if (argv[0][1] == '-' && !argv[0][2]) {
4596                 argc--,argv++;
4597                 break;
4598             }
4599             if ((s = strchr(argv[0], '='))) {
4600                 const char *const start_name = argv[0] + 1;
4601                 sv_setpv(GvSV(gv_fetchpvn_flags(start_name, s - start_name,
4602                                                 TRUE, SVt_PV)), s + 1);
4603             }
4604             else
4605                 sv_setiv(GvSV(gv_fetchpv(argv[0]+1, GV_ADD, SVt_PV)),1);
4606         }
4607     }
4608     if ((PL_argvgv = gv_fetchpvs("ARGV", GV_ADD|GV_NOTQUAL, SVt_PVAV))) {
4609         GvMULTI_on(PL_argvgv);
4610         (void)gv_AVadd(PL_argvgv);
4611         av_clear(GvAVn(PL_argvgv));
4612         for (; argc > 0; argc--,argv++) {
4613             SV * const sv = newSVpv(argv[0],0);
4614             av_push(GvAVn(PL_argvgv),sv);
4615             if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) {
4616                  if (PL_unicode & PERL_UNICODE_ARGV_FLAG)
4617                       SvUTF8_on(sv);
4618             }
4619             if (PL_unicode & PERL_UNICODE_WIDESYSCALLS_FLAG) /* Sarathy? */
4620                  (void)sv_utf8_decode(sv);
4621         }
4622     }
4623 }
4624
4625 STATIC void
4626 S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env)
4627 {
4628     dVAR;
4629     GV* tmpgv;
4630
4631     PERL_ARGS_ASSERT_INIT_POSTDUMP_SYMBOLS;
4632
4633     PL_toptarget = newSV_type(SVt_PVFM);
4634     sv_setpvs(PL_toptarget, "");
4635     PL_bodytarget = newSV_type(SVt_PVFM);
4636     sv_setpvs(PL_bodytarget, "");
4637     PL_formtarget = PL_bodytarget;
4638
4639     TAINT;
4640
4641     init_argv_symbols(argc,argv);
4642
4643     if ((tmpgv = gv_fetchpvs("0", GV_ADD|GV_NOTQUAL, SVt_PV))) {
4644 #ifdef MACOS_TRADITIONAL
4645         /* $0 is not majick on a Mac */
4646         sv_setpv(GvSV(tmpgv),MacPerl_MPWFileName(PL_origfilename));
4647 #else
4648         sv_setpv(GvSV(tmpgv),PL_origfilename);
4649         {
4650             GV * const gv = gv_fetchpv("0", GV_ADD, SVt_PV);
4651             if (gv)
4652                 sv_magic(GvSV(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, "0", 1);
4653         }
4654 #endif
4655     }
4656     if ((PL_envgv = gv_fetchpvs("ENV", GV_ADD|GV_NOTQUAL, SVt_PVHV))) {
4657         HV *hv;
4658         bool env_is_not_environ;
4659         GvMULTI_on(PL_envgv);
4660         hv = GvHVn(PL_envgv);
4661         hv_magic(hv, NULL, PERL_MAGIC_env);
4662 #ifndef PERL_MICRO
4663 #ifdef USE_ENVIRON_ARRAY
4664         /* Note that if the supplied env parameter is actually a copy
4665            of the global environ then it may now point to free'd memory
4666            if the environment has been modified since. To avoid this
4667            problem we treat env==NULL as meaning 'use the default'
4668         */
4669         if (!env)
4670             env = environ;
4671         env_is_not_environ = env != environ;
4672         if (env_is_not_environ
4673 #  ifdef USE_ITHREADS
4674             && PL_curinterp == aTHX
4675 #  endif
4676            )
4677         {
4678             environ[0] = NULL;
4679         }
4680         if (env) {
4681           char *s, *old_var;
4682           SV *sv;
4683           for (; *env; env++) {
4684             old_var = *env;
4685
4686             if (!(s = strchr(old_var,'=')) || s == old_var)
4687                 continue;
4688
4689 #if defined(MSDOS) && !defined(DJGPP)
4690             *s = '\0';
4691             (void)strupr(old_var);
4692             *s = '=';
4693 #endif
4694             sv = newSVpv(s+1, 0);
4695             (void)hv_store(hv, old_var, s - old_var, sv, 0);
4696             if (env_is_not_environ)
4697                 mg_set(sv);
4698           }
4699       }
4700 #endif /* USE_ENVIRON_ARRAY */
4701 #endif /* !PERL_MICRO */
4702     }
4703     TAINT_NOT;
4704     if ((tmpgv = gv_fetchpvs("$", GV_ADD|GV_NOTQUAL, SVt_PV))) {
4705         SvREADONLY_off(GvSV(tmpgv));
4706         sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
4707         SvREADONLY_on(GvSV(tmpgv));
4708     }
4709 #ifdef THREADS_HAVE_PIDS
4710     PL_ppid = (IV)getppid();
4711 #endif
4712
4713     /* touch @F array to prevent spurious warnings 20020415 MJD */
4714     if (PL_minus_a) {
4715       (void) get_av("main::F", TRUE | GV_ADDMULTI);
4716     }
4717 }
4718
4719 STATIC void
4720 S_init_perllib(pTHX)
4721 {
4722     dVAR;
4723     char *s;
4724     if (!PL_tainting) {
4725 #ifndef VMS
4726         s = PerlEnv_getenv("PERL5LIB");
4727 /*
4728  * It isn't possible to delete an environment variable with
4729  * PERL_USE_SAFE_PUTENV set unless unsetenv() is also available, so in that
4730  * case we treat PERL5LIB as undefined if it has a zero-length value.
4731  */
4732 #if defined(PERL_USE_SAFE_PUTENV) && ! defined(HAS_UNSETENV)
4733         if (s && *s != '\0')
4734 #else
4735         if (s)
4736 #endif
4737             incpush(s, TRUE, TRUE, TRUE, FALSE);
4738         else
4739             incpush(PerlEnv_getenv("PERLLIB"), FALSE, FALSE, TRUE, FALSE);
4740 #else /* VMS */
4741         /* Treat PERL5?LIB as a possible search list logical name -- the
4742          * "natural" VMS idiom for a Unix path string.  We allow each
4743          * element to be a set of |-separated directories for compatibility.
4744          */
4745         char buf[256];
4746         int idx = 0;
4747         if (my_trnlnm("PERL5LIB",buf,0))
4748             do { incpush(buf,TRUE,TRUE,TRUE,FALSE); } while (my_trnlnm("PERL5LIB",buf,++idx));
4749         else
4750             while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE,FALSE,TRUE,FALSE);
4751 #endif /* VMS */
4752     }
4753
4754 /* Use the ~-expanded versions of APPLLIB (undocumented),
4755     ARCHLIB PRIVLIB SITEARCH SITELIB VENDORARCH and VENDORLIB
4756 */
4757 #ifdef APPLLIB_EXP
4758     incpush(APPLLIB_EXP, TRUE, TRUE, TRUE, TRUE);
4759 #endif
4760
4761 #ifdef ARCHLIB_EXP
4762     incpush(ARCHLIB_EXP, FALSE, FALSE, TRUE, TRUE);
4763 #endif
4764 #ifdef MACOS_TRADITIONAL
4765     {
4766         Stat_t tmpstatbuf;
4767         SV * privdir = newSV(0);
4768         char * macperl = PerlEnv_getenv("MACPERL");
4769
4770         if (!macperl)
4771             macperl = "";
4772
4773         Perl_sv_setpvf(aTHX_ privdir, "%slib:", macperl);
4774         if (PerlLIO_stat(SvPVX(privdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode))
4775             incpush(SvPVX(privdir), TRUE, FALSE, TRUE, FALSE);
4776         Perl_sv_setpvf(aTHX_ privdir, "%ssite_perl:", macperl);
4777         if (PerlLIO_stat(SvPVX(privdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode))
4778             incpush(SvPVX(privdir), TRUE, FALSE, TRUE, FALSE);
4779
4780         SvREFCNT_dec(privdir);
4781     }
4782     if (!PL_tainting)
4783         incpush(":", FALSE, FALSE, TRUE, FALSE);
4784 #else
4785 #ifndef PRIVLIB_EXP
4786 #  define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
4787 #endif
4788 #if defined(WIN32)
4789     incpush(PRIVLIB_EXP, TRUE, FALSE, TRUE, TRUE);
4790 #else
4791     incpush(PRIVLIB_EXP, FALSE, FALSE, TRUE, TRUE);
4792 #endif
4793
4794 #ifdef SITEARCH_EXP
4795     /* sitearch is always relative to sitelib on Windows for
4796      * DLL-based path intuition to work correctly */
4797 #  if !defined(WIN32)
4798     incpush(SITEARCH_EXP, FALSE, FALSE, TRUE, TRUE);
4799 #  endif
4800 #endif
4801
4802 #ifdef SITELIB_EXP
4803 #  if defined(WIN32)
4804     /* this picks up sitearch as well */
4805     incpush(SITELIB_EXP, TRUE, FALSE, TRUE, TRUE);
4806 #  else
4807     incpush(SITELIB_EXP, FALSE, FALSE, TRUE, TRUE);
4808 #  endif
4809 #endif
4810
4811 #if defined(SITELIB_STEM) && defined(PERL_INC_VERSION_LIST)
4812     /* Search for version-specific dirs below here */
4813     incpush(SITELIB_STEM, FALSE, TRUE, TRUE, TRUE);
4814 #endif
4815
4816 #ifdef PERL_VENDORARCH_EXP
4817     /* vendorarch is always relative to vendorlib on Windows for
4818      * DLL-based path intuition to work correctly */
4819 #  if !defined(WIN32)
4820     incpush(PERL_VENDORARCH_EXP, FALSE, FALSE, TRUE, TRUE);
4821 #  endif
4822 #endif
4823
4824 #ifdef PERL_VENDORLIB_EXP
4825 #  if defined(WIN32)
4826     incpush(PERL_VENDORLIB_EXP, TRUE, FALSE, TRUE, TRUE);       /* this picks up vendorarch as well */
4827 #  else
4828     incpush(PERL_VENDORLIB_EXP, FALSE, FALSE, TRUE, TRUE);
4829 #  endif
4830 #endif
4831
4832 #if defined(PERL_VENDORLIB_STEM) && defined(PERL_INC_VERSION_LIST)
4833     /* Search for version-specific dirs below here */
4834     incpush(PERL_VENDORLIB_STEM, FALSE, TRUE, TRUE, TRUE);
4835 #endif
4836
4837 #ifdef PERL_OTHERLIBDIRS
4838     incpush(PERL_OTHERLIBDIRS, TRUE, TRUE, TRUE, TRUE);
4839 #endif
4840
4841     if (!PL_tainting)
4842         incpush(".", FALSE, FALSE, TRUE, FALSE);
4843 #endif /* MACOS_TRADITIONAL */
4844 }
4845
4846 #if defined(DOSISH) || defined(EPOC) || defined(__SYMBIAN32__)
4847 #    define PERLLIB_SEP ';'
4848 #else
4849 #  if defined(VMS)
4850 #    define PERLLIB_SEP '|'
4851 #  else
4852 #    if defined(MACOS_TRADITIONAL)
4853 #      define PERLLIB_SEP ','
4854 #    else
4855 #      define PERLLIB_SEP ':'
4856 #    endif
4857 #  endif
4858 #endif
4859 #ifndef PERLLIB_MANGLE
4860 #  define PERLLIB_MANGLE(s,n) (s)
4861 #endif
4862
4863 /* Push a directory onto @INC if it exists.
4864    Generate a new SV if we do this, to save needing to copy the SV we push
4865    onto @INC  */
4866 STATIC SV *
4867 S_incpush_if_exists(pTHX_ SV *dir)
4868 {
4869     dVAR;
4870     Stat_t tmpstatbuf;
4871
4872     PERL_ARGS_ASSERT_INCPUSH_IF_EXISTS;
4873
4874     if (PerlLIO_stat(SvPVX_const(dir), &tmpstatbuf) >= 0 &&
4875         S_ISDIR(tmpstatbuf.st_mode)) {
4876         av_push(GvAVn(PL_incgv), dir);
4877         dir = newSV(0);
4878     }
4879     return dir;
4880 }
4881
4882 STATIC void
4883 S_incpush(pTHX_ const char *dir, bool addsubdirs, bool addoldvers, bool usesep,
4884           bool canrelocate)
4885 {
4886     dVAR;
4887     SV *subdir = NULL;
4888     const char *p = dir;
4889
4890     if (!p || !*p)
4891         return;
4892
4893     if (addsubdirs || addoldvers) {
4894         subdir = newSV(0);
4895     }
4896
4897     /* Break at all separators */
4898     while (p && *p) {
4899         SV *libdir = newSV(0);
4900         const char *s;
4901
4902         /* skip any consecutive separators */
4903         if (usesep) {
4904             while ( *p == PERLLIB_SEP ) {
4905                 /* Uncomment the next line for PATH semantics */
4906                 /* av_push(GvAVn(PL_incgv), newSVpvs(".")); */
4907                 p++;
4908             }
4909         }
4910
4911         if ( usesep && (s = strchr(p, PERLLIB_SEP)) != NULL ) {
4912             sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
4913                       (STRLEN)(s - p));
4914             p = s + 1;
4915         }
4916         else {
4917             sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
4918             p = NULL;   /* break out */
4919         }
4920 #ifdef MACOS_TRADITIONAL
4921         if (!strchr(SvPVX(libdir), ':')) {
4922             char buf[256];
4923
4924             sv_setpv(libdir, MacPerl_CanonDir(SvPVX(libdir), buf, 0));
4925         }
4926         if (SvPVX(libdir)[SvCUR(libdir)-1] != ':')
4927             sv_catpvs(libdir, ":");
4928 #endif
4929
4930         /* Do the if() outside the #ifdef to avoid warnings about an unused
4931            parameter.  */
4932         if (canrelocate) {
4933 #ifdef PERL_RELOCATABLE_INC
4934         /*
4935          * Relocatable include entries are marked with a leading .../
4936          *
4937          * The algorithm is
4938          * 0: Remove that leading ".../"
4939          * 1: Remove trailing executable name (anything after the last '/')
4940          *    from the perl path to give a perl prefix
4941          * Then
4942          * While the @INC element starts "../" and the prefix ends with a real
4943          * directory (ie not . or ..) chop that real directory off the prefix
4944          * and the leading "../" from the @INC element. ie a logical "../"
4945          * cleanup
4946          * Finally concatenate the prefix and the remainder of the @INC element
4947          * The intent is that /usr/local/bin/perl and .../../lib/perl5
4948          * generates /usr/local/lib/perl5
4949          */
4950             const char *libpath = SvPVX(libdir);
4951             STRLEN libpath_len = SvCUR(libdir);
4952             if (libpath_len >= 4 && memEQ (libpath, ".../", 4)) {
4953                 /* Game on!  */
4954                 SV * const caret_X = get_sv("\030", 0);
4955                 /* Going to use the SV just as a scratch buffer holding a C
4956                    string:  */
4957                 SV *prefix_sv;
4958                 char *prefix;
4959                 char *lastslash;
4960
4961                 /* $^X is *the* source of taint if tainting is on, hence
4962                    SvPOK() won't be true.  */
4963                 assert(caret_X);
4964                 assert(SvPOKp(caret_X));
4965                 prefix_sv = newSVpvn_flags(SvPVX(caret_X), SvCUR(caret_X),
4966                                            SvUTF8(caret_X));
4967                 /* Firstly take off the leading .../
4968                    If all else fail we'll do the paths relative to the current
4969                    directory.  */
4970                 sv_chop(libdir, libpath + 4);
4971                 /* Don't use SvPV as we're intentionally bypassing taining,
4972                    mortal copies that the mg_get of tainting creates, and
4973                    corruption that seems to come via the save stack.
4974                    I guess that the save stack isn't correctly set up yet.  */
4975                 libpath = SvPVX(libdir);
4976                 libpath_len = SvCUR(libdir);
4977
4978                 /* This would work more efficiently with memrchr, but as it's
4979                    only a GNU extension we'd need to probe for it and
4980                    implement our own. Not hard, but maybe not worth it?  */
4981
4982                 prefix = SvPVX(prefix_sv);
4983                 lastslash = strrchr(prefix, '/');
4984
4985                 /* First time in with the *lastslash = '\0' we just wipe off
4986                    the trailing /perl from (say) /usr/foo/bin/perl
4987                 */
4988                 if (lastslash) {
4989                     SV *tempsv;
4990                     while ((*lastslash = '\0'), /* Do that, come what may.  */
4991                            (libpath_len >= 3 && memEQ(libpath, "../", 3)
4992                             && (lastslash = strrchr(prefix, '/')))) {
4993                         if (lastslash[1] == '\0'
4994                             || (lastslash[1] == '.'
4995                                 && (lastslash[2] == '/' /* ends "/."  */
4996                                     || (lastslash[2] == '/'
4997                                         && lastslash[3] == '/' /* or "/.."  */
4998                                         )))) {
4999                             /* Prefix ends "/" or "/." or "/..", any of which
5000                                are fishy, so don't do any more logical cleanup.
5001                             */
5002                             break;
5003                         }
5004                         /* Remove leading "../" from path  */
5005                         libpath += 3;
5006                         libpath_len -= 3;
5007                         /* Next iteration round the loop removes the last
5008                            directory name from prefix by writing a '\0' in
5009                            the while clause.  */
5010                     }
5011                     /* prefix has been terminated with a '\0' to the correct
5012                        length. libpath points somewhere into the libdir SV.
5013                        We need to join the 2 with '/' and drop the result into
5014                        libdir.  */
5015                     tempsv = Perl_newSVpvf(aTHX_ "%s/%s", prefix, libpath);
5016                     SvREFCNT_dec(libdir);
5017                     /* And this is the new libdir.  */
5018                     libdir = tempsv;
5019                     if (PL_tainting &&
5020                         (PL_uid != PL_euid || PL_gid != PL_egid)) {
5021                         /* Need to taint reloccated paths if running set ID  */
5022                         SvTAINTED_on(libdir);
5023                     }
5024                 }
5025                 SvREFCNT_dec(prefix_sv);
5026             }
5027 #endif
5028         }
5029         /*
5030          * BEFORE pushing libdir onto @INC we may first push version- and
5031          * archname-specific sub-directories.
5032          */
5033         if (addsubdirs || addoldvers) {
5034 #ifdef PERL_INC_VERSION_LIST
5035             /* Configure terminates PERL_INC_VERSION_LIST with a NULL */
5036             const char * const incverlist[] = { PERL_INC_VERSION_LIST };
5037             const char * const *incver;
5038 #endif
5039 #ifdef VMS
5040             char *unix;
5041             STRLEN len;
5042
5043             if ((unix = tounixspec_ts(SvPV(libdir,len),NULL)) != NULL) {
5044                 len = strlen(unix);
5045                 while (unix[len-1] == '/') len--;  /* Cosmetic */
5046                 sv_usepvn(libdir,unix,len);
5047             }
5048             else
5049                 PerlIO_printf(Perl_error_log,
5050                               "Failed to unixify @INC element \"%s\"\n",
5051                               SvPV(libdir,len));
5052 #endif
5053             if (addsubdirs) {
5054 #ifdef MACOS_TRADITIONAL
5055 #define PERL_AV_SUFFIX_FMT      ""
5056 #define PERL_ARCH_FMT           "%s:"
5057 #define PERL_ARCH_FMT_PATH      PERL_FS_VER_FMT PERL_AV_SUFFIX_FMT
5058 #else
5059 #define PERL_AV_SUFFIX_FMT      "/"
5060 #define PERL_ARCH_FMT           "/%s"
5061 #define PERL_ARCH_FMT_PATH      PERL_AV_SUFFIX_FMT PERL_FS_VER_FMT
5062 #endif
5063                 /* .../version/archname if -d .../version/archname */
5064                 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT_PATH PERL_ARCH_FMT,
5065                                SVfARG(libdir),
5066                                (int)PERL_REVISION, (int)PERL_VERSION,
5067                                (int)PERL_SUBVERSION, ARCHNAME);
5068                 subdir = S_incpush_if_exists(aTHX_ subdir);
5069
5070                 /* .../version if -d .../version */
5071                 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT_PATH,
5072                                SVfARG(libdir),
5073                                (int)PERL_REVISION, (int)PERL_VERSION,
5074                                (int)PERL_SUBVERSION);
5075                 subdir = S_incpush_if_exists(aTHX_ subdir);
5076
5077                 /* .../archname if -d .../archname */
5078                 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT,
5079                                SVfARG(libdir), ARCHNAME);
5080                 subdir = S_incpush_if_exists(aTHX_ subdir);
5081
5082             }
5083
5084 #ifdef PERL_INC_VERSION_LIST
5085             if (addoldvers) {
5086                 for (incver = incverlist; *incver; incver++) {
5087                     /* .../xxx if -d .../xxx */
5088                     Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT,
5089                                    SVfARG(libdir), *incver);
5090                     subdir = S_incpush_if_exists(aTHX_ subdir);
5091                 }
5092             }
5093 #endif
5094         }
5095
5096         /* finally push this lib directory on the end of @INC */
5097         av_push(GvAVn(PL_incgv), libdir);
5098     }
5099     if (subdir) {
5100         assert (SvREFCNT(subdir) == 1);
5101         SvREFCNT_dec(subdir);
5102     }
5103 }
5104
5105
5106 void
5107 Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
5108 {
5109     dVAR;
5110     SV *atsv;
5111     volatile const line_t oldline = PL_curcop ? CopLINE(PL_curcop) : 0;
5112     CV *cv;
5113     STRLEN len;
5114     int ret;
5115     dJMPENV;
5116
5117     PERL_ARGS_ASSERT_CALL_LIST;
5118
5119     while (av_len(paramList) >= 0) {
5120         cv = MUTABLE_CV(av_shift(paramList));
5121         if (PL_savebegin) {
5122             if (paramList == PL_beginav) {
5123                 /* save PL_beginav for compiler */
5124                 Perl_av_create_and_push(aTHX_ &PL_beginav_save, MUTABLE_SV(cv));
5125             }
5126             else if (paramList == PL_checkav) {
5127                 /* save PL_checkav for compiler */
5128                 Perl_av_create_and_push(aTHX_ &PL_checkav_save, MUTABLE_SV(cv));
5129             }
5130             else if (paramList == PL_unitcheckav) {
5131                 /* save PL_unitcheckav for compiler */
5132                 Perl_av_create_and_push(aTHX_ &PL_unitcheckav_save, MUTABLE_SV(cv));
5133             }
5134         } else {
5135             if (!PL_madskills)
5136                 SAVEFREESV(cv);
5137         }
5138         JMPENV_PUSH(ret);
5139         switch (ret) {
5140         case 0:
5141 #ifdef PERL_MAD
5142             if (PL_madskills)
5143                 PL_madskills |= 16384;
5144 #endif
5145             CALL_LIST_BODY(cv);
5146 #ifdef PERL_MAD
5147             if (PL_madskills)
5148                 PL_madskills &= ~16384;
5149 #endif
5150             atsv = ERRSV;
5151             (void)SvPV_const(atsv, len);
5152             if (len) {
5153                 PL_curcop = &PL_compiling;
5154                 CopLINE_set(PL_curcop, oldline);
5155                 if (paramList == PL_beginav)
5156                     sv_catpvs(atsv, "BEGIN failed--compilation aborted");
5157                 else
5158                     Perl_sv_catpvf(aTHX_ atsv,
5159                                    "%s failed--call queue aborted",
5160                                    paramList == PL_checkav ? "CHECK"
5161                                    : paramList == PL_initav ? "INIT"
5162                                    : paramList == PL_unitcheckav ? "UNITCHECK"
5163                                    : "END");
5164                 while (PL_scopestack_ix > oldscope)
5165                     LEAVE;
5166                 JMPENV_POP;
5167                 Perl_croak(aTHX_ "%"SVf"", SVfARG(atsv));
5168             }
5169             break;
5170         case 1:
5171             STATUS_ALL_FAILURE;
5172             /* FALL THROUGH */
5173         case 2:
5174             /* my_exit() was called */
5175             while (PL_scopestack_ix > oldscope)
5176                 LEAVE;
5177             FREETMPS;
5178             PL_curstash = PL_defstash;
5179             PL_curcop = &PL_compiling;
5180             CopLINE_set(PL_curcop, oldline);
5181             JMPENV_POP;
5182             if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED)) {
5183                 if (paramList == PL_beginav)
5184                     Perl_croak(aTHX_ "BEGIN failed--compilation aborted");
5185                 else
5186                     Perl_croak(aTHX_ "%s failed--call queue aborted",
5187                                paramList == PL_checkav ? "CHECK"
5188                                : paramList == PL_initav ? "INIT"
5189                                : paramList == PL_unitcheckav ? "UNITCHECK"
5190                                : "END");
5191             }
5192             my_exit_jump();
5193             /* NOTREACHED */
5194         case 3:
5195             if (PL_restartop) {
5196                 PL_curcop = &PL_compiling;
5197                 CopLINE_set(PL_curcop, oldline);
5198                 JMPENV_JUMP(3);
5199             }
5200             PerlIO_printf(Perl_error_log, "panic: restartop\n");
5201             FREETMPS;
5202             break;
5203         }
5204         JMPENV_POP;
5205     }
5206 }
5207
5208 void
5209 Perl_my_exit(pTHX_ U32 status)
5210 {
5211     dVAR;
5212     switch (status) {
5213     case 0:
5214         STATUS_ALL_SUCCESS;
5215         break;
5216     case 1:
5217         STATUS_ALL_FAILURE;
5218         break;
5219     default:
5220         STATUS_EXIT_SET(status);
5221         break;
5222     }
5223     my_exit_jump();
5224 }
5225
5226 void
5227 Perl_my_failure_exit(pTHX)
5228 {
5229     dVAR;
5230 #ifdef VMS
5231      /* We have been called to fall on our sword.  The desired exit code
5232       * should be already set in STATUS_UNIX, but could be shifted over
5233       * by 8 bits.  STATUS_UNIX_EXIT_SET will handle the cases where a
5234       * that code is set.
5235       *
5236       * If an error code has not been set, then force the issue.
5237       */
5238     if (MY_POSIX_EXIT) {
5239
5240         /* In POSIX_EXIT mode follow Perl documentations and use 255 for
5241          * the exit code when there isn't an error.
5242          */
5243
5244         if (STATUS_UNIX == 0)
5245             STATUS_UNIX_EXIT_SET(255);
5246         else {
5247             STATUS_UNIX_EXIT_SET(STATUS_UNIX);
5248
5249             /* The exit code could have been set by $? or vmsish which
5250              * means that it may not be fatal.  So convert
5251              * success/warning codes to fatal.
5252              */
5253             if ((STATUS_NATIVE & (STS$K_SEVERE|STS$K_ERROR)) == 0)
5254                 STATUS_UNIX_EXIT_SET(255);
5255         }
5256     }
5257     else {
5258         /* Traditionally Perl on VMS always expects a Fatal Error. */
5259         if (vaxc$errno & 1) {
5260
5261             /* So force success status to failure */
5262             if (STATUS_NATIVE & 1)
5263                 STATUS_ALL_FAILURE;
5264         }
5265         else {
5266             if (!vaxc$errno) {
5267                 STATUS_UNIX = EINTR; /* In case something cares */
5268                 STATUS_ALL_FAILURE;
5269             }
5270             else {
5271                 int severity;
5272                 STATUS_NATIVE = vaxc$errno; /* Should already be this */
5273
5274                 /* Encode the severity code */
5275                 severity = STATUS_NATIVE & STS$M_SEVERITY;
5276                 STATUS_UNIX = (severity ? severity : 1) << 8;
5277
5278                 /* Perl expects this to be a fatal error */
5279                 if (severity != STS$K_SEVERE)
5280                     STATUS_ALL_FAILURE;
5281             }
5282         }
5283     }
5284
5285 #else
5286     int exitstatus;
5287     if (errno & 255)
5288         STATUS_UNIX_SET(errno);
5289     else {
5290         exitstatus = STATUS_UNIX >> 8;
5291         if (exitstatus & 255)
5292             STATUS_UNIX_SET(exitstatus);
5293         else
5294             STATUS_UNIX_SET(255);
5295     }
5296 #endif
5297     my_exit_jump();
5298 }
5299
5300 STATIC void
5301 S_my_exit_jump(pTHX)
5302 {
5303     dVAR;
5304
5305     if (PL_e_script) {
5306         SvREFCNT_dec(PL_e_script);
5307         PL_e_script = NULL;
5308     }
5309
5310     POPSTACK_TO(PL_mainstack);
5311     dounwind(-1);
5312     LEAVE_SCOPE(0);
5313
5314     JMPENV_JUMP(2);
5315 }
5316
5317 static I32
5318 read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen)
5319 {
5320     dVAR;
5321     const char * const p  = SvPVX_const(PL_e_script);
5322     const char *nl = strchr(p, '\n');
5323
5324     PERL_UNUSED_ARG(idx);
5325     PERL_UNUSED_ARG(maxlen);
5326
5327     nl = (nl) ? nl+1 : SvEND(PL_e_script);
5328     if (nl-p == 0) {
5329         filter_del(read_e_script);
5330         return 0;
5331     }
5332     sv_catpvn(buf_sv, p, nl-p);
5333     sv_chop(PL_e_script, nl);
5334     return 1;
5335 }
5336
5337 /*
5338  * Local variables:
5339  * c-indentation-style: bsd
5340  * c-basic-offset: 4
5341  * indent-tabs-mode: t
5342  * End:
5343  *
5344  * ex: set ts=8 sts=4 sw=4 noet:
5345  */