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