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