perl.c

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