perl.c

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