perl.c

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