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