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             goto reswitch;
1791         case 'S':
1792             forbid_setid('S', -1);
1793             dosearch = TRUE;
1794             s++;
1795             goto reswitch;
1796         case 'V':
1797             {
1798                 SV *opts_prog;
1799
1800                 Perl_av_create_and_push(aTHX_ &PL_preambleav, newSVpvs("use Config;"));
1801                 if (*++s != ':')  {
1802                     STRLEN opts;
1803
1804                     opts_prog = newSVpvs("print Config::myconfig(),");
1805 #ifdef VMS
1806                     sv_catpvs(opts_prog,"\"\\nCharacteristics of this PERLSHR image: \\n\",");
1807 #else
1808                     sv_catpvs(opts_prog,"\"\\nCharacteristics of this binary (from libperl): \\n\",");
1809 #endif
1810                     opts = SvCUR(opts_prog);
1811
1812                     Perl_sv_catpv(aTHX_ opts_prog,"\"  Compile-time options:"
1813 #  ifdef DEBUGGING
1814                              " DEBUGGING"
1815 #  endif
1816 #  ifdef DEBUG_LEAKING_SCALARS
1817                              " DEBUG_LEAKING_SCALARS"
1818 #  endif
1819 #  ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
1820                              " DEBUG_LEAKING_SCALARS_FORK_DUMP"
1821 #  endif
1822 #  ifdef FAKE_THREADS
1823                              " FAKE_THREADS"
1824 #  endif
1825 #  ifdef MULTIPLICITY
1826                              " MULTIPLICITY"
1827 #  endif
1828 #  ifdef MYMALLOC
1829                              " MYMALLOC"
1830 #  endif
1831 #  ifdef NO_MATHOMS
1832                             " NO_MATHOMS"
1833 #  endif
1834 #  ifdef PERL_DEBUG_READONLY_OPS
1835                              " PERL_DEBUG_READONLY_OPS"
1836 #  endif
1837 #  ifdef PERL_DONT_CREATE_GVSV
1838                              " PERL_DONT_CREATE_GVSV"
1839 #  endif
1840 #  ifdef PERL_GLOBAL_STRUCT
1841                              " PERL_GLOBAL_STRUCT"
1842 #  endif
1843 #  ifdef PERL_IMPLICIT_CONTEXT
1844                              " PERL_IMPLICIT_CONTEXT"
1845 #  endif
1846 #  ifdef PERL_IMPLICIT_SYS
1847                              " PERL_IMPLICIT_SYS"
1848 #  endif
1849 #  ifdef PERL_MAD
1850                              " PERL_MAD"
1851 #  endif
1852 #  ifdef PERL_MALLOC_WRAP
1853                              " PERL_MALLOC_WRAP"
1854 #  endif
1855 #  ifdef PERL_MEM_LOG
1856                              " PERL_MEM_LOG"
1857 #  endif
1858 #  ifdef PERL_MEM_LOG_ENV
1859                              " PERL_MEM_LOG_ENV"
1860 #  endif
1861 #  ifdef PERL_MEM_LOG_ENV_FD
1862                              " PERL_MEM_LOG_ENV_FD"
1863 #  endif
1864 #  ifdef PERL_MEM_LOG_STDERR
1865                              " PERL_MEM_LOG_STDERR"
1866 #  endif
1867 #  ifdef PERL_MEM_LOG_TIMESTAMP
1868                              " PERL_MEM_LOG_TIMESTAMP"
1869 #  endif
1870 #  ifdef PERL_NEED_APPCTX
1871                              " PERL_NEED_APPCTX"
1872 #  endif
1873 #  ifdef PERL_NEED_TIMESBASE
1874                              " PERL_NEED_TIMESBASE"
1875 #  endif
1876 #  ifdef PERL_OLD_COPY_ON_WRITE
1877                              " PERL_OLD_COPY_ON_WRITE"
1878 #  endif
1879 #  ifdef PERL_POISON
1880                              " PERL_POISON"
1881 #  endif
1882 #  ifdef PERL_TRACK_MEMPOOL
1883                              " PERL_TRACK_MEMPOOL"
1884 #  endif
1885 #  ifdef PERL_USE_SAFE_PUTENV
1886                              " PERL_USE_SAFE_PUTENV"
1887 #  endif
1888 #  ifdef PERL_USES_PL_PIDSTATUS
1889                              " PERL_USES_PL_PIDSTATUS"
1890 #  endif
1891 #  ifdef PL_OP_SLAB_ALLOC
1892                              " PL_OP_SLAB_ALLOC"
1893 #  endif
1894 #  ifdef THREADS_HAVE_PIDS
1895                              " THREADS_HAVE_PIDS"
1896 #  endif
1897 #  ifdef USE_64_BIT_ALL
1898                              " USE_64_BIT_ALL"
1899 #  endif
1900 #  ifdef USE_64_BIT_INT
1901                              " USE_64_BIT_INT"
1902 #  endif
1903 #  ifdef USE_ITHREADS
1904                              " USE_ITHREADS"
1905 #  endif
1906 #  ifdef USE_LARGE_FILES
1907                              " USE_LARGE_FILES"
1908 #  endif
1909 #  ifdef USE_LONG_DOUBLE
1910                              " USE_LONG_DOUBLE"
1911 #  endif
1912 #  ifdef USE_PERLIO
1913                              " USE_PERLIO"
1914 #  endif
1915 #  ifdef USE_REENTRANT_API
1916                              " USE_REENTRANT_API"
1917 #  endif
1918 #  ifdef USE_SFIO
1919                              " USE_SFIO"
1920 #  endif
1921 #  ifdef USE_SITECUSTOMIZE
1922                              " USE_SITECUSTOMIZE"
1923 #  endif
1924 #  ifdef USE_SOCKS
1925                              " USE_SOCKS"
1926 #  endif
1927                              );
1928
1929                     while (SvCUR(opts_prog) > opts+76) {
1930                         /* find last space after "options: " and before col 76
1931                          */
1932
1933                         const char *space;
1934                         char * const pv = SvPV_nolen(opts_prog);
1935                         const char c = pv[opts+76];
1936                         pv[opts+76] = '\0';
1937                         space = strrchr(pv+opts+26, ' ');
1938                         pv[opts+76] = c;
1939                         if (!space) break; /* "Can't happen" */
1940
1941                         /* break the line before that space */
1942
1943                         opts = space - pv;
1944                         Perl_sv_insert(aTHX_ opts_prog, opts, 0,
1945                                   STR_WITH_LEN("\\n                       "));
1946                     }
1947
1948                     sv_catpvs(opts_prog,"\\n\",");
1949
1950 #if defined(LOCAL_PATCH_COUNT)
1951                     if (LOCAL_PATCH_COUNT > 0) {
1952                         int i;
1953                         sv_catpvs(opts_prog,
1954                                  "\"  Locally applied patches:\\n\",");
1955                         for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
1956                             if (PL_localpatches[i])
1957                                 Perl_sv_catpvf(aTHX_ opts_prog,"q%c\t%s\n%c,",
1958                                                0, PL_localpatches[i], 0);
1959                         }
1960                     }
1961 #endif
1962                     Perl_sv_catpvf(aTHX_ opts_prog,
1963                                    "\"  Built under %s\\n\"",OSNAME);
1964 #ifdef __DATE__
1965 #  ifdef __TIME__
1966                     Perl_sv_catpvf(aTHX_ opts_prog,
1967                                    ",\"  Compiled at %s %s\\n\"",__DATE__,
1968                                    __TIME__);
1969 #  else
1970                     Perl_sv_catpvf(aTHX_ opts_prog,",\"  Compiled on %s\\n\"",
1971                                    __DATE__);
1972 #  endif
1973 #endif
1974                     sv_catpvs(opts_prog, "; $\"=\"\\n    \"; "
1975                              "@env = map { \"$_=\\\"$ENV{$_}\\\"\" } "
1976                              "sort grep {/^PERL/} keys %ENV; ");
1977 #ifdef __CYGWIN__
1978                     sv_catpvs(opts_prog,
1979                              "push @env, \"CYGWIN=\\\"$ENV{CYGWIN}\\\"\";");
1980 #endif
1981                     sv_catpvs(opts_prog,
1982                              "print \"  \\%ENV:\\n    @env\\n\" if @env;"
1983                              "print \"  \\@INC:\\n    @INC\\n\";");
1984                 }
1985                 else {
1986                     ++s;
1987                     opts_prog = Perl_newSVpvf(aTHX_
1988                                               "Config::config_vars(qw%c%s%c)",
1989                                               0, s, 0);
1990                     s += strlen(s);
1991                 }
1992                 av_push(PL_preambleav, opts_prog);
1993                 /* don't look for script or read stdin */
1994                 scriptname = BIT_BUCKET;
1995                 goto reswitch;
1996             }
1997         case 'x':
1998             PL_doextract = TRUE;
1999             s++;
2000             if (*s) {
2001                 cddir = s;
2002             }
2003             else if ((s=argv[1]) && *s != '-') {
2004                 argc--,argv++;
2005                 cddir = s;
2006             }
2007             break;
2008         case 0:
2009             break;
2010         case '-':
2011             if (!*++s || isSPACE(*s)) {
2012                 argc--,argv++;
2013                 goto switch_end;
2014             }
2015             /* catch use of gnu style long options */
2016             if (strEQ(s, "version")) {
2017                 s = (char *)"v";
2018                 goto reswitch;
2019             }
2020             if (strEQ(s, "help")) {
2021                 s = (char *)"h";
2022                 goto reswitch;
2023             }
2024             s--;
2025             /* FALL THROUGH */
2026         default:
2027             Perl_croak(aTHX_ "Unrecognized switch: -%s  (-h will show valid options)",s);
2028         }
2029     }
2030   switch_end:
2031
2032     if (
2033 #ifndef SECURE_INTERNAL_GETENV
2034         !PL_tainting &&
2035 #endif
2036         (s = PerlEnv_getenv("PERL5OPT")))
2037     {
2038         const char *popt = s;
2039         while (isSPACE(*s))
2040             s++;
2041         if (*s == '-' && *(s+1) == 'T') {
2042             CHECK_MALLOC_TOO_LATE_FOR('T');
2043             PL_tainting = TRUE;
2044             PL_taint_warn = FALSE;
2045         }
2046         else {
2047             char *popt_copy = NULL;
2048             while (s && *s) {
2049                 char *d;
2050                 while (isSPACE(*s))
2051                     s++;
2052                 if (*s == '-') {
2053                     s++;
2054                     if (isSPACE(*s))
2055                         continue;
2056                 }
2057                 d = s;
2058                 if (!*s)
2059                     break;
2060                 if (!strchr("CDIMUdmtwA", *s))
2061                     Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s);
2062                 while (++s && *s) {
2063                     if (isSPACE(*s)) {
2064                         if (!popt_copy) {
2065                             popt_copy = SvPVX(sv_2mortal(newSVpv(popt,0)));
2066                             s = popt_copy + (s - popt);
2067                             d = popt_copy + (d - popt);
2068                         }
2069                         *s++ = '\0';
2070                         break;
2071                     }
2072                 }
2073                 if (*d == 't') {
2074                     if( !PL_tainting ) {
2075                         PL_taint_warn = TRUE;
2076                         PL_tainting = TRUE;
2077                     }
2078                 } else {
2079                     moreswitches(d);
2080                 }
2081             }
2082         }
2083     }
2084
2085 #ifdef USE_SITECUSTOMIZE
2086     if (!minus_f) {
2087         (void)Perl_av_create_and_unshift_one(aTHX_ &PL_preambleav,
2088                                              Perl_newSVpvf(aTHX_ "BEGIN { do '%s/sitecustomize.pl' }", SITELIB_EXP));
2089     }
2090 #endif
2091
2092     if (!scriptname)
2093         scriptname = argv[0];
2094     if (PL_e_script) {
2095         argc++,argv--;
2096         scriptname = BIT_BUCKET;        /* don't look for script or read stdin */
2097     }
2098     else if (scriptname == NULL) {
2099 #ifdef MSDOS
2100         if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) )
2101             moreswitches("h");
2102 #endif
2103         scriptname = "-";
2104     }
2105
2106     /* Set $^X early so that it can be used for relocatable paths in @INC  */
2107     assert (!PL_tainted);
2108     TAINT;
2109     S_set_caret_X(aTHX);
2110     TAINT_NOT;
2111     init_perllib();
2112
2113     {
2114         int suidscript;
2115         const int fdscript
2116             = open_script(scriptname, dosearch, sv, &suidscript, &rsfp);
2117
2118         validate_suid(validarg, scriptname, fdscript, suidscript,
2119                 linestr_sv, rsfp);
2120
2121 #ifndef PERL_MICRO
2122 #  if defined(SIGCHLD) || defined(SIGCLD)
2123         {
2124 #  ifndef SIGCHLD
2125 #    define SIGCHLD SIGCLD
2126 #  endif
2127             Sighandler_t sigstate = rsignal_state(SIGCHLD);
2128             if (sigstate == (Sighandler_t) SIG_IGN) {
2129                 if (ckWARN(WARN_SIGNAL))
2130                     Perl_warner(aTHX_ packWARN(WARN_SIGNAL),
2131                                 "Can't ignore signal CHLD, forcing to default");
2132                 (void)rsignal(SIGCHLD, (Sighandler_t)SIG_DFL);
2133             }
2134         }
2135 #  endif
2136 #endif
2137
2138         if (PL_doextract
2139 #ifdef MACOS_TRADITIONAL
2140             || gMacPerl_AlwaysExtract
2141 #endif
2142             ) {
2143
2144             /* This will croak if suidscript is >= 0, as -x cannot be used with
2145                setuid scripts.  */
2146             forbid_setid('x', suidscript);
2147             /* Hence you can't get here if suidscript >= 0  */
2148
2149             find_beginning(linestr_sv, rsfp);
2150             if (cddir && PerlDir_chdir( (char *)cddir ) < 0)
2151                 Perl_croak(aTHX_ "Can't chdir to %s",cddir);
2152         }
2153     }
2154
2155     PL_main_cv = PL_compcv = (CV*)newSV_type(SVt_PVCV);
2156     CvUNIQUE_on(PL_compcv);
2157
2158     CvPADLIST(PL_compcv) = pad_new(0);
2159
2160     PL_isarev = newHV();
2161
2162     boot_core_PerlIO();
2163     boot_core_UNIVERSAL();
2164     boot_core_xsutils();
2165     boot_core_mro();
2166
2167     if (xsinit)
2168         (*xsinit)(aTHX);        /* in case linked C routines want magical variables */
2169 #ifndef PERL_MICRO
2170 #if defined(VMS) || defined(WIN32) || defined(DJGPP) || defined(__CYGWIN__) || defined(EPOC) || defined(SYMBIAN)
2171     init_os_extras();
2172 #endif
2173 #endif
2174
2175 #ifdef USE_SOCKS
2176 #   ifdef HAS_SOCKS5_INIT
2177     socks5_init(argv[0]);
2178 #   else
2179     SOCKSinit(argv[0]);
2180 #   endif
2181 #endif
2182
2183     init_predump_symbols();
2184     /* init_postdump_symbols not currently designed to be called */
2185     /* more than once (ENV isn't cleared first, for example)     */
2186     /* But running with -u leaves %ENV & @ARGV undefined!    XXX */
2187     if (!PL_do_undump)
2188         init_postdump_symbols(argc,argv,env);
2189
2190     /* PL_unicode is turned on by -C, or by $ENV{PERL_UNICODE},
2191      * or explicitly in some platforms.
2192      * locale.c:Perl_init_i18nl10n() if the environment
2193      * look like the user wants to use UTF-8. */
2194 #if defined(__SYMBIAN32__)
2195     PL_unicode = PERL_UNICODE_STD_FLAG; /* See PERL_SYMBIAN_CONSOLE_UTF8. */
2196 #endif
2197     if (PL_unicode) {
2198          /* Requires init_predump_symbols(). */
2199          if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) {
2200               IO* io;
2201               PerlIO* fp;
2202               SV* sv;
2203
2204               /* Turn on UTF-8-ness on STDIN, STDOUT, STDERR
2205                * and the default open disciplines. */
2206               if ((PL_unicode & PERL_UNICODE_STDIN_FLAG) &&
2207                   PL_stdingv  && (io = GvIO(PL_stdingv)) &&
2208                   (fp = IoIFP(io)))
2209                    PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
2210               if ((PL_unicode & PERL_UNICODE_STDOUT_FLAG) &&
2211                   PL_defoutgv && (io = GvIO(PL_defoutgv)) &&
2212                   (fp = IoOFP(io)))
2213                    PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
2214               if ((PL_unicode & PERL_UNICODE_STDERR_FLAG) &&
2215                   PL_stderrgv && (io = GvIO(PL_stderrgv)) &&
2216                   (fp = IoOFP(io)))
2217                    PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
2218               if ((PL_unicode & PERL_UNICODE_INOUT_FLAG) &&
2219                   (sv = GvSV(gv_fetchpvs("\017PEN", GV_ADD|GV_NOTQUAL,
2220                                          SVt_PV)))) {
2221                    U32 in  = PL_unicode & PERL_UNICODE_IN_FLAG;
2222                    U32 out = PL_unicode & PERL_UNICODE_OUT_FLAG;
2223                    if (in) {
2224                         if (out)
2225                              sv_setpvn(sv, ":utf8\0:utf8", 11);
2226                         else
2227                              sv_setpvn(sv, ":utf8\0", 6);
2228                    }
2229                    else if (out)
2230                         sv_setpvn(sv, "\0:utf8", 6);
2231                    SvSETMAGIC(sv);
2232               }
2233          }
2234     }
2235
2236     if ((s = PerlEnv_getenv("PERL_SIGNALS"))) {
2237          if (strEQ(s, "unsafe"))
2238               PL_signals |=  PERL_SIGNALS_UNSAFE_FLAG;
2239          else if (strEQ(s, "safe"))
2240               PL_signals &= ~PERL_SIGNALS_UNSAFE_FLAG;
2241          else
2242               Perl_croak(aTHX_ "PERL_SIGNALS illegal: \"%s\"", s);
2243     }
2244
2245 #ifdef PERL_MAD
2246     if ((s = PerlEnv_getenv("PERL_XMLDUMP"))) {
2247         PL_madskills = 1;
2248         PL_minus_c = 1;
2249         if (!s || !s[0])
2250             PL_xmlfp = PerlIO_stdout();
2251         else {
2252             PL_xmlfp = PerlIO_open(s, "w");
2253             if (!PL_xmlfp)
2254                 Perl_croak(aTHX_ "Can't open %s", s);
2255         }
2256         my_setenv("PERL_XMLDUMP", Nullch);      /* hide from subprocs */
2257     }
2258     if ((s = PerlEnv_getenv("PERL_MADSKILLS"))) {
2259         PL_madskills = atoi(s);
2260         my_setenv("PERL_MADSKILLS", Nullch);    /* hide from subprocs */
2261     }
2262 #endif
2263
2264     lex_start(linestr_sv, rsfp, TRUE);
2265     PL_subname = newSVpvs("main");
2266
2267     if (add_read_e_script)
2268         filter_add(read_e_script, NULL);
2269
2270     /* now parse the script */
2271
2272     SETERRNO(0,SS_NORMAL);
2273 #ifdef MACOS_TRADITIONAL
2274     if (gMacPerl_SyntaxError = (yyparse() || PL_parser->error_count)) {
2275         if (PL_minus_c)
2276             Perl_croak(aTHX_ "%s had compilation errors.\n", MacPerl_MPWFileName(PL_origfilename));
2277         else {
2278             Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
2279                        MacPerl_MPWFileName(PL_origfilename));
2280         }
2281     }
2282 #else
2283     if (yyparse() || PL_parser->error_count) {
2284         if (PL_minus_c)
2285             Perl_croak(aTHX_ "%s had compilation errors.\n", PL_origfilename);
2286         else {
2287             Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
2288                        PL_origfilename);
2289         }
2290     }
2291 #endif
2292     CopLINE_set(PL_curcop, 0);
2293     PL_curstash = PL_defstash;
2294     PL_preprocess = FALSE;
2295     if (PL_e_script) {
2296         SvREFCNT_dec(PL_e_script);
2297         PL_e_script = NULL;
2298     }
2299
2300     if (PL_do_undump)
2301         my_unexec();
2302
2303     if (isWARN_ONCE) {
2304         SAVECOPFILE(PL_curcop);
2305         SAVECOPLINE(PL_curcop);
2306         gv_check(PL_defstash);
2307     }
2308
2309     LEAVE;
2310     FREETMPS;
2311
2312 #ifdef MYMALLOC
2313     if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
2314         dump_mstats("after compilation:");
2315 #endif
2316
2317     ENTER;
2318     PL_restartop = 0;
2319     return NULL;
2320 }
2321
2322 /*
2323 =for apidoc perl_run
2324
2325 Tells a Perl interpreter to run.  See L<perlembed>.
2326
2327 =cut
2328 */
2329
2330 int
2331 perl_run(pTHXx)
2332 {
2333     dVAR;
2334     I32 oldscope;
2335     int ret = 0;
2336     dJMPENV;
2337
2338     PERL_UNUSED_ARG(my_perl);
2339
2340     oldscope = PL_scopestack_ix;
2341 #ifdef VMS
2342     VMSISH_HUSHED = 0;
2343 #endif
2344
2345     JMPENV_PUSH(ret);
2346     switch (ret) {
2347     case 1:
2348         cxstack_ix = -1;                /* start context stack again */
2349         goto redo_body;
2350     case 0:                             /* normal completion */
2351  redo_body:
2352         run_body(oldscope);
2353         /* FALL THROUGH */
2354     case 2:                             /* my_exit() */
2355         while (PL_scopestack_ix > oldscope)
2356             LEAVE;
2357         FREETMPS;
2358         PL_curstash = PL_defstash;
2359         if (!(PL_exit_flags & PERL_EXIT_DESTRUCT_END) &&
2360             PL_endav && !PL_minus_c)
2361             call_list(oldscope, PL_endav);
2362 #ifdef MYMALLOC
2363         if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
2364             dump_mstats("after execution:  ");
2365 #endif
2366         ret = STATUS_EXIT;
2367         break;
2368     case 3:
2369         if (PL_restartop) {
2370             POPSTACK_TO(PL_mainstack);
2371             goto redo_body;
2372         }
2373         PerlIO_printf(Perl_error_log, "panic: restartop\n");
2374         FREETMPS;
2375         ret = 1;
2376         break;
2377     }
2378
2379     JMPENV_POP;
2380     return ret;
2381 }
2382
2383 STATIC void
2384 S_run_body(pTHX_ I32 oldscope)
2385 {
2386     dVAR;
2387     DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
2388                     PL_sawampersand ? "Enabling" : "Omitting"));
2389
2390     if (!PL_restartop) {
2391 #ifdef PERL_MAD
2392         if (PL_xmlfp) {
2393             xmldump_all();
2394             exit(0);    /* less likely to core dump than my_exit(0) */
2395         }
2396 #endif
2397         DEBUG_x(dump_all());
2398 #ifdef DEBUGGING
2399         if (!DEBUG_q_TEST)
2400           PERL_DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
2401 #endif
2402         DEBUG_S(PerlIO_printf(Perl_debug_log, "main thread is 0x%"UVxf"\n",
2403                               PTR2UV(thr)));
2404
2405         if (PL_minus_c) {
2406 #ifdef MACOS_TRADITIONAL
2407             PerlIO_printf(Perl_error_log, "%s%s syntax OK\n",
2408                 (gMacPerl_ErrorFormat ? "# " : ""),
2409                 MacPerl_MPWFileName(PL_origfilename));
2410 #else
2411             PerlIO_printf(Perl_error_log, "%s syntax OK\n", PL_origfilename);
2412 #endif
2413             my_exit(0);
2414         }
2415         if (PERLDB_SINGLE && PL_DBsingle)
2416             sv_setiv(PL_DBsingle, 1);
2417         if (PL_initav)
2418             call_list(oldscope, PL_initav);
2419 #ifdef PERL_DEBUG_READONLY_OPS
2420         Perl_pending_Slabs_to_ro(aTHX);
2421 #endif
2422     }
2423
2424     /* do it */
2425
2426     if (PL_restartop) {
2427         PL_op = PL_restartop;
2428         PL_restartop = 0;
2429         CALLRUNOPS(aTHX);
2430     }
2431     else if (PL_main_start) {
2432         CvDEPTH(PL_main_cv) = 1;
2433         PL_op = PL_main_start;
2434         CALLRUNOPS(aTHX);
2435     }
2436     my_exit(0);
2437     /* NOTREACHED */
2438 }
2439
2440 /*
2441 =head1 SV Manipulation Functions
2442
2443 =for apidoc p||get_sv
2444
2445 Returns the SV of the specified Perl scalar.  If C<create> is set and the
2446 Perl variable does not exist then it will be created.  If C<create> is not
2447 set and the variable does not exist then NULL is returned.
2448
2449 =cut
2450 */
2451
2452 SV*
2453 Perl_get_sv(pTHX_ const char *name, I32 create)
2454 {
2455     GV *gv;
2456     gv = gv_fetchpv(name, create, SVt_PV);
2457     if (gv)
2458         return GvSV(gv);
2459     return NULL;
2460 }
2461
2462 /*
2463 =head1 Array Manipulation Functions
2464
2465 =for apidoc p||get_av
2466
2467 Returns the AV of the specified Perl array.  If C<create> is set and the
2468 Perl variable does not exist then it will be created.  If C<create> is not
2469 set and the variable does not exist then NULL is returned.
2470
2471 =cut
2472 */
2473
2474 AV*
2475 Perl_get_av(pTHX_ const char *name, I32 create)
2476 {
2477     GV* const gv = gv_fetchpv(name, create, SVt_PVAV);
2478     if (create)
2479         return GvAVn(gv);
2480     if (gv)
2481         return GvAV(gv);
2482     return NULL;
2483 }
2484
2485 /*
2486 =head1 Hash Manipulation Functions
2487
2488 =for apidoc p||get_hv
2489
2490 Returns the HV of the specified Perl hash.  If C<create> is set and the
2491 Perl variable does not exist then it will be created.  If C<create> is not
2492 set and the variable does not exist then NULL is returned.
2493
2494 =cut
2495 */
2496
2497 HV*
2498 Perl_get_hv(pTHX_ const char *name, I32 create)
2499 {
2500     GV* const gv = gv_fetchpv(name, create, SVt_PVHV);
2501     if (create)
2502         return GvHVn(gv);
2503     if (gv)
2504         return GvHV(gv);
2505     return NULL;
2506 }
2507
2508 /*
2509 =head1 CV Manipulation Functions
2510
2511 =for apidoc p||get_cvn_flags
2512
2513 Returns the CV of the specified Perl subroutine.  C<flags> are passed to
2514 C<gv_fetchpvn_flags>. If C<GV_ADD> is set and the Perl subroutine does not
2515 exist then it will be declared (which has the same effect as saying
2516 C<sub name;>).  If C<GV_ADD> is not set and the subroutine does not exist
2517 then NULL is returned.
2518
2519 =for apidoc p||get_cv
2520
2521 Uses C<strlen> to get the length of C<name>, then calls C<get_cvn_flags>.
2522
2523 =cut
2524 */
2525
2526 CV*
2527 Perl_get_cvn_flags(pTHX_ const char *name, STRLEN len, I32 flags)
2528 {
2529     GV* const gv = gv_fetchpvn_flags(name, len, flags, SVt_PVCV);
2530     /* XXX this is probably not what they think they're getting.
2531      * It has the same effect as "sub name;", i.e. just a forward
2532      * declaration! */
2533     if ((flags & ~GV_NOADD_MASK) && !GvCVu(gv)) {
2534         SV *const sv = newSVpvn(name,len);
2535         SvFLAGS(sv) |= flags & SVf_UTF8;
2536         return newSUB(start_subparse(FALSE, 0),
2537                       newSVOP(OP_CONST, 0, sv),
2538                       NULL, NULL);
2539     }
2540     if (gv)
2541         return GvCVu(gv);
2542     return NULL;
2543 }
2544
2545 CV*
2546 Perl_get_cv(pTHX_ const char *name, I32 flags)
2547 {
2548     return get_cvn_flags(name, strlen(name), flags);
2549 }
2550
2551 /* Be sure to refetch the stack pointer after calling these routines. */
2552
2553 /*
2554
2555 =head1 Callback Functions
2556
2557 =for apidoc p||call_argv
2558
2559 Performs a callback to the specified Perl sub.  See L<perlcall>.
2560
2561 =cut
2562 */
2563
2564 I32
2565 Perl_call_argv(pTHX_ const char *sub_name, I32 flags, register char **argv)
2566
2567                         /* See G_* flags in cop.h */
2568                         /* null terminated arg list */
2569 {
2570     dVAR;
2571     dSP;
2572
2573     PUSHMARK(SP);
2574     if (argv) {
2575         while (*argv) {
2576             XPUSHs(sv_2mortal(newSVpv(*argv,0)));
2577             argv++;
2578         }
2579         PUTBACK;
2580     }
2581     return call_pv(sub_name, flags);
2582 }
2583
2584 /*
2585 =for apidoc p||call_pv
2586
2587 Performs a callback to the specified Perl sub.  See L<perlcall>.
2588
2589 =cut
2590 */
2591
2592 I32
2593 Perl_call_pv(pTHX_ const char *sub_name, I32 flags)
2594                         /* name of the subroutine */
2595                         /* See G_* flags in cop.h */
2596 {
2597     return call_sv((SV*)get_cv(sub_name, TRUE), flags);
2598 }
2599
2600 /*
2601 =for apidoc p||call_method
2602
2603 Performs a callback to the specified Perl method.  The blessed object must
2604 be on the stack.  See L<perlcall>.
2605
2606 =cut
2607 */
2608
2609 I32
2610 Perl_call_method(pTHX_ const char *methname, I32 flags)
2611                         /* name of the subroutine */
2612                         /* See G_* flags in cop.h */
2613 {
2614     return call_sv(sv_2mortal(newSVpv(methname,0)), flags | G_METHOD);
2615 }
2616
2617 /* May be called with any of a CV, a GV, or an SV containing the name. */
2618 /*
2619 =for apidoc p||call_sv
2620
2621 Performs a callback to the Perl sub whose name is in the SV.  See
2622 L<perlcall>.
2623
2624 =cut
2625 */
2626
2627 I32
2628 Perl_call_sv(pTHX_ SV *sv, I32 flags)
2629                         /* See G_* flags in cop.h */
2630 {
2631     dVAR; dSP;
2632     LOGOP myop;         /* fake syntax tree node */
2633     UNOP method_op;
2634     I32 oldmark;
2635     VOL I32 retval = 0;
2636     I32 oldscope;
2637     bool oldcatch = CATCH_GET;
2638     int ret;
2639     OP* const oldop = PL_op;
2640     dJMPENV;
2641
2642     if (flags & G_DISCARD) {
2643         ENTER;
2644         SAVETMPS;
2645     }
2646
2647     Zero(&myop, 1, LOGOP);
2648     myop.op_next = NULL;
2649     if (!(flags & G_NOARGS))
2650         myop.op_flags |= OPf_STACKED;
2651     myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
2652                       (flags & G_ARRAY) ? OPf_WANT_LIST :
2653                       OPf_WANT_SCALAR);
2654     SAVEOP();
2655     PL_op = (OP*)&myop;
2656
2657     EXTEND(PL_stack_sp, 1);
2658     *++PL_stack_sp = sv;
2659     oldmark = TOPMARK;
2660     oldscope = PL_scopestack_ix;
2661
2662     if (PERLDB_SUB && PL_curstash != PL_debstash
2663            /* Handle first BEGIN of -d. */
2664           && (PL_DBcv || (PL_DBcv = GvCV(PL_DBsub)))
2665            /* Try harder, since this may have been a sighandler, thus
2666             * curstash may be meaningless. */
2667           && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != PL_debstash)
2668           && !(flags & G_NODEBUG))
2669         PL_op->op_private |= OPpENTERSUB_DB;
2670
2671     if (flags & G_METHOD) {
2672         Zero(&method_op, 1, UNOP);
2673         method_op.op_next = PL_op;
2674         method_op.op_ppaddr = PL_ppaddr[OP_METHOD];
2675         myop.op_ppaddr = PL_ppaddr[OP_ENTERSUB];
2676         PL_op = (OP*)&method_op;
2677     }
2678
2679     if (!(flags & G_EVAL)) {
2680         CATCH_SET(TRUE);
2681         CALL_BODY_SUB((OP*)&myop);
2682         retval = PL_stack_sp - (PL_stack_base + oldmark);
2683         CATCH_SET(oldcatch);
2684     }
2685     else {
2686         myop.op_other = (OP*)&myop;
2687         PL_markstack_ptr--;
2688         create_eval_scope(flags|G_FAKINGEVAL);
2689         PL_markstack_ptr++;
2690
2691         JMPENV_PUSH(ret);
2692
2693         switch (ret) {
2694         case 0:
2695  redo_body:
2696             CALL_BODY_SUB((OP*)&myop);
2697             retval = PL_stack_sp - (PL_stack_base + oldmark);
2698             if (!(flags & G_KEEPERR))
2699                 sv_setpvn(ERRSV,"",0);
2700             break;
2701         case 1:
2702             STATUS_ALL_FAILURE;
2703             /* FALL THROUGH */
2704         case 2:
2705             /* my_exit() was called */
2706             PL_curstash = PL_defstash;
2707             FREETMPS;
2708             JMPENV_POP;
2709             if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
2710                 Perl_croak(aTHX_ "Callback called exit");
2711             my_exit_jump();
2712             /* NOTREACHED */
2713         case 3:
2714             if (PL_restartop) {
2715                 PL_op = PL_restartop;
2716                 PL_restartop = 0;
2717                 goto redo_body;
2718             }
2719             PL_stack_sp = PL_stack_base + oldmark;
2720             if (flags & G_ARRAY)
2721                 retval = 0;
2722             else {
2723                 retval = 1;
2724                 *++PL_stack_sp = &PL_sv_undef;
2725             }
2726             break;
2727         }
2728
2729         if (PL_scopestack_ix > oldscope)
2730             delete_eval_scope();
2731         JMPENV_POP;
2732     }
2733
2734     if (flags & G_DISCARD) {
2735         PL_stack_sp = PL_stack_base + oldmark;
2736         retval = 0;
2737         FREETMPS;
2738         LEAVE;
2739     }
2740     PL_op = oldop;
2741     return retval;
2742 }
2743
2744 /* Eval a string. The G_EVAL flag is always assumed. */
2745
2746 /*
2747 =for apidoc p||eval_sv
2748
2749 Tells Perl to C<eval> the string in the SV.
2750
2751 =cut
2752 */
2753
2754 I32
2755 Perl_eval_sv(pTHX_ SV *sv, I32 flags)
2756
2757                         /* See G_* flags in cop.h */
2758 {
2759     dVAR;
2760     dSP;
2761     UNOP myop;          /* fake syntax tree node */
2762     VOL I32 oldmark = SP - PL_stack_base;
2763     VOL I32 retval = 0;
2764     int ret;
2765     OP* const oldop = PL_op;
2766     dJMPENV;
2767
2768     if (flags & G_DISCARD) {
2769         ENTER;
2770         SAVETMPS;
2771     }
2772
2773     SAVEOP();
2774     PL_op = (OP*)&myop;
2775     Zero(PL_op, 1, UNOP);
2776     EXTEND(PL_stack_sp, 1);
2777     *++PL_stack_sp = sv;
2778
2779     if (!(flags & G_NOARGS))
2780         myop.op_flags = OPf_STACKED;
2781     myop.op_next = NULL;
2782     myop.op_type = OP_ENTEREVAL;
2783     myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
2784                       (flags & G_ARRAY) ? OPf_WANT_LIST :
2785                       OPf_WANT_SCALAR);
2786     if (flags & G_KEEPERR)
2787         myop.op_flags |= OPf_SPECIAL;
2788
2789     /* fail now; otherwise we could fail after the JMPENV_PUSH but
2790      * before a PUSHEVAL, which corrupts the stack after a croak */
2791     TAINT_PROPER("eval_sv()");
2792
2793     JMPENV_PUSH(ret);
2794     switch (ret) {
2795     case 0:
2796  redo_body:
2797         CALL_BODY_EVAL((OP*)&myop);
2798         retval = PL_stack_sp - (PL_stack_base + oldmark);
2799         if (!(flags & G_KEEPERR))
2800             sv_setpvn(ERRSV,"",0);
2801         break;
2802     case 1:
2803         STATUS_ALL_FAILURE;
2804         /* FALL THROUGH */
2805     case 2:
2806         /* my_exit() was called */
2807         PL_curstash = PL_defstash;
2808         FREETMPS;
2809         JMPENV_POP;
2810         if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
2811             Perl_croak(aTHX_ "Callback called exit");
2812         my_exit_jump();
2813         /* NOTREACHED */
2814     case 3:
2815         if (PL_restartop) {
2816             PL_op = PL_restartop;
2817             PL_restartop = 0;
2818             goto redo_body;
2819         }
2820         PL_stack_sp = PL_stack_base + oldmark;
2821         if (flags & G_ARRAY)
2822             retval = 0;
2823         else {
2824             retval = 1;
2825             *++PL_stack_sp = &PL_sv_undef;
2826         }
2827         break;
2828     }
2829
2830     JMPENV_POP;
2831     if (flags & G_DISCARD) {
2832         PL_stack_sp = PL_stack_base + oldmark;
2833         retval = 0;
2834         FREETMPS;
2835         LEAVE;
2836     }
2837     PL_op = oldop;
2838     return retval;
2839 }
2840
2841 /*
2842 =for apidoc p||eval_pv
2843
2844 Tells Perl to C<eval> the given string and return an SV* result.
2845
2846 =cut
2847 */
2848
2849 SV*
2850 Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error)
2851 {
2852     dVAR;
2853     dSP;
2854     SV* sv = newSVpv(p, 0);
2855
2856     eval_sv(sv, G_SCALAR);
2857     SvREFCNT_dec(sv);
2858
2859     SPAGAIN;
2860     sv = POPs;
2861     PUTBACK;
2862
2863     if (croak_on_error && SvTRUE(ERRSV)) {
2864         Perl_croak(aTHX_ SvPVx_nolen_const(ERRSV));
2865     }
2866
2867     return sv;
2868 }
2869
2870 /* Require a module. */
2871
2872 /*
2873 =head1 Embedding Functions
2874
2875 =for apidoc p||require_pv
2876
2877 Tells Perl to C<require> the file named by the string argument.  It is
2878 analogous to the Perl code C<eval "require '$file'">.  It's even
2879 implemented that way; consider using load_module instead.
2880
2881 =cut */
2882
2883 void
2884 Perl_require_pv(pTHX_ const char *pv)
2885 {
2886     dVAR;
2887     dSP;
2888     SV* sv;
2889     PUSHSTACKi(PERLSI_REQUIRE);
2890     PUTBACK;
2891     sv = Perl_newSVpvf(aTHX_ "require q%c%s%c", 0, pv, 0);
2892     eval_sv(sv_2mortal(sv), G_DISCARD);
2893     SPAGAIN;
2894     POPSTACK;
2895 }
2896
2897 void
2898 Perl_magicname(pTHX_ const char *sym, const char *name, I32 namlen)
2899 {
2900     register GV * const gv = gv_fetchpv(sym, GV_ADD, SVt_PV);
2901
2902     if (gv)
2903         sv_magic(GvSV(gv), (SV*)gv, PERL_MAGIC_sv, name, namlen);
2904 }
2905
2906 STATIC void
2907 S_usage(pTHX_ const char *name)         /* XXX move this out into a module ? */
2908 {
2909     /* This message really ought to be max 23 lines.
2910      * Removed -h because the user already knows that option. Others? */
2911
2912     static const char * const usage_msg[] = {
2913 "-0[octal]         specify record separator (\\0, if no argument)",
2914 "-a                autosplit mode with -n or -p (splits $_ into @F)",
2915 "-C[number/list]   enables the listed Unicode features",
2916 "-c                check syntax only (runs BEGIN and CHECK blocks)",
2917 "-d[:debugger]     run program under debugger",
2918 "-D[number/list]   set debugging flags (argument is a bit mask or alphabets)",
2919 "-e program        one line of program (several -e's allowed, omit programfile)",
2920 "-E program        like -e, but enables all optional features",
2921 "-f                don't do $sitelib/sitecustomize.pl at startup",
2922 "-F/pattern/       split() pattern for -a switch (//'s are optional)",
2923 "-i[extension]     edit <> files in place (makes backup if extension supplied)",
2924 "-Idirectory       specify @INC/#include directory (several -I's allowed)",
2925 "-l[octal]         enable line ending processing, specifies line terminator",
2926 "-[mM][-]module    execute \"use/no module...\" before executing program",
2927 "-n                assume \"while (<>) { ... }\" loop around program",
2928 "-p                assume loop like -n but print line also, like sed",
2929 "-P                run program through C preprocessor before compilation",
2930 "-s                enable rudimentary parsing for switches after programfile",
2931 "-S                look for programfile using PATH environment variable",
2932 "-t                enable tainting warnings",
2933 "-T                enable tainting checks",
2934 "-u                dump core after parsing program",
2935 "-U                allow unsafe operations",
2936 "-v                print version, subversion (includes VERY IMPORTANT perl info)",
2937 "-V[:variable]     print configuration summary (or a single Config.pm variable)",
2938 "-w                enable many useful warnings (RECOMMENDED)",
2939 "-W                enable all warnings",
2940 "-x[directory]     strip off text before #!perl line and perhaps cd to directory",
2941 "-X                disable all warnings",
2942 "\n",
2943 NULL
2944 };
2945     const char * const *p = usage_msg;
2946
2947     PerlIO_printf(PerlIO_stdout(),
2948                   "\nUsage: %s [switches] [--] [programfile] [arguments]",
2949                   name);
2950     while (*p)
2951         PerlIO_printf(PerlIO_stdout(), "\n  %s", *p++);
2952 }
2953
2954 /* convert a string of -D options (or digits) into an int.
2955  * sets *s to point to the char after the options */
2956
2957 #ifdef DEBUGGING
2958 int
2959 Perl_get_debug_opts(pTHX_ const char **s, bool givehelp)
2960 {
2961     static const char * const usage_msgd[] = {
2962       " Debugging flag values: (see also -d)",
2963       "  p  Tokenizing and parsing (with v, displays parse stack)",
2964       "  s  Stack snapshots (with v, displays all stacks)",
2965       "  l  Context (loop) stack processing",
2966       "  t  Trace execution",
2967       "  o  Method and overloading resolution",
2968       "  c  String/numeric conversions",
2969       "  P  Print profiling info, preprocessor command for -P, source file input state",
2970       "  m  Memory allocation",
2971       "  f  Format processing",
2972       "  r  Regular expression parsing and execution",
2973       "  x  Syntax tree dump",
2974       "  u  Tainting checks",
2975       "  H  Hash dump -- usurps values()",
2976       "  X  Scratchpad allocation",
2977       "  D  Cleaning up",
2978       "  S  Thread synchronization",
2979       "  T  Tokenising",
2980       "  R  Include reference counts of dumped variables (eg when using -Ds)",
2981       "  J  Do not s,t,P-debug (Jump over) opcodes within package DB",
2982       "  v  Verbose: use in conjunction with other flags",
2983       "  C  Copy On Write",
2984       "  A  Consistency checks on internal structures",
2985       "  q  quiet - currently only suppresses the 'EXECUTING' message",
2986       NULL
2987     };
2988     int i = 0;
2989     if (isALPHA(**s)) {
2990         /* if adding extra options, remember to update DEBUG_MASK */
2991         static const char debopts[] = "psltocPmfrxuUHXDSTRJvCAq";
2992
2993         for (; isALNUM(**s); (*s)++) {
2994             const char * const d = strchr(debopts,**s);
2995             if (d)
2996                 i |= 1 << (d - debopts);
2997             else if (ckWARN_d(WARN_DEBUGGING))
2998                 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
2999                     "invalid option -D%c, use -D'' to see choices\n", **s);
3000         }
3001     }
3002     else if (isDIGIT(**s)) {
3003         i = atoi(*s);
3004         for (; isALNUM(**s); (*s)++) ;
3005     }
3006     else if (givehelp) {
3007       const char *const *p = usage_msgd;
3008       while (*p) PerlIO_printf(PerlIO_stdout(), "%s\n", *p++);
3009     }
3010 #  ifdef EBCDIC
3011     if ((i & DEBUG_p_FLAG) && ckWARN_d(WARN_DEBUGGING))
3012         Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
3013                 "-Dp not implemented on this platform\n");
3014 #  endif
3015     return i;
3016 }
3017 #endif
3018
3019 /* This routine handles any switches that can be given during run */
3020
3021 char *
3022 Perl_moreswitches(pTHX_ char *s)
3023 {
3024     dVAR;
3025     UV rschar;
3026
3027     switch (*s) {
3028     case '0':
3029     {
3030          I32 flags = 0;
3031          STRLEN numlen;
3032
3033          SvREFCNT_dec(PL_rs);
3034          if (s[1] == 'x' && s[2]) {
3035               const char *e = s+=2;
3036               U8 *tmps;
3037
3038               while (*e)
3039                 e++;
3040               numlen = e - s;
3041               flags = PERL_SCAN_SILENT_ILLDIGIT;
3042               rschar = (U32)grok_hex(s, &numlen, &flags, NULL);
3043               if (s + numlen < e) {
3044                    rschar = 0; /* Grandfather -0xFOO as -0 -xFOO. */
3045                    numlen = 0;
3046                    s--;
3047               }
3048               PL_rs = newSVpvs("");
3049               SvGROW(PL_rs, (STRLEN)(UNISKIP(rschar) + 1));
3050               tmps = (U8*)SvPVX(PL_rs);
3051               uvchr_to_utf8(tmps, rschar);
3052               SvCUR_set(PL_rs, UNISKIP(rschar));
3053               SvUTF8_on(PL_rs);
3054          }
3055          else {
3056               numlen = 4;
3057               rschar = (U32)grok_oct(s, &numlen, &flags, NULL);
3058               if (rschar & ~((U8)~0))
3059                    PL_rs = &PL_sv_undef;
3060               else if (!rschar && numlen >= 2)
3061                    PL_rs = newSVpvs("");
3062               else {
3063                    char ch = (char)rschar;
3064                    PL_rs = newSVpvn(&ch, 1);
3065               }
3066          }
3067          sv_setsv(get_sv("/", TRUE), PL_rs);
3068          return s + numlen;
3069     }
3070     case 'C':
3071         s++;
3072         PL_unicode = parse_unicode_opts( (const char **)&s );
3073         if (PL_unicode & PERL_UNICODE_UTF8CACHEASSERT_FLAG)
3074             PL_utf8cache = -1;
3075         return s;
3076     case 'F':
3077         PL_minus_F = TRUE;
3078         PL_splitstr = ++s;
3079         while (*s && !isSPACE(*s)) ++s;
3080         PL_splitstr = savepvn(PL_splitstr, s - PL_splitstr);
3081         return s;
3082     case 'a':
3083         PL_minus_a = TRUE;
3084         s++;
3085         return s;
3086     case 'c':
3087         PL_minus_c = TRUE;
3088         s++;
3089         return s;
3090     case 'd':
3091         forbid_setid('d', -1);
3092         s++;
3093
3094         /* -dt indicates to the debugger that threads will be used */
3095         if (*s == 't' && !isALNUM(s[1])) {
3096             ++s;
3097             my_setenv("PERL5DB_THREADED", "1");
3098         }
3099
3100         /* The following permits -d:Mod to accepts arguments following an =
3101            in the fashion that -MSome::Mod does. */
3102         if (*s == ':' || *s == '=') {
3103             const char *start;
3104             SV * const sv = newSVpvs("use Devel::");
3105             start = ++s;
3106             /* We now allow -d:Module=Foo,Bar */
3107             while(isALNUM(*s) || *s==':') ++s;
3108             if (*s != '=')
3109                 sv_catpv(sv, start);
3110             else {
3111                 sv_catpvn(sv, start, s-start);
3112                 /* Don't use NUL as q// delimiter here, this string goes in the
3113                  * environment. */
3114                 Perl_sv_catpvf(aTHX_ sv, " split(/,/,q{%s});", ++s);
3115             }
3116             s += strlen(s);
3117             my_setenv("PERL5DB", SvPV_nolen_const(sv));
3118         }
3119         if (!PL_perldb) {
3120             PL_perldb = PERLDB_ALL;
3121             init_debugger();
3122         }
3123         return s;
3124     case 'D':
3125     {
3126 #ifdef DEBUGGING
3127         forbid_setid('D', -1);
3128         s++;
3129         PL_debug = get_debug_opts( (const char **)&s, 1) | DEBUG_TOP_FLAG;
3130 #else /* !DEBUGGING */
3131         if (ckWARN_d(WARN_DEBUGGING))
3132             Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
3133                    "Recompile perl with -DDEBUGGING to use -D switch (did you mean -d ?)\n");
3134         for (s++; isALNUM(*s); s++) ;
3135 #endif
3136         return s;
3137     }
3138     case 'h':
3139         usage(PL_origargv[0]);
3140         my_exit(0);
3141     case 'i':
3142         Safefree(PL_inplace);
3143 #if defined(__CYGWIN__) /* do backup extension automagically */
3144         if (*(s+1) == '\0') {
3145         PL_inplace = savepvs(".bak");
3146         return s+1;
3147         }
3148 #endif /* __CYGWIN__ */
3149         {
3150             const char * const start = ++s;
3151             while (*s && !isSPACE(*s))
3152                 ++s;
3153
3154             PL_inplace = savepvn(start, s - start);
3155         }
3156         if (*s) {
3157             ++s;
3158             if (*s == '-')      /* Additional switches on #! line. */
3159                 s++;
3160         }
3161         return s;
3162     case 'I':   /* -I handled both here and in parse_body() */
3163         forbid_setid('I', -1);
3164         ++s;
3165         while (*s && isSPACE(*s))
3166             ++s;
3167         if (*s) {
3168             char *e, *p;
3169             p = s;
3170             /* ignore trailing spaces (possibly followed by other switches) */
3171             do {
3172                 for (e = p; *e && !isSPACE(*e); e++) ;
3173                 p = e;
3174                 while (isSPACE(*p))
3175                     p++;
3176             } while (*p && *p != '-');
3177             e = savepvn(s, e-s);
3178             incpush(e, TRUE, TRUE, FALSE, FALSE);
3179             Safefree(e);
3180             s = p;
3181             if (*s == '-')
3182                 s++;
3183         }
3184         else
3185             Perl_croak(aTHX_ "No directory specified for -I");
3186         return s;
3187     case 'l':
3188         PL_minus_l = TRUE;
3189         s++;
3190         if (PL_ors_sv) {
3191             SvREFCNT_dec(PL_ors_sv);
3192             PL_ors_sv = NULL;
3193         }
3194         if (isDIGIT(*s)) {
3195             I32 flags = 0;
3196             STRLEN numlen;
3197             PL_ors_sv = newSVpvs("\n");
3198             numlen = 3 + (*s == '0');
3199             *SvPVX(PL_ors_sv) = (char)grok_oct(s, &numlen, &flags, NULL);
3200             s += numlen;
3201         }
3202         else {
3203             if (RsPARA(PL_rs)) {
3204                 PL_ors_sv = newSVpvs("\n\n");
3205             }
3206             else {
3207                 PL_ors_sv = newSVsv(PL_rs);
3208             }
3209         }
3210         return s;
3211     case 'M':
3212         forbid_setid('M', -1);  /* XXX ? */
3213         /* FALL THROUGH */
3214     case 'm':
3215         forbid_setid('m', -1);  /* XXX ? */
3216         if (*++s) {
3217             char *start;
3218             SV *sv;
3219             const char *use = "use ";
3220             /* -M-foo == 'no foo'       */
3221             /* Leading space on " no " is deliberate, to make both
3222                possibilities the same length.  */
3223             if (*s == '-') { use = " no "; ++s; }
3224             sv = newSVpvn(use,4);
3225             start = s;
3226             /* We allow -M'Module qw(Foo Bar)'  */
3227             while(isALNUM(*s) || *s==':') ++s;
3228             if (*s != '=') {
3229                 sv_catpv(sv, start);
3230                 if (*(start-1) == 'm') {
3231                     if (*s != '\0')
3232                         Perl_croak(aTHX_ "Can't use '%c' after -mname", *s);
3233                     sv_catpvs( sv, " ()");
3234                 }
3235             } else {
3236                 if (s == start)
3237                     Perl_croak(aTHX_ "Module name required with -%c option",
3238                                s[-1]);
3239                 sv_catpvn(sv, start, s-start);
3240                 sv_catpvs(sv, " split(/,/,q");
3241                 sv_catpvs(sv, "\0");        /* Use NUL as q//-delimiter. */
3242                 sv_catpv(sv, ++s);
3243                 sv_catpvs(sv,  "\0)");
3244             }
3245             s += strlen(s);
3246             Perl_av_create_and_push(aTHX_ &PL_preambleav, sv);
3247         }
3248         else
3249             Perl_croak(aTHX_ "Missing argument to -%c", *(s-1));
3250         return s;
3251     case 'n':
3252         PL_minus_n = TRUE;
3253         s++;
3254         return s;
3255     case 'p':
3256         PL_minus_p = TRUE;
3257         s++;
3258         return s;
3259     case 's':
3260         forbid_setid('s', -1);
3261         PL_doswitches = TRUE;
3262         s++;
3263         return s;
3264     case 't':
3265         if (!PL_tainting)
3266             TOO_LATE_FOR('t');
3267         s++;
3268         return s;
3269     case 'T':
3270         if (!PL_tainting)
3271             TOO_LATE_FOR('T');
3272         s++;
3273         return s;
3274     case 'u':
3275 #ifdef MACOS_TRADITIONAL
3276         Perl_croak(aTHX_ "Believe me, you don't want to use \"-u\" on a Macintosh");
3277 #endif
3278         PL_do_undump = TRUE;
3279         s++;
3280         return s;
3281     case 'U':
3282         PL_unsafe = TRUE;
3283         s++;
3284         return s;
3285     case 'v':
3286         if (!sv_derived_from(PL_patchlevel, "version"))
3287             upg_version(PL_patchlevel, TRUE);
3288 #if !defined(DGUX)
3289         PerlIO_printf(PerlIO_stdout(),
3290                 Perl_form(aTHX_ "\nThis is perl, %"SVf
3291 #ifdef PERL_PATCHNUM
3292                           " DEVEL" STRINGIFY(PERL_PATCHNUM)
3293 #endif
3294                           " built for %s",
3295                           SVfARG(vstringify(PL_patchlevel)),
3296                           ARCHNAME));
3297 #else /* DGUX */
3298 /* Adjust verbose output as in the perl that ships with the DG/UX OS from EMC */
3299         PerlIO_printf(PerlIO_stdout(),
3300                 Perl_form(aTHX_ "\nThis is perl, %"SVf"\n",
3301                     SVfARG(vstringify(PL_patchlevel))));
3302         PerlIO_printf(PerlIO_stdout(),
3303                         Perl_form(aTHX_ "        built under %s at %s %s\n",
3304                                         OSNAME, __DATE__, __TIME__));
3305         PerlIO_printf(PerlIO_stdout(),
3306                         Perl_form(aTHX_ "        OS Specific Release: %s\n",
3307                                         OSVERS));
3308 #endif /* !DGUX */
3309
3310 #if defined(LOCAL_PATCH_COUNT)
3311         if (LOCAL_PATCH_COUNT > 0)
3312             PerlIO_printf(PerlIO_stdout(),
3313                           "\n(with %d registered patch%s, "
3314                           "see perl -V for more detail)",
3315                           LOCAL_PATCH_COUNT,
3316                           (LOCAL_PATCH_COUNT!=1) ? "es" : "");
3317 #endif
3318
3319         PerlIO_printf(PerlIO_stdout(),
3320                       "\n\nCopyright 1987-2007, Larry Wall\n");
3321 #ifdef MACOS_TRADITIONAL
3322         PerlIO_printf(PerlIO_stdout(),
3323                       "\nMac OS port Copyright 1991-2002, Matthias Neeracher;\n"
3324                       "maintained by Chris Nandor\n");
3325 #endif
3326 #ifdef MSDOS
3327         PerlIO_printf(PerlIO_stdout(),
3328                       "\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
3329 #endif
3330 #ifdef DJGPP
3331         PerlIO_printf(PerlIO_stdout(),
3332                       "djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n"
3333                       "djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n");
3334 #endif
3335 #ifdef OS2
3336         PerlIO_printf(PerlIO_stdout(),
3337                       "\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
3338                       "Version 5 port Copyright (c) 1994-2002, Andreas Kaiser, Ilya Zakharevich\n");
3339 #endif
3340 #ifdef atarist
3341         PerlIO_printf(PerlIO_stdout(),
3342                       "atariST series port, ++jrb  bammi@cadence.com\n");
3343 #endif
3344 #ifdef __BEOS__
3345         PerlIO_printf(PerlIO_stdout(),
3346                       "BeOS port Copyright Tom Spindler, 1997-1999\n");
3347 #endif
3348 #ifdef MPE
3349         PerlIO_printf(PerlIO_stdout(),
3350                       "MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-2003\n");
3351 #endif
3352 #ifdef OEMVS
3353         PerlIO_printf(PerlIO_stdout(),
3354                       "MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
3355 #endif
3356 #ifdef __VOS__
3357         PerlIO_printf(PerlIO_stdout(),
3358                       "Stratus VOS port by Paul.Green@stratus.com, 1997-2002\n");
3359 #endif
3360 #ifdef __OPEN_VM
3361         PerlIO_printf(PerlIO_stdout(),
3362                       "VM/ESA port by Neale Ferguson, 1998-1999\n");
3363 #endif
3364 #ifdef POSIX_BC
3365         PerlIO_printf(PerlIO_stdout(),
3366                       "BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
3367 #endif
3368 #ifdef __MINT__
3369         PerlIO_printf(PerlIO_stdout(),
3370                       "MiNT port by Guido Flohr, 1997-1999\n");
3371 #endif
3372 #ifdef EPOC
3373         PerlIO_printf(PerlIO_stdout(),
3374                       "EPOC port by Olaf Flebbe, 1999-2002\n");
3375 #endif
3376 #ifdef UNDER_CE
3377         PerlIO_printf(PerlIO_stdout(),"WINCE port by Rainer Keuchel, 2001-2002\n");
3378         PerlIO_printf(PerlIO_stdout(),"Built on " __DATE__ " " __TIME__ "\n\n");
3379         wce_hitreturn();
3380 #endif
3381 #ifdef __SYMBIAN32__
3382         PerlIO_printf(PerlIO_stdout(),
3383                       "Symbian port by Nokia, 2004-2005\n");
3384 #endif
3385 #ifdef BINARY_BUILD_NOTICE
3386         BINARY_BUILD_NOTICE;
3387 #endif
3388         PerlIO_printf(PerlIO_stdout(),
3389                       "\n\
3390 Perl may be copied only under the terms of either the Artistic License or the\n\
3391 GNU General Public License, which may be found in the Perl 5 source kit.\n\n\
3392 Complete documentation for Perl, including FAQ lists, should be found on\n\
3393 this system using \"man perl\" or \"perldoc perl\".  If you have access to the\n\
3394 Internet, point your browser at http://www.perl.org/, the Perl Home Page.\n\n");
3395         my_exit(0);
3396     case 'w':
3397         if (! (PL_dowarn & G_WARN_ALL_MASK)) {
3398             PL_dowarn |= G_WARN_ON;
3399         }
3400         s++;
3401         return s;
3402     case 'W':
3403         PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
3404         if (!specialWARN(PL_compiling.cop_warnings))
3405             PerlMemShared_free(PL_compiling.cop_warnings);
3406         PL_compiling.cop_warnings = pWARN_ALL ;
3407         s++;
3408         return s;
3409     case 'X':
3410         PL_dowarn = G_WARN_ALL_OFF;
3411         if (!specialWARN(PL_compiling.cop_warnings))
3412             PerlMemShared_free(PL_compiling.cop_warnings);
3413         PL_compiling.cop_warnings = pWARN_NONE ;
3414         s++;
3415         return s;
3416     case '*':
3417     case ' ':
3418         if (s[1] == '-')        /* Additional switches on #! line. */
3419             return s+2;
3420         break;
3421     case '-':
3422     case 0:
3423 #if defined(WIN32) || !defined(PERL_STRICT_CR)
3424     case '\r':
3425 #endif
3426     case '\n':
3427     case '\t':
3428         break;
3429 #ifdef ALTERNATE_SHEBANG
3430     case 'S':                   /* OS/2 needs -S on "extproc" line. */
3431         break;
3432 #endif
3433     case 'P':
3434         if (PL_preprocess)
3435             return s+1;
3436         /* FALL THROUGH */
3437     default:
3438         Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s);
3439     }
3440     return NULL;
3441 }
3442
3443 /* compliments of Tom Christiansen */
3444
3445 /* unexec() can be found in the Gnu emacs distribution */
3446 /* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
3447
3448 void
3449 Perl_my_unexec(pTHX)
3450 {
3451     PERL_UNUSED_CONTEXT;
3452 #ifdef UNEXEC
3453     SV *    prog = newSVpv(BIN_EXP, 0);
3454     SV *    file = newSVpv(PL_origfilename, 0);
3455     int    status = 1;
3456     extern int etext;
3457
3458     sv_catpvs(prog, "/perl");
3459     sv_catpvs(file, ".perldump");
3460
3461     unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
3462     /* unexec prints msg to stderr in case of failure */
3463     PerlProc_exit(status);
3464 #else
3465 #  ifdef VMS
3466 #    include <lib$routines.h>
3467      lib$signal(SS$_DEBUG);  /* ssdef.h #included from vmsish.h */
3468 #  elif defined(WIN32) || defined(__CYGWIN__)
3469     Perl_croak(aTHX_ "dump is not supported");
3470 #  else
3471     ABORT();            /* for use with undump */
3472 #  endif
3473 #endif
3474 }
3475
3476 /* initialize curinterp */
3477 STATIC void
3478 S_init_interp(pTHX)
3479 {
3480     dVAR;
3481 #ifdef MULTIPLICITY
3482 #  define PERLVAR(var,type)
3483 #  define PERLVARA(var,n,type)
3484 #  if defined(PERL_IMPLICIT_CONTEXT)
3485 #    define PERLVARI(var,type,init)             aTHX->var = init;
3486 #    define PERLVARIC(var,type,init)    aTHX->var = init;
3487 #  else
3488 #    define PERLVARI(var,type,init)     PERL_GET_INTERP->var = init;
3489 #    define PERLVARIC(var,type,init)    PERL_GET_INTERP->var = init;
3490 #  endif
3491 #  include "intrpvar.h"
3492 #  undef PERLVAR
3493 #  undef PERLVARA
3494 #  undef PERLVARI
3495 #  undef PERLVARIC
3496 #else
3497 #  define PERLVAR(var,type)
3498 #  define PERLVARA(var,n,type)
3499 #  define PERLVARI(var,type,init)       PL_##var = init;
3500 #  define PERLVARIC(var,type,init)      PL_##var = init;
3501 #  include "intrpvar.h"
3502 #  undef PERLVAR
3503 #  undef PERLVARA
3504 #  undef PERLVARI
3505 #  undef PERLVARIC
3506 #endif
3507
3508     /* As these are inside a structure, PERLVARI isn't capable of initialising
3509        them  */
3510     PL_reg_oldcurpm = PL_reg_curpm = NULL;
3511     PL_reg_poscache = PL_reg_starttry = NULL;
3512 }
3513
3514 STATIC void
3515 S_init_main_stash(pTHX)
3516 {
3517     dVAR;
3518     GV *gv;
3519
3520     PL_curstash = PL_defstash = newHV();
3521     /* We know that the string "main" will be in the global shared string
3522        table, so it's a small saving to use it rather than allocate another
3523        8 bytes.  */
3524     PL_curstname = newSVpvs_share("main");
3525     gv = gv_fetchpvs("main::", GV_ADD|GV_NOTQUAL, SVt_PVHV);
3526     /* If we hadn't caused another reference to "main" to be in the shared
3527        string table above, then it would be worth reordering these two,
3528        because otherwise all we do is delete "main" from it as a consequence
3529        of the SvREFCNT_dec, only to add it again with hv_name_set */
3530     SvREFCNT_dec(GvHV(gv));
3531     hv_name_set(PL_defstash, "main", 4, 0);
3532     GvHV(gv) = (HV*)SvREFCNT_inc_simple(PL_defstash);
3533     SvREADONLY_on(gv);
3534     PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpvs("INC", GV_ADD|GV_NOTQUAL,
3535                                              SVt_PVAV)));
3536     SvREFCNT_inc_simple_void(PL_incgv); /* Don't allow it to be freed */
3537     GvMULTI_on(PL_incgv);
3538     PL_hintgv = gv_fetchpvs("\010", GV_ADD|GV_NOTQUAL, SVt_PV); /* ^H */
3539     GvMULTI_on(PL_hintgv);
3540     PL_defgv = gv_fetchpvs("_", GV_ADD|GV_NOTQUAL, SVt_PVAV);
3541     SvREFCNT_inc_simple_void(PL_defgv);
3542     PL_errgv = gv_HVadd(gv_fetchpvs("@", GV_ADD|GV_NOTQUAL, SVt_PV));
3543     SvREFCNT_inc_simple_void(PL_errgv);
3544     GvMULTI_on(PL_errgv);
3545     PL_replgv = gv_fetchpvs("\022", GV_ADD|GV_NOTQUAL, SVt_PV); /* ^R */
3546     GvMULTI_on(PL_replgv);
3547     (void)Perl_form(aTHX_ "%240s","");  /* Preallocate temp - for immediate signals. */
3548 #ifdef PERL_DONT_CREATE_GVSV
3549     gv_SVadd(PL_errgv);
3550 #endif
3551     sv_grow(ERRSV, 240);        /* Preallocate - for immediate signals. */
3552     sv_setpvn(ERRSV, "", 0);
3553     PL_curstash = PL_defstash;
3554     CopSTASH_set(&PL_compiling, PL_defstash);
3555     PL_debstash = GvHV(gv_fetchpvs("DB::", GV_ADDMULTI, SVt_PVHV));
3556     PL_globalstash = GvHV(gv_fetchpvs("CORE::GLOBAL::", GV_ADDMULTI,
3557                                       SVt_PVHV));
3558     /* We must init $/ before switches are processed. */
3559     sv_setpvn(get_sv("/", TRUE), "\n", 1);
3560 }
3561
3562 STATIC int
3563 S_open_script(pTHX_ const char *scriptname, bool dosearch, SV *sv,
3564               int *suidscript, PerlIO **rsfpp)
3565 {
3566 #ifndef IAMSUID
3567     const char *quote;
3568     const char *code;
3569     const char *cpp_discard_flag;
3570     const char *perl;
3571 #endif
3572     int fdscript = -1;
3573     dVAR;
3574
3575     *suidscript = -1;
3576
3577     if (PL_e_script) {
3578         PL_origfilename = savepvs("-e");
3579     }
3580     else {
3581         /* if find_script() returns, it returns a malloc()-ed value */
3582         scriptname = PL_origfilename = find_script(scriptname, dosearch, NULL, 1);
3583
3584         if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
3585             const char *s = scriptname + 8;
3586             fdscript = atoi(s);
3587             while (isDIGIT(*s))
3588                 s++;
3589             if (*s) {
3590                 /* PSz 18 Feb 04
3591                  * Tell apart "normal" usage of fdscript, e.g.
3592                  * with bash on FreeBSD:
3593                  *   perl <( echo '#!perl -DA'; echo 'print "$0\n"')
3594                  * from usage in suidperl.
3595                  * Does any "normal" usage leave garbage after the number???
3596                  * Is it a mistake to use a similar /dev/fd/ construct for
3597                  * suidperl?
3598                  */
3599                 *suidscript = 1;
3600                 /* PSz 20 Feb 04
3601                  * Be supersafe and do some sanity-checks.
3602                  * Still, can we be sure we got the right thing?
3603                  */
3604                 if (*s != '/') {
3605                     Perl_croak(aTHX_ "Wrong syntax (suid) fd script name \"%s\"\n", s);
3606                 }
3607                 if (! *(s+1)) {
3608                     Perl_croak(aTHX_ "Missing (suid) fd script name\n");
3609                 }
3610                 scriptname = savepv(s + 1);
3611                 Safefree(PL_origfilename);
3612                 PL_origfilename = (char *)scriptname;
3613             }
3614         }
3615     }
3616
3617     CopFILE_free(PL_curcop);
3618     CopFILE_set(PL_curcop, PL_origfilename);
3619     if (*PL_origfilename == '-' && PL_origfilename[1] == '\0')
3620         scriptname = (char *)"";
3621     if (fdscript >= 0) {
3622         *rsfpp = PerlIO_fdopen(fdscript,PERL_SCRIPT_MODE);
3623 #       if defined(HAS_FCNTL) && defined(F_SETFD)
3624             if (*rsfpp)
3625                 /* ensure close-on-exec */
3626                 fcntl(PerlIO_fileno(*rsfpp),F_SETFD,1);
3627 #       endif
3628     }
3629 #ifdef IAMSUID
3630     else {
3631         Perl_croak(aTHX_ "sperl needs fd script\n"
3632                    "You should not call sperl directly; do you need to "
3633                    "change a #! line\nfrom sperl to perl?\n");
3634
3635 /* PSz 11 Nov 03
3636  * Do not open (or do other fancy stuff) while setuid.
3637  * Perl does the open, and hands script to suidperl on a fd;
3638  * suidperl only does some checks, sets up UIDs and re-execs
3639  * perl with that fd as it has always done.
3640  */
3641     }
3642     if (*suidscript != 1) {
3643         Perl_croak(aTHX_ "suidperl needs (suid) fd script\n");
3644     }
3645 #else /* IAMSUID */
3646     else if (PL_preprocess) {
3647         const char * const cpp_cfg = CPPSTDIN;
3648         SV * const cpp = newSVpvs("");
3649         SV * const cmd = newSV(0);
3650
3651         if (cpp_cfg[0] == 0) /* PERL_MICRO? */
3652              Perl_croak(aTHX_ "Can't run with cpp -P with CPPSTDIN undefined");
3653         if (strEQ(cpp_cfg, "cppstdin"))
3654             Perl_sv_catpvf(aTHX_ cpp, "%s/", BIN_EXP);
3655         sv_catpv(cpp, cpp_cfg);
3656
3657 #       ifndef VMS
3658             sv_catpvs(sv, "-I");
3659             sv_catpv(sv,PRIVLIB_EXP);
3660 #       endif
3661
3662         DEBUG_P(PerlIO_printf(Perl_debug_log,
3663                               "PL_preprocess: scriptname=\"%s\", cpp=\"%s\", sv=\"%s\", CPPMINUS=\"%s\"\n",
3664                               scriptname, SvPVX_const (cpp), SvPVX_const (sv),
3665                               CPPMINUS));
3666
3667 #       if defined(MSDOS) || defined(WIN32) || defined(VMS)
3668             quote = "\"";
3669 #       else
3670             quote = "'";
3671 #       endif
3672
3673 #       ifdef VMS
3674             cpp_discard_flag = "";
3675 #       else
3676             cpp_discard_flag = "-C";
3677 #       endif
3678
3679 #       ifdef OS2
3680             perl = os2_execname(aTHX);
3681 #       else
3682             perl = PL_origargv[0];
3683 #       endif
3684
3685
3686         /* This strips off Perl comments which might interfere with
3687            the C pre-processor, including #!.  #line directives are
3688            deliberately stripped to avoid confusion with Perl's version
3689            of #line.  FWP played some golf with it so it will fit
3690            into VMS's 255 character buffer.
3691         */
3692         if( PL_doextract )
3693             code = "(1../^#!.*perl/i)|/^\\s*#(?!\\s*((ifn?|un)def|(el|end)?if|define|include|else|error|pragma)\\b)/||!($|=1)||print";
3694         else
3695             code = "/^\\s*#(?!\\s*((ifn?|un)def|(el|end)?if|define|include|else|error|pragma)\\b)/||!($|=1)||print";
3696
3697         Perl_sv_setpvf(aTHX_ cmd, "\
3698 %s -ne%s%s%s %s | %"SVf" %s %"SVf" %s",
3699                        perl, quote, code, quote, scriptname, SVfARG(cpp),
3700                        cpp_discard_flag, SVfARG(sv), CPPMINUS);
3701
3702         PL_doextract = FALSE;
3703
3704         DEBUG_P(PerlIO_printf(Perl_debug_log,
3705                               "PL_preprocess: cmd=\"%s\"\n",
3706                               SvPVX_const(cmd)));
3707
3708         *rsfpp = PerlProc_popen((char *)SvPVX_const(cmd), (char *)"r");
3709         SvREFCNT_dec(cmd);
3710         SvREFCNT_dec(cpp);
3711     }
3712     else if (!*scriptname) {
3713         forbid_setid(0, *suidscript);
3714         *rsfpp = PerlIO_stdin();
3715     }
3716     else {
3717 #ifdef FAKE_BIT_BUCKET
3718         /* This hack allows one not to have /dev/null (or BIT_BUCKET as it
3719          * is called) and still have the "-e" work.  (Believe it or not,
3720          * a /dev/null is required for the "-e" to work because source
3721          * filter magic is used to implement it. ) This is *not* a general
3722          * replacement for a /dev/null.  What we do here is create a temp
3723          * file (an empty file), open up that as the script, and then
3724          * immediately close and unlink it.  Close enough for jazz. */
3725 #define FAKE_BIT_BUCKET_PREFIX "/tmp/perlnull-"
3726 #define FAKE_BIT_BUCKET_SUFFIX "XXXXXXXX"
3727 #define FAKE_BIT_BUCKET_TEMPLATE FAKE_BIT_BUCKET_PREFIX FAKE_BIT_BUCKET_SUFFIX
3728         char tmpname[sizeof(FAKE_BIT_BUCKET_TEMPLATE)] = {
3729             FAKE_BIT_BUCKET_TEMPLATE
3730         };
3731         const char * const err = "Failed to create a fake bit bucket";
3732         if (strEQ(scriptname, BIT_BUCKET)) {
3733 #ifdef HAS_MKSTEMP /* Hopefully mkstemp() is safe here. */
3734             int tmpfd = mkstemp(tmpname);
3735             if (tmpfd > -1) {
3736                 scriptname = tmpname;
3737                 close(tmpfd);
3738             } else
3739                 Perl_croak(aTHX_ err);
3740 #else
3741 #  ifdef HAS_MKTEMP
3742             scriptname = mktemp(tmpname);
3743             if (!scriptname)
3744                 Perl_croak(aTHX_ err);
3745 #  endif
3746 #endif
3747         }
3748 #endif
3749         *rsfpp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
3750 #ifdef FAKE_BIT_BUCKET
3751         if (memEQ(scriptname, FAKE_BIT_BUCKET_PREFIX,
3752                   sizeof(FAKE_BIT_BUCKET_PREFIX) - 1)
3753             && strlen(scriptname) == sizeof(tmpname) - 1) {
3754             unlink(scriptname);
3755         }
3756         scriptname = BIT_BUCKET;
3757 #endif
3758 #       if defined(HAS_FCNTL) && defined(F_SETFD)
3759             if (*rsfpp)
3760                 /* ensure close-on-exec */
3761                 fcntl(PerlIO_fileno(*rsfpp),F_SETFD,1);
3762 #       endif
3763     }
3764 #endif /* IAMSUID */
3765     if (!*rsfpp) {
3766         /* PSz 16 Sep 03  Keep neat error message */
3767         if (PL_e_script)
3768             Perl_croak(aTHX_ "Can't open "BIT_BUCKET": %s\n", Strerror(errno));
3769         else
3770             Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
3771                     CopFILE(PL_curcop), Strerror(errno));
3772     }
3773     return fdscript;
3774 }
3775
3776 /* Mention
3777  * I_SYSSTATVFS HAS_FSTATVFS
3778  * I_SYSMOUNT
3779  * I_STATFS     HAS_FSTATFS     HAS_GETFSSTAT
3780  * I_MNTENT     HAS_GETMNTENT   HAS_HASMNTOPT
3781  * here so that metaconfig picks them up. */
3782
3783 #ifdef IAMSUID
3784 STATIC int
3785 S_fd_on_nosuid_fs(pTHX_ int fd)
3786 {
3787 /* PSz 27 Feb 04
3788  * We used to do this as "plain" user (after swapping UIDs with setreuid);
3789  * but is needed also on machines without setreuid.
3790  * Seems safe enough to run as root.
3791  */
3792     int check_okay = 0; /* able to do all the required sys/libcalls */
3793     int on_nosuid  = 0; /* the fd is on a nosuid fs */
3794     /* PSz 12 Nov 03
3795      * Need to check noexec also: nosuid might not be set, the average
3796      * sysadmin would say that nosuid is irrelevant once he sets noexec.
3797      */
3798     int on_noexec  = 0; /* the fd is on a noexec fs */
3799
3800 /*
3801  * Preferred order: fstatvfs(), fstatfs(), ustat()+getmnt(), getmntent().
3802  * fstatvfs() is UNIX98.
3803  * fstatfs() is 4.3 BSD.
3804  * ustat()+getmnt() is pre-4.3 BSD.
3805  * getmntent() is O(number-of-mounted-filesystems) and can hang on
3806  * an irrelevant filesystem while trying to reach the right one.
3807  */
3808
3809 #undef FD_ON_NOSUID_CHECK_OKAY  /* found the syscalls to do the check? */
3810
3811 #   if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
3812         defined(HAS_FSTATVFS)
3813 #   define FD_ON_NOSUID_CHECK_OKAY
3814     struct statvfs stfs;
3815
3816     check_okay = fstatvfs(fd, &stfs) == 0;
3817     on_nosuid  = check_okay && (stfs.f_flag  & ST_NOSUID);
3818 #ifdef ST_NOEXEC
3819     /* ST_NOEXEC certainly absent on AIX 5.1, and doesn't seem to be documented
3820        on platforms where it is present.  */
3821     on_noexec  = check_okay && (stfs.f_flag  & ST_NOEXEC);
3822 #endif
3823 #   endif /* fstatvfs */
3824
3825 #   if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
3826         defined(PERL_MOUNT_NOSUID)      && \
3827         defined(PERL_MOUNT_NOEXEC)      && \
3828         defined(HAS_FSTATFS)            && \
3829         defined(HAS_STRUCT_STATFS)      && \
3830         defined(HAS_STRUCT_STATFS_F_FLAGS)
3831 #   define FD_ON_NOSUID_CHECK_OKAY
3832     struct statfs  stfs;
3833
3834     check_okay = fstatfs(fd, &stfs)  == 0;
3835     on_nosuid  = check_okay && (stfs.f_flags & PERL_MOUNT_NOSUID);
3836     on_noexec  = check_okay && (stfs.f_flags & PERL_MOUNT_NOEXEC);
3837 #   endif /* fstatfs */
3838
3839 #   if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
3840         defined(PERL_MOUNT_NOSUID)      && \
3841         defined(PERL_MOUNT_NOEXEC)      && \
3842         defined(HAS_FSTAT)              && \
3843         defined(HAS_USTAT)              && \
3844         defined(HAS_GETMNT)             && \
3845         defined(HAS_STRUCT_FS_DATA)     && \
3846         defined(NOSTAT_ONE)
3847 #   define FD_ON_NOSUID_CHECK_OKAY
3848     Stat_t fdst;
3849
3850     if (fstat(fd, &fdst) == 0) {
3851         struct ustat us;
3852         if (ustat(fdst.st_dev, &us) == 0) {
3853             struct fs_data fsd;
3854             /* NOSTAT_ONE here because we're not examining fields which
3855              * vary between that case and STAT_ONE. */
3856             if (getmnt((int*)0, &fsd, (int)0, NOSTAT_ONE, us.f_fname) == 0) {
3857                 size_t cmplen = sizeof(us.f_fname);
3858                 if (sizeof(fsd.fd_req.path) < cmplen)
3859                     cmplen = sizeof(fsd.fd_req.path);
3860                 if (strnEQ(fsd.fd_req.path, us.f_fname, cmplen) &&
3861                     fdst.st_dev == fsd.fd_req.dev) {
3862                     check_okay = 1;
3863                     on_nosuid = fsd.fd_req.flags & PERL_MOUNT_NOSUID;
3864                     on_noexec = fsd.fd_req.flags & PERL_MOUNT_NOEXEC;
3865                 }
3866             }
3867         }
3868     }
3869 #   endif /* fstat+ustat+getmnt */
3870
3871 #   if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
3872         defined(HAS_GETMNTENT)          && \
3873         defined(HAS_HASMNTOPT)          && \
3874         defined(MNTOPT_NOSUID)          && \
3875         defined(MNTOPT_NOEXEC)
3876 #   define FD_ON_NOSUID_CHECK_OKAY
3877     FILE                *mtab = fopen("/etc/mtab", "r");
3878     struct mntent       *entry;
3879     Stat_t              stb, fsb;
3880
3881     if (mtab && (fstat(fd, &stb) == 0)) {
3882         while (entry = getmntent(mtab)) {
3883             if (stat(entry->mnt_dir, &fsb) == 0
3884                 && fsb.st_dev == stb.st_dev)
3885             {
3886                 /* found the filesystem */
3887                 check_okay = 1;
3888                 if (hasmntopt(entry, MNTOPT_NOSUID))
3889                     on_nosuid = 1;
3890                 if (hasmntopt(entry, MNTOPT_NOEXEC))
3891                     on_noexec = 1;
3892                 break;
3893             } /* A single fs may well fail its stat(). */
3894         }
3895     }
3896     if (mtab)
3897         fclose(mtab);
3898 #   endif /* getmntent+hasmntopt */
3899
3900     if (!check_okay)
3901         Perl_croak(aTHX_ "Can't check filesystem of script \"%s\" for nosuid/noexec", PL_origfilename);
3902     if (on_nosuid)
3903         Perl_croak(aTHX_ "Setuid script \"%s\" on nosuid filesystem", PL_origfilename);
3904     if (on_noexec)
3905         Perl_croak(aTHX_ "Setuid script \"%s\" on noexec filesystem", PL_origfilename);
3906     return ((!check_okay) || on_nosuid || on_noexec);
3907 }
3908 #endif /* IAMSUID */
3909
3910 STATIC void
3911 S_validate_suid(pTHX_ const char *validarg, const char *scriptname,
3912                 int fdscript, int suidscript, SV *linestr_sv, PerlIO *rsfp)
3913 {
3914     dVAR;
3915 #ifdef IAMSUID
3916     /* int which; */
3917 #endif /* IAMSUID */
3918
3919     /* do we need to emulate setuid on scripts? */
3920
3921     /* This code is for those BSD systems that have setuid #! scripts disabled
3922      * in the kernel because of a security problem.  Merely defining DOSUID
3923      * in perl will not fix that problem, but if you have disabled setuid
3924      * scripts in the kernel, this will attempt to emulate setuid and setgid
3925      * on scripts that have those now-otherwise-useless bits set.  The setuid
3926      * root version must be called suidperl or sperlN.NNN.  If regular perl
3927      * discovers that it has opened a setuid script, it calls suidperl with
3928      * the same argv that it had.  If suidperl finds that the script it has
3929      * just opened is NOT setuid root, it sets the effective uid back to the
3930      * uid.  We don't just make perl setuid root because that loses the
3931      * effective uid we had before invoking perl, if it was different from the
3932      * uid.
3933      * PSz 27 Feb 04
3934      * Description/comments above do not match current workings:
3935      *   suidperl must be hardlinked to sperlN.NNN (that is what we exec);
3936      *   suidperl called with script open and name changed to /dev/fd/N/X;
3937      *   suidperl croaks if script is not setuid;
3938      *   making perl setuid would be a huge security risk (and yes, that
3939      *     would lose any euid we might have had).
3940      *
3941      * DOSUID must be defined in both perl and suidperl, and IAMSUID must
3942      * be defined in suidperl only.  suidperl must be setuid root.  The
3943      * Configure script will set this up for you if you want it.
3944      */
3945
3946 #ifdef DOSUID
3947     const char *s, *s2;
3948
3949     if (PerlLIO_fstat(PerlIO_fileno(rsfp),&PL_statbuf) < 0)     /* normal stat is insecure */
3950         Perl_croak(aTHX_ "Can't stat script \"%s\"",PL_origfilename);
3951     if (PL_statbuf.st_mode & (S_ISUID|S_ISGID)) {
3952         I32 len;
3953         const char *linestr;
3954         const char *s_end;
3955
3956 #  ifdef IAMSUID
3957         if (fdscript < 0 || suidscript != 1)
3958             Perl_croak(aTHX_ "Need (suid) fdscript in suidperl\n");     /* We already checked this */
3959         /* PSz 11 Nov 03
3960          * Since the script is opened by perl, not suidperl, some of these
3961          * checks are superfluous. Leaving them in probably does not lower
3962          * security(?!).
3963          */
3964         /* PSz 27 Feb 04
3965          * Do checks even for systems with no HAS_SETREUID.
3966          * We used to swap, then re-swap UIDs with
3967 #    ifdef HAS_SETREUID
3968             if (setreuid(PL_euid,PL_uid) < 0
3969                 || PerlProc_getuid() != PL_euid || PerlProc_geteuid() != PL_uid)
3970                 Perl_croak(aTHX_ "Can't swap uid and euid");
3971 #    endif
3972 #    ifdef HAS_SETREUID
3973             if (setreuid(PL_uid,PL_euid) < 0
3974                 || PerlProc_getuid() != PL_uid || PerlProc_geteuid() != PL_euid)
3975                 Perl_croak(aTHX_ "Can't reswap uid and euid");
3976 #    endif
3977          */
3978
3979         /* On this access check to make sure the directories are readable,
3980          * there is actually a small window that the user could use to make
3981          * filename point to an accessible directory.  So there is a faint
3982          * chance that someone could execute a setuid script down in a
3983          * non-accessible directory.  I don't know what to do about that.
3984          * But I don't think it's too important.  The manual lies when
3985          * it says access() is useful in setuid programs.
3986          *
3987          * So, access() is pretty useless... but not harmful... do anyway.
3988          */
3989         if (PerlLIO_access(CopFILE(PL_curcop),1)) { /*double check*/
3990             Perl_croak(aTHX_ "Can't access() script\n");
3991         }
3992
3993         /* If we can swap euid and uid, then we can determine access rights
3994          * with a simple stat of the file, and then compare device and
3995          * inode to make sure we did stat() on the same file we opened.
3996          * Then we just have to make sure he or she can execute it.
3997          *
3998          * PSz 24 Feb 04
3999          * As the script is opened by perl, not suidperl, we do not need to
4000          * care much about access rights.
4001          *
4002          * The 'script changed' check is needed, or we can get lied to
4003          * about $0 with e.g.
4004          *  suidperl /dev/fd/4//bin/x 4<setuidscript
4005          * Without HAS_SETREUID, is it safe to stat() as root?
4006          *
4007          * Are there any operating systems that pass /dev/fd/xxx for setuid
4008          * scripts, as suggested/described in perlsec(1)? Surely they do not
4009          * pass the script name as we do, so the "script changed" test would
4010          * fail for them... but we never get here with
4011          * SETUID_SCRIPTS_ARE_SECURE_NOW defined.
4012          *
4013          * This is one place where we must "lie" about return status: not
4014          * say if the stat() failed. We are doing this as root, and could
4015          * be tricked into reporting existence or not of files that the
4016          * "plain" user cannot even see.
4017          */
4018         {
4019             Stat_t tmpstatbuf;
4020             if (PerlLIO_stat(CopFILE(PL_curcop),&tmpstatbuf) < 0 ||
4021                 tmpstatbuf.st_dev != PL_statbuf.st_dev ||
4022                 tmpstatbuf.st_ino != PL_statbuf.st_ino) {
4023                 Perl_croak(aTHX_ "Setuid script changed\n");
4024             }
4025
4026         }
4027         if (!cando(S_IXUSR,FALSE,&PL_statbuf))          /* can real uid exec? */
4028             Perl_croak(aTHX_ "Real UID cannot exec script\n");
4029
4030         /* PSz 27 Feb 04
4031          * We used to do this check as the "plain" user (after swapping
4032          * UIDs). But the check for nosuid and noexec filesystem is needed,
4033          * and should be done even without HAS_SETREUID. (Maybe those
4034          * operating systems do not have such mount options anyway...)
4035          * Seems safe enough to do as root.
4036          */
4037 #    if !defined(NO_NOSUID_CHECK)
4038         if (fd_on_nosuid_fs(PerlIO_fileno(rsfp))) {
4039             Perl_croak(aTHX_ "Setuid script on nosuid or noexec filesystem\n");
4040         }
4041 #    endif
4042 #  endif /* IAMSUID */
4043
4044         if (!S_ISREG(PL_statbuf.st_mode)) {
4045             Perl_croak(aTHX_ "Setuid script not plain file\n");
4046         }
4047         if (PL_statbuf.st_mode & S_IWOTH)
4048             Perl_croak(aTHX_ "Setuid/gid script is writable by world");
4049         PL_doswitches = FALSE;          /* -s is insecure in suid */
4050         /* PSz 13 Nov 03  But -s was caught elsewhere ... so unsetting it here is useless(?!) */
4051         CopLINE_inc(PL_curcop);
4052         if (sv_gets(linestr_sv, rsfp, 0) == NULL)
4053             Perl_croak(aTHX_ "No #! line");
4054         linestr = SvPV_nolen_const(linestr_sv);
4055         /* required even on Sys V */
4056         if (!*linestr || !linestr[1] || strnNE(linestr,"#!",2))
4057             Perl_croak(aTHX_ "No #! line");
4058         linestr += 2;
4059         s = linestr;
4060         /* PSz 27 Feb 04 */
4061         /* Sanity check on line length */
4062         s_end = s + strlen(s);
4063         if (s_end == s || (s_end - s) > 4000)
4064             Perl_croak(aTHX_ "Very long #! line");
4065         /* Allow more than a single space after #! */
4066         while (isSPACE(*s)) s++;
4067         /* Sanity check on buffer end */
4068         while ((*s) && !isSPACE(*s)) s++;
4069         for (s2 = s;  (s2 > linestr &&
4070                        (isDIGIT(s2[-1]) || s2[-1] == '.' || s2[-1] == '_'
4071                         || s2[-1] == '-'));  s2--) ;
4072         /* Sanity check on buffer start */
4073         if ( (s2-4 < linestr || strnNE(s2-4,"perl",4)) &&
4074               (s-9 < linestr || strnNE(s-9,"perl",4)) )
4075             Perl_croak(aTHX_ "Not a perl script");
4076         while (*s == ' ' || *s == '\t') s++;
4077         /*
4078          * #! arg must be what we saw above.  They can invoke it by
4079          * mentioning suidperl explicitly, but they may not add any strange
4080          * arguments beyond what #! says if they do invoke suidperl that way.
4081          */
4082         /*
4083          * The way validarg was set up, we rely on the kernel to start
4084          * scripts with argv[1] set to contain all #! line switches (the
4085          * whole line).
4086          */
4087         /*
4088          * Check that we got all the arguments listed in the #! line (not
4089          * just that there are no extraneous arguments). Might not matter
4090          * much, as switches from #! line seem to be acted upon (also), and
4091          * so may be checked and trapped in perl. But, security checks must
4092          * be done in suidperl and not deferred to perl. Note that suidperl
4093          * does not get around to parsing (and checking) the switches on
4094          * the #! line (but execs perl sooner).
4095          * Allow (require) a trailing newline (which may be of two
4096          * characters on some architectures?) (but no other trailing
4097          * whitespace).
4098          */
4099         len = strlen(validarg);
4100         if (strEQ(validarg," PHOOEY ") ||
4101             strnNE(s,validarg,len) || !isSPACE(s[len]) ||
4102             !((s_end - s) == len+1
4103               || ((s_end - s) == len+2 && isSPACE(s[len+1]))))
4104             Perl_croak(aTHX_ "Args must match #! line");
4105
4106 #  ifndef IAMSUID
4107         if (fdscript < 0 &&
4108             PL_euid != PL_uid && (PL_statbuf.st_mode & S_ISUID) &&
4109             PL_euid == PL_statbuf.st_uid)
4110             if (!PL_do_undump)
4111                 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
4112 FIX YOUR KERNEL, OR PUT A C WRAPPER AROUND THIS SCRIPT!\n");
4113 #  endif /* IAMSUID */
4114
4115         if (fdscript < 0 &&
4116             PL_euid) {  /* oops, we're not the setuid root perl */
4117             /* PSz 18 Feb 04
4118              * When root runs a setuid script, we do not go through the same
4119              * steps of execing sperl and then perl with fd scripts, but
4120              * simply set up UIDs within the same perl invocation; so do
4121              * not have the same checks (on options, whatever) that we have
4122              * for plain users. No problem really: would have to be a script
4123              * that does not actually work for plain users; and if root is
4124              * foolish and can be persuaded to run such an unsafe script, he
4125              * might run also non-setuid ones, and deserves what he gets.
4126              *
4127              * Or, we might drop the PL_euid check above (and rely just on
4128              * fdscript to avoid loops), and do the execs
4129              * even for root.
4130              */
4131 #  ifndef IAMSUID
4132             int which;
4133             /* PSz 11 Nov 03
4134              * Pass fd script to suidperl.
4135              * Exec suidperl, substituting fd script for scriptname.
4136              * Pass script name as "subdir" of fd, which perl will grok;
4137              * in fact will use that to distinguish this from "normal"
4138              * usage, see comments above.
4139              */
4140             PerlIO_rewind(rsfp);
4141             PerlLIO_lseek(PerlIO_fileno(rsfp),(Off_t)0,0);  /* just in case rewind didn't */
4142             /* PSz 27 Feb 04  Sanity checks on scriptname */
4143             if ((!scriptname) || (!*scriptname) ) {
4144                 Perl_croak(aTHX_ "No setuid script name\n");
4145             }
4146             if (*scriptname == '-') {
4147                 Perl_croak(aTHX_ "Setuid script name may not begin with dash\n");
4148                 /* Or we might confuse it with an option when replacing
4149                  * name in argument list, below (though we do pointer, not
4150                  * string, comparisons).
4151                  */
4152             }
4153             for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ;
4154             if (!PL_origargv[which]) {
4155                 Perl_croak(aTHX_ "Can't change argv to have fd script\n");
4156             }
4157             PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s",
4158                                           PerlIO_fileno(rsfp), PL_origargv[which]));
4159 #    if defined(HAS_FCNTL) && defined(F_SETFD)
4160             fcntl(PerlIO_fileno(rsfp),F_SETFD,0);       /* ensure no close-on-exec */
4161 #    endif
4162             PERL_FPU_PRE_EXEC
4163             PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT, BIN_EXP,
4164                                      (int)PERL_REVISION, (int)PERL_VERSION,
4165                                      (int)PERL_SUBVERSION), PL_origargv);
4166             PERL_FPU_POST_EXEC
4167 #  endif /* IAMSUID */
4168             Perl_croak(aTHX_ "Can't do setuid (cannot exec sperl)\n");
4169         }
4170
4171         if (PL_statbuf.st_mode & S_ISGID && PL_statbuf.st_gid != PL_egid) {
4172 /* PSz 26 Feb 04
4173  * This seems back to front: we try HAS_SETEGID first; if not available
4174  * then try HAS_SETREGID; as a last chance we try HAS_SETRESGID. May be OK
4175  * in the sense that we only want to set EGID; but are there any machines
4176  * with either of the latter, but not the former? Same with UID, later.
4177  */
4178 #  ifdef HAS_SETEGID
4179             (void)setegid(PL_statbuf.st_gid);
4180 #  else
4181 #    ifdef HAS_SETREGID
4182            (void)setregid((Gid_t)-1,PL_statbuf.st_gid);
4183 #    else
4184 #      ifdef HAS_SETRESGID
4185            (void)setresgid((Gid_t)-1,PL_statbuf.st_gid,(Gid_t)-1);
4186 #      else
4187             PerlProc_setgid(PL_statbuf.st_gid);
4188 #      endif
4189 #    endif
4190 #  endif
4191             if (PerlProc_getegid() != PL_statbuf.st_gid)
4192                 Perl_croak(aTHX_ "Can't do setegid!\n");
4193         }
4194         if (PL_statbuf.st_mode & S_ISUID) {
4195             if (PL_statbuf.st_uid != PL_euid)
4196 #  ifdef HAS_SETEUID
4197                 (void)seteuid(PL_statbuf.st_uid);       /* all that for this */
4198 #  else
4199 #    ifdef HAS_SETREUID
4200                 (void)setreuid((Uid_t)-1,PL_statbuf.st_uid);
4201 #    else
4202 #      ifdef HAS_SETRESUID
4203                 (void)setresuid((Uid_t)-1,PL_statbuf.st_uid,(Uid_t)-1);
4204 #      else
4205                 PerlProc_setuid(PL_statbuf.st_uid);
4206 #      endif
4207 #    endif
4208 #  endif
4209             if (PerlProc_geteuid() != PL_statbuf.st_uid)
4210                 Perl_croak(aTHX_ "Can't do seteuid!\n");
4211         }
4212         else if (PL_uid) {                      /* oops, mustn't run as root */
4213 #  ifdef HAS_SETEUID
4214           (void)seteuid((Uid_t)PL_uid);
4215 #  else
4216 #    ifdef HAS_SETREUID
4217           (void)setreuid((Uid_t)-1,(Uid_t)PL_uid);
4218 #    else
4219 #      ifdef HAS_SETRESUID
4220           (void)setresuid((Uid_t)-1,(Uid_t)PL_uid,(Uid_t)-1);
4221 #      else
4222           PerlProc_setuid((Uid_t)PL_uid);
4223 #      endif
4224 #    endif
4225 #  endif
4226             if (PerlProc_geteuid() != PL_uid)
4227                 Perl_croak(aTHX_ "Can't do seteuid!\n");
4228         }
4229         init_ids();
4230         if (!cando(S_IXUSR,TRUE,&PL_statbuf))
4231             Perl_croak(aTHX_ "Effective UID cannot exec script\n");     /* they can't do this */
4232     }
4233 #  ifdef IAMSUID
4234     else if (PL_preprocess)     /* PSz 13 Nov 03  Caught elsewhere, useless(?!) here */
4235         Perl_croak(aTHX_ "-P not allowed for setuid/setgid script\n");
4236     else if (fdscript < 0 || suidscript != 1)
4237         /* PSz 13 Nov 03  Caught elsewhere, useless(?!) here */
4238         Perl_croak(aTHX_ "(suid) fdscript needed in suidperl\n");
4239     else {
4240 /* PSz 16 Sep 03  Keep neat error message */
4241         Perl_croak(aTHX_ "Script is not setuid/setgid in suidperl\n");
4242     }
4243
4244     /* We absolutely must clear out any saved ids here, so we */
4245     /* exec the real perl, substituting fd script for scriptname. */
4246     /* (We pass script name as "subdir" of fd, which perl will grok.) */
4247     /*
4248      * It might be thought that using setresgid and/or setresuid (changed to
4249      * set the saved IDs) above might obviate the need to exec, and we could
4250      * go on to "do the perl thing".
4251      *
4252      * Is there such a thing as "saved GID", and is that set for setuid (but
4253      * not setgid) execution like suidperl? Without exec, it would not be
4254      * cleared for setuid (but not setgid) scripts (or might need a dummy
4255      * setresgid).
4256      *
4257      * We need suidperl to do the exact same argument checking that perl
4258      * does. Thus it cannot be very small; while it could be significantly
4259      * smaller, it is safer (simpler?) to make it essentially the same
4260      * binary as perl (but they are not identical). - Maybe could defer that
4261      * check to the invoked perl, and suidperl be a tiny wrapper instead;
4262      * but prefer to do thorough checks in suidperl itself. Such deferral
4263      * would make suidperl security rely on perl, a design no-no.
4264      *
4265      * Setuid things should be short and simple, thus easy to understand and
4266      * verify. They should do their "own thing", without influence by
4267      * attackers. It may help if their internal execution flow is fixed,
4268      * regardless of platform: it may be best to exec anyway.
4269      *
4270      * Suidperl should at least be conceptually simple: a wrapper only,
4271      * never to do any real perl. Maybe we should put
4272      * #ifdef IAMSUID
4273      *         Perl_croak(aTHX_ "Suidperl should never do real perl\n");
4274      * #endif
4275      * into the perly bits.
4276      */
4277     PerlIO_rewind(rsfp);
4278     PerlLIO_lseek(PerlIO_fileno(rsfp),(Off_t)0,0);  /* just in case rewind didn't */
4279     /* PSz 11 Nov 03
4280      * Keep original arguments: suidperl already has fd script.
4281      */
4282 /*  for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ;  */
4283 /*  if (!PL_origargv[which]) {                                          */
4284 /*      errno = EPERM;                                                  */
4285 /*      Perl_croak(aTHX_ "Permission denied\n");                        */
4286 /*  }                                                                   */
4287 /*  PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s",        */
4288 /*                                PerlIO_fileno(rsfp), PL_origargv[which]));    */
4289 #  if defined(HAS_FCNTL) && defined(F_SETFD)
4290     fcntl(PerlIO_fileno(rsfp),F_SETFD,0);       /* ensure no close-on-exec */
4291 #  endif
4292     PERL_FPU_PRE_EXEC
4293     PerlProc_execv(Perl_form(aTHX_ "%s/perl"PERL_FS_VER_FMT, BIN_EXP,
4294                              (int)PERL_REVISION, (int)PERL_VERSION,
4295                              (int)PERL_SUBVERSION), PL_origargv);/* try again */
4296     PERL_FPU_POST_EXEC
4297     Perl_croak(aTHX_ "Can't do setuid (suidperl cannot exec perl)\n");
4298 #  endif /* IAMSUID */
4299 #else /* !DOSUID */
4300     PERL_UNUSED_ARG(fdscript);
4301     PERL_UNUSED_ARG(suidscript);
4302     if (PL_euid != PL_uid || PL_egid != PL_gid) {       /* (suidperl doesn't exist, in fact) */
4303 #  ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
4304     PERL_UNUSED_ARG(rsfp);
4305 #  else
4306         PerlLIO_fstat(PerlIO_fileno(rsfp),&PL_statbuf); /* may be either wrapped or real suid */
4307         if ((PL_euid != PL_uid && PL_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
4308             ||
4309             (PL_egid != PL_gid && PL_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
4310            )
4311             if (!PL_do_undump)
4312                 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
4313 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
4314 #  endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
4315         /* not set-id, must be wrapped */
4316     }
4317 #endif /* DOSUID */
4318     PERL_UNUSED_ARG(validarg);
4319     PERL_UNUSED_ARG(scriptname);
4320     PERL_UNUSED_ARG(linestr_sv);
4321 }
4322
4323 STATIC void
4324 S_find_beginning(pTHX_ SV* linestr_sv, PerlIO *rsfp)
4325 {
4326     dVAR;
4327     register char *s;
4328     register const char *s2;
4329 #ifdef MACOS_TRADITIONAL
4330     int maclines = 0;
4331 #endif
4332
4333     /* skip forward in input to the real script? */
4334
4335 #ifdef MACOS_TRADITIONAL
4336     /* Since the Mac OS does not honor #! arguments for us, we do it ourselves */
4337
4338     while (PL_doextract || gMacPerl_AlwaysExtract) {
4339         if ((s = sv_gets(linestr_sv, rsfp, 0)) == NULL) {
4340             if (!gMacPerl_AlwaysExtract)
4341                 Perl_croak(aTHX_ "No Perl script found in input\n");
4342
4343             if (PL_doextract)                   /* require explicit override ? */
4344                 if (!OverrideExtract(PL_origfilename))
4345                     Perl_croak(aTHX_ "User aborted script\n");
4346                 else
4347                     PL_doextract = FALSE;
4348
4349             /* Pater peccavi, file does not have #! */
4350             PerlIO_rewind(rsfp);
4351
4352             break;
4353         }
4354 #else
4355     while (PL_doextract) {
4356         if ((s = sv_gets(linestr_sv, rsfp, 0)) == NULL)
4357             Perl_croak(aTHX_ "No Perl script found in input\n");
4358 #endif
4359         s2 = s;
4360         if (*s == '#' && s[1] == '!' && ((s = instr(s,"perl")) || (s = instr(s2,"PERL")))) {
4361             PerlIO_ungetc(rsfp, '\n');          /* to keep line count right */
4362             PL_doextract = FALSE;
4363             while (*s && !(isSPACE (*s) || *s == '#')) s++;
4364             s2 = s;
4365             while (*s == ' ' || *s == '\t') s++;
4366             if (*s++ == '-') {
4367                 while (isDIGIT(s2[-1]) || s2[-1] == '-' || s2[-1] == '.'
4368                        || s2[-1] == '_') s2--;
4369                 if (strnEQ(s2-4,"perl",4))
4370                     while ((s = moreswitches(s)))
4371                         ;
4372             }
4373 #ifdef MACOS_TRADITIONAL
4374             /* We are always searching for the #!perl line in MacPerl,
4375              * so if we find it, still keep the line count correct
4376              * by counting lines we already skipped over
4377              */
4378             for (; maclines > 0 ; maclines--)
4379                 PerlIO_ungetc(rsfp, '\n');
4380
4381             break;
4382
4383         /* gMacPerl_AlwaysExtract is false in MPW tool */
4384         } else if (gMacPerl_AlwaysExtract) {
4385             ++maclines;
4386 #endif
4387         }
4388     }
4389 }
4390
4391
4392 STATIC void
4393 S_init_ids(pTHX)
4394 {
4395     dVAR;
4396     PL_uid = PerlProc_getuid();
4397     PL_euid = PerlProc_geteuid();
4398     PL_gid = PerlProc_getgid();
4399     PL_egid = PerlProc_getegid();
4400 #ifdef VMS
4401     PL_uid |= PL_gid << 16;
4402     PL_euid |= PL_egid << 16;
4403 #endif
4404     /* Should not happen: */
4405     CHECK_MALLOC_TAINT(PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
4406     PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
4407     /* BUG */
4408     /* PSz 27 Feb 04
4409      * Should go by suidscript, not uid!=euid: why disallow
4410      * system("ls") in scripts run from setuid things?
4411      * Or, is this run before we check arguments and set suidscript?
4412      * What about SETUID_SCRIPTS_ARE_SECURE_NOW: could we use fdscript then?
4413      * (We never have suidscript, can we be sure to have fdscript?)
4414      * Or must then go by UID checks? See comments in forbid_setid also.
4415      */
4416 }
4417
4418 /* This is used very early in the lifetime of the program,
4419  * before even the options are parsed, so PL_tainting has
4420  * not been initialized properly.  */
4421 bool
4422 Perl_doing_taint(int argc, char *argv[], char *envp[])
4423 {
4424 #ifndef PERL_IMPLICIT_SYS
4425     /* If we have PERL_IMPLICIT_SYS we can't call getuid() et alia
4426      * before we have an interpreter-- and the whole point of this
4427      * function is to be called at such an early stage.  If you are on
4428      * a system with PERL_IMPLICIT_SYS but you do have a concept of
4429      * "tainted because running with altered effective ids', you'll
4430      * have to add your own checks somewhere in here.  The two most
4431      * known samples of 'implicitness' are Win32 and NetWare, neither
4432      * of which has much of concept of 'uids'. */
4433     int uid  = PerlProc_getuid();
4434     int euid = PerlProc_geteuid();
4435     int gid  = PerlProc_getgid();
4436     int egid = PerlProc_getegid();
4437     (void)envp;
4438
4439 #ifdef VMS
4440     uid  |=  gid << 16;
4441     euid |= egid << 16;
4442 #endif
4443     if (uid && (euid != uid || egid != gid))
4444         return 1;
4445 #endif /* !PERL_IMPLICIT_SYS */
4446     /* This is a really primitive check; environment gets ignored only
4447      * if -T are the first chars together; otherwise one gets
4448      *  "Too late" message. */
4449     if ( argc > 1 && argv[1][0] == '-'
4450          && (argv[1][1] == 't' || argv[1][1] == 'T') )
4451         return 1;
4452     return 0;
4453 }
4454
4455 /* Passing the flag as a single char rather than a string is a slight space
4456    optimisation.  The only message that isn't /^-.$/ is
4457    "program input from stdin", which is substituted in place of '\0', which
4458    could never be a command line flag.  */
4459 STATIC void
4460 S_forbid_setid(pTHX_ const char flag, const int suidscript)
4461 {
4462     dVAR;
4463     char string[3] = "-x";
4464     const char *message = "program input from stdin";
4465
4466     if (flag) {
4467         string[1] = flag;
4468         message = string;
4469     }
4470
4471 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
4472     if (PL_euid != PL_uid)
4473         Perl_croak(aTHX_ "No %s allowed while running setuid", message);
4474     if (PL_egid != PL_gid)
4475         Perl_croak(aTHX_ "No %s allowed while running setgid", message);
4476 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
4477     /* PSz 29 Feb 04
4478      * Checks for UID/GID above "wrong": why disallow
4479      *   perl -e 'print "Hello\n"'
4480      * from within setuid things?? Simply drop them: replaced by
4481      * fdscript/suidscript and #ifdef IAMSUID checks below.
4482      *
4483      * This may be too late for command-line switches. Will catch those on
4484      * the #! line, after finding the script name and setting up
4485      * fdscript/suidscript. Note that suidperl does not get around to
4486      * parsing (and checking) the switches on the #! line, but checks that
4487      * the two sets are identical.
4488      *
4489      * With SETUID_SCRIPTS_ARE_SECURE_NOW, could we use fdscript, also or
4490      * instead, or would that be "too late"? (We never have suidscript, can
4491      * we be sure to have fdscript?)
4492      *
4493      * Catch things with suidscript (in descendant of suidperl), even with
4494      * right UID/GID. Was already checked in suidperl, with #ifdef IAMSUID,
4495      * below; but I am paranoid.
4496      *
4497      * Also see comments about root running a setuid script, elsewhere.
4498      */
4499     if (suidscript >= 0)
4500         Perl_croak(aTHX_ "No %s allowed with (suid) fdscript", message);
4501 #ifdef IAMSUID
4502     /* PSz 11 Nov 03  Catch it in suidperl, always! */
4503     Perl_croak(aTHX_ "No %s allowed in suidperl", message);
4504 #endif /* IAMSUID */
4505 }
4506
4507 void
4508 Perl_init_debugger(pTHX)
4509 {
4510     dVAR;
4511     HV * const ostash = PL_curstash;
4512
4513     PL_curstash = PL_debstash;
4514     PL_dbargs = GvAV(gv_AVadd((gv_fetchpvs("DB::args", GV_ADDMULTI,
4515                                            SVt_PVAV))));
4516     AvREAL_off(PL_dbargs);
4517     PL_DBgv = gv_fetchpvs("DB::DB", GV_ADDMULTI, SVt_PVGV);
4518     PL_DBline = gv_fetchpvs("DB::dbline", GV_ADDMULTI, SVt_PVAV);
4519     PL_DBsub = gv_HVadd(gv_fetchpvs("DB::sub", GV_ADDMULTI, SVt_PVHV));
4520     PL_DBsingle = GvSV((gv_fetchpvs("DB::single", GV_ADDMULTI, SVt_PV)));
4521     sv_setiv(PL_DBsingle, 0);
4522     PL_DBtrace = GvSV((gv_fetchpvs("DB::trace", GV_ADDMULTI, SVt_PV)));
4523     sv_setiv(PL_DBtrace, 0);
4524     PL_DBsignal = GvSV((gv_fetchpvs("DB::signal", GV_ADDMULTI, SVt_PV)));
4525     sv_setiv(PL_DBsignal, 0);
4526     PL_curstash = ostash;
4527 }
4528
4529 #ifndef STRESS_REALLOC
4530 #define REASONABLE(size) (size)
4531 #else
4532 #define REASONABLE(size) (1) /* unreasonable */
4533 #endif
4534
4535 void
4536 Perl_init_stacks(pTHX)
4537 {
4538     dVAR;
4539     /* start with 128-item stack and 8K cxstack */
4540     PL_curstackinfo = new_stackinfo(REASONABLE(128),
4541                                  REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
4542     PL_curstackinfo->si_type = PERLSI_MAIN;
4543     PL_curstack = PL_curstackinfo->si_stack;
4544     PL_mainstack = PL_curstack;         /* remember in case we switch stacks */
4545
4546     PL_stack_base = AvARRAY(PL_curstack);
4547     PL_stack_sp = PL_stack_base;
4548     PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
4549
4550     Newx(PL_tmps_stack,REASONABLE(128),SV*);
4551     PL_tmps_floor = -1;
4552     PL_tmps_ix = -1;
4553     PL_tmps_max = REASONABLE(128);
4554
4555     Newx(PL_markstack,REASONABLE(32),I32);
4556     PL_markstack_ptr = PL_markstack;
4557     PL_markstack_max = PL_markstack + REASONABLE(32);
4558
4559     SET_MARK_OFFSET;
4560
4561     Newx(PL_scopestack,REASONABLE(32),I32);
4562     PL_scopestack_ix = 0;
4563     PL_scopestack_max = REASONABLE(32);
4564
4565     Newx(PL_savestack,REASONABLE(128),ANY);
4566     PL_savestack_ix = 0;
4567     PL_savestack_max = REASONABLE(128);
4568 }
4569
4570 #undef REASONABLE
4571
4572 STATIC void
4573 S_nuke_stacks(pTHX)
4574 {
4575     dVAR;
4576     while (PL_curstackinfo->si_next)
4577         PL_curstackinfo = PL_curstackinfo->si_next;
4578     while (PL_curstackinfo) {
4579         PERL_SI *p = PL_curstackinfo->si_prev;
4580         /* curstackinfo->si_stack got nuked by sv_free_arenas() */
4581         Safefree(PL_curstackinfo->si_cxstack);
4582         Safefree(PL_curstackinfo);
4583         PL_curstackinfo = p;
4584     }
4585     Safefree(PL_tmps_stack);
4586     Safefree(PL_markstack);
4587     Safefree(PL_scopestack);
4588     Safefree(PL_savestack);
4589 }
4590
4591
4592 STATIC void
4593 S_init_predump_symbols(pTHX)
4594 {
4595     dVAR;
4596     GV *tmpgv;
4597     IO *io;
4598
4599     sv_setpvn(get_sv("\"", TRUE), " ", 1);
4600     PL_stdingv = gv_fetchpvs("STDIN", GV_ADD|GV_NOTQUAL, SVt_PVIO);
4601     GvMULTI_on(PL_stdingv);
4602     io = GvIOp(PL_stdingv);
4603     IoTYPE(io) = IoTYPE_RDONLY;
4604     IoIFP(io) = PerlIO_stdin();
4605     tmpgv = gv_fetchpvs("stdin", GV_ADD|GV_NOTQUAL, SVt_PV);
4606     GvMULTI_on(tmpgv);
4607     GvIOp(tmpgv) = (IO*)SvREFCNT_inc_simple(io);
4608
4609     tmpgv = gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVIO);
4610     GvMULTI_on(tmpgv);
4611     io = GvIOp(tmpgv);
4612     IoTYPE(io) = IoTYPE_WRONLY;
4613     IoOFP(io) = IoIFP(io) = PerlIO_stdout();
4614     setdefout(tmpgv);
4615     tmpgv = gv_fetchpvs("stdout", GV_ADD|GV_NOTQUAL, SVt_PV);
4616     GvMULTI_on(tmpgv);
4617     GvIOp(tmpgv) = (IO*)SvREFCNT_inc_simple(io);
4618
4619     PL_stderrgv = gv_fetchpvs("STDERR", GV_ADD|GV_NOTQUAL, SVt_PVIO);
4620     GvMULTI_on(PL_stderrgv);
4621     io = GvIOp(PL_stderrgv);
4622     IoTYPE(io) = IoTYPE_WRONLY;
4623     IoOFP(io) = IoIFP(io) = PerlIO_stderr();
4624     tmpgv = gv_fetchpvs("stderr", GV_ADD|GV_NOTQUAL, SVt_PV);
4625     GvMULTI_on(tmpgv);
4626     GvIOp(tmpgv) = (IO*)SvREFCNT_inc_simple(io);
4627
4628     PL_statname = newSV(0);             /* last filename we did stat on */
4629
4630     Safefree(PL_osname);
4631     PL_osname = savepv(OSNAME);
4632 }
4633
4634 void
4635 Perl_init_argv_symbols(pTHX_ register int argc, register char **argv)
4636 {
4637     dVAR;
4638     argc--,argv++;      /* skip name of script */
4639     if (PL_doswitches) {
4640         for (; argc > 0 && **argv == '-'; argc--,argv++) {
4641             char *s;
4642             if (!argv[0][1])
4643                 break;
4644             if (argv[0][1] == '-' && !argv[0][2]) {
4645                 argc--,argv++;
4646                 break;
4647             }
4648             if ((s = strchr(argv[0], '='))) {
4649                 const char *const start_name = argv[0] + 1;
4650                 sv_setpv(GvSV(gv_fetchpvn_flags(start_name, s - start_name,
4651                                                 TRUE, SVt_PV)), s + 1);
4652             }
4653             else
4654                 sv_setiv(GvSV(gv_fetchpv(argv[0]+1, GV_ADD, SVt_PV)),1);
4655         }
4656     }
4657     if ((PL_argvgv = gv_fetchpvs("ARGV", GV_ADD|GV_NOTQUAL, SVt_PVAV))) {
4658         GvMULTI_on(PL_argvgv);
4659         (void)gv_AVadd(PL_argvgv);
4660         av_clear(GvAVn(PL_argvgv));
4661         for (; argc > 0; argc--,argv++) {
4662             SV * const sv = newSVpv(argv[0],0);
4663             av_push(GvAVn(PL_argvgv),sv);
4664             if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) {
4665                  if (PL_unicode & PERL_UNICODE_ARGV_FLAG)
4666                       SvUTF8_on(sv);
4667             }
4668             if (PL_unicode & PERL_UNICODE_WIDESYSCALLS_FLAG) /* Sarathy? */
4669                  (void)sv_utf8_decode(sv);
4670         }
4671     }
4672 }
4673
4674 STATIC void
4675 S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env)
4676 {
4677     dVAR;
4678     GV* tmpgv;
4679
4680     PL_toptarget = newSV_type(SVt_PVFM);
4681     sv_setpvn(PL_toptarget, "", 0);
4682     PL_bodytarget = newSV_type(SVt_PVFM);
4683     sv_setpvn(PL_bodytarget, "", 0);
4684     PL_formtarget = PL_bodytarget;
4685
4686     TAINT;
4687
4688     init_argv_symbols(argc,argv);
4689
4690     if ((tmpgv = gv_fetchpvs("0", GV_ADD|GV_NOTQUAL, SVt_PV))) {
4691 #ifdef MACOS_TRADITIONAL
4692         /* $0 is not majick on a Mac */
4693         sv_setpv(GvSV(tmpgv),MacPerl_MPWFileName(PL_origfilename));
4694 #else
4695         sv_setpv(GvSV(tmpgv),PL_origfilename);
4696         magicname("0", "0", 1);
4697 #endif
4698     }
4699     if ((PL_envgv = gv_fetchpvs("ENV", GV_ADD|GV_NOTQUAL, SVt_PVHV))) {
4700         HV *hv;
4701         bool env_is_not_environ;
4702         GvMULTI_on(PL_envgv);
4703         hv = GvHVn(PL_envgv);
4704         hv_magic(hv, NULL, PERL_MAGIC_env);
4705 #ifndef PERL_MICRO
4706 #ifdef USE_ENVIRON_ARRAY
4707         /* Note that if the supplied env parameter is actually a copy
4708            of the global environ then it may now point to free'd memory
4709            if the environment has been modified since. To avoid this
4710            problem we treat env==NULL as meaning 'use the default'
4711         */
4712         if (!env)
4713             env = environ;
4714         env_is_not_environ = env != environ;
4715         if (env_is_not_environ
4716 #  ifdef USE_ITHREADS
4717             && PL_curinterp == aTHX
4718 #  endif
4719            )
4720         {
4721             environ[0] = NULL;
4722         }
4723         if (env) {
4724           char *s;
4725           SV *sv;
4726           for (; *env; env++) {
4727             if (!(s = strchr(*env,'=')) || s == *env)
4728                 continue;
4729 #if defined(MSDOS) && !defined(DJGPP)
4730             *s = '\0';
4731             (void)strupr(*env);
4732             *s = '=';
4733 #endif
4734             sv = newSVpv(s+1, 0);
4735             (void)hv_store(hv, *env, s - *env, sv, 0);
4736             if (env_is_not_environ)
4737                 mg_set(sv);
4738           }
4739       }
4740 #endif /* USE_ENVIRON_ARRAY */
4741 #endif /* !PERL_MICRO */
4742     }
4743     TAINT_NOT;
4744     if ((tmpgv = gv_fetchpvs("$", GV_ADD|GV_NOTQUAL, SVt_PV))) {
4745         SvREADONLY_off(GvSV(tmpgv));
4746         sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
4747         SvREADONLY_on(GvSV(tmpgv));
4748     }
4749 #ifdef THREADS_HAVE_PIDS
4750     PL_ppid = (IV)getppid();
4751 #endif
4752
4753     /* touch @F array to prevent spurious warnings 20020415 MJD */
4754     if (PL_minus_a) {
4755       (void) get_av("main::F", TRUE | GV_ADDMULTI);
4756     }
4757 }
4758
4759 STATIC void
4760 S_init_perllib(pTHX)
4761 {
4762     dVAR;
4763     char *s;
4764     if (!PL_tainting) {
4765 #ifndef VMS
4766         s = PerlEnv_getenv("PERL5LIB");
4767 /*
4768  * It isn't possible to delete an environment variable with
4769  * PERL_USE_SAFE_PUTENV set unless unsetenv() is also available, so in that
4770  * case we treat PERL5LIB as undefined if it has a zero-length value.
4771  */
4772 #if defined(PERL_USE_SAFE_PUTENV) && ! defined(HAS_UNSETENV)
4773         if (s && *s != '\0')
4774 #else
4775         if (s)
4776 #endif
4777             incpush(s, TRUE, TRUE, TRUE, FALSE);
4778         else
4779             incpush(PerlEnv_getenv("PERLLIB"), FALSE, FALSE, TRUE, FALSE);
4780 #else /* VMS */
4781         /* Treat PERL5?LIB as a possible search list logical name -- the
4782          * "natural" VMS idiom for a Unix path string.  We allow each
4783          * element to be a set of |-separated directories for compatibility.
4784          */
4785         char buf[256];
4786         int idx = 0;
4787         if (my_trnlnm("PERL5LIB",buf,0))
4788             do { incpush(buf,TRUE,TRUE,TRUE,FALSE); } while (my_trnlnm("PERL5LIB",buf,++idx));
4789         else
4790             while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE,FALSE,TRUE,FALSE);
4791 #endif /* VMS */
4792     }
4793
4794 /* Use the ~-expanded versions of APPLLIB (undocumented),
4795     ARCHLIB PRIVLIB SITEARCH SITELIB VENDORARCH and VENDORLIB
4796 */
4797 #ifdef APPLLIB_EXP
4798     incpush(APPLLIB_EXP, TRUE, TRUE, TRUE, TRUE);
4799 #endif
4800
4801 #ifdef ARCHLIB_EXP
4802     incpush(ARCHLIB_EXP, FALSE, FALSE, TRUE, TRUE);
4803 #endif
4804 #ifdef MACOS_TRADITIONAL
4805     {
4806         Stat_t tmpstatbuf;
4807         SV * privdir = newSV(0);
4808         char * macperl = PerlEnv_getenv("MACPERL");
4809
4810         if (!macperl)
4811             macperl = "";
4812
4813         Perl_sv_setpvf(aTHX_ privdir, "%slib:", macperl);
4814         if (PerlLIO_stat(SvPVX(privdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode))
4815             incpush(SvPVX(privdir), TRUE, FALSE, TRUE, FALSE);
4816         Perl_sv_setpvf(aTHX_ privdir, "%ssite_perl:", macperl);
4817         if (PerlLIO_stat(SvPVX(privdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode))
4818             incpush(SvPVX(privdir), TRUE, FALSE, TRUE, FALSE);
4819
4820         SvREFCNT_dec(privdir);
4821     }
4822     if (!PL_tainting)
4823         incpush(":", FALSE, FALSE, TRUE, FALSE);
4824 #else
4825 #ifndef PRIVLIB_EXP
4826 #  define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
4827 #endif
4828 #if defined(WIN32)
4829     incpush(PRIVLIB_EXP, TRUE, FALSE, TRUE, TRUE);
4830 #else
4831     incpush(PRIVLIB_EXP, FALSE, FALSE, TRUE, TRUE);
4832 #endif
4833
4834 #ifdef SITEARCH_EXP
4835     /* sitearch is always relative to sitelib on Windows for
4836      * DLL-based path intuition to work correctly */
4837 #  if !defined(WIN32)
4838     incpush(SITEARCH_EXP, FALSE, FALSE, TRUE, TRUE);
4839 #  endif
4840 #endif
4841
4842 #ifdef SITELIB_EXP
4843 #  if defined(WIN32)
4844     /* this picks up sitearch as well */
4845     incpush(SITELIB_EXP, TRUE, FALSE, TRUE, TRUE);
4846 #  else
4847     incpush(SITELIB_EXP, FALSE, FALSE, TRUE, TRUE);
4848 #  endif
4849 #endif
4850
4851 #if defined(SITELIB_STEM) && defined(PERL_INC_VERSION_LIST)
4852     /* Search for version-specific dirs below here */
4853     incpush(SITELIB_STEM, FALSE, TRUE, TRUE, TRUE);
4854 #endif
4855
4856 #ifdef PERL_VENDORARCH_EXP
4857     /* vendorarch is always relative to vendorlib on Windows for
4858      * DLL-based path intuition to work correctly */
4859 #  if !defined(WIN32)
4860     incpush(PERL_VENDORARCH_EXP, FALSE, FALSE, TRUE, TRUE);
4861 #  endif
4862 #endif
4863
4864 #ifdef PERL_VENDORLIB_EXP
4865 #  if defined(WIN32)
4866     incpush(PERL_VENDORLIB_EXP, TRUE, FALSE, TRUE, TRUE);       /* this picks up vendorarch as well */
4867 #  else
4868     incpush(PERL_VENDORLIB_EXP, FALSE, FALSE, TRUE, TRUE);
4869 #  endif
4870 #endif
4871
4872 #ifdef PERL_VENDORLIB_STEM /* Search for version-specific dirs below here */
4873     incpush(PERL_VENDORLIB_STEM, FALSE, TRUE, TRUE, TRUE);
4874 #endif
4875
4876 #ifdef PERL_OTHERLIBDIRS
4877     incpush(PERL_OTHERLIBDIRS, TRUE, TRUE, TRUE, TRUE);
4878 #endif
4879
4880     if (!PL_tainting)
4881         incpush(".", FALSE, FALSE, TRUE, FALSE);
4882 #endif /* MACOS_TRADITIONAL */
4883 }
4884
4885 #if defined(DOSISH) || defined(EPOC) || defined(__SYMBIAN32__)
4886 #    define PERLLIB_SEP ';'
4887 #else
4888 #  if defined(VMS)
4889 #    define PERLLIB_SEP '|'
4890 #  else
4891 #    if defined(MACOS_TRADITIONAL)
4892 #      define PERLLIB_SEP ','
4893 #    else
4894 #      define PERLLIB_SEP ':'
4895 #    endif
4896 #  endif
4897 #endif
4898 #ifndef PERLLIB_MANGLE
4899 #  define PERLLIB_MANGLE(s,n) (s)
4900 #endif
4901
4902 /* Push a directory onto @INC if it exists.
4903    Generate a new SV if we do this, to save needing to copy the SV we push
4904    onto @INC  */
4905 STATIC SV *
4906 S_incpush_if_exists(pTHX_ SV *dir)
4907 {
4908     dVAR;
4909     Stat_t tmpstatbuf;
4910     if (PerlLIO_stat(SvPVX_const(dir), &tmpstatbuf) >= 0 &&
4911         S_ISDIR(tmpstatbuf.st_mode)) {
4912         av_push(GvAVn(PL_incgv), dir);
4913         dir = newSV(0);
4914     }
4915     return dir;
4916 }
4917
4918 STATIC void
4919 S_incpush(pTHX_ const char *dir, bool addsubdirs, bool addoldvers, bool usesep,
4920           bool canrelocate)
4921 {
4922     dVAR;
4923     SV *subdir = NULL;
4924     const char *p = dir;
4925
4926     if (!p || !*p)
4927         return;
4928
4929     if (addsubdirs || addoldvers) {
4930         subdir = newSV(0);
4931     }
4932
4933     /* Break at all separators */
4934     while (p && *p) {
4935         SV *libdir = newSV(0);
4936         const char *s;
4937
4938         /* skip any consecutive separators */
4939         if (usesep) {
4940             while ( *p == PERLLIB_SEP ) {
4941                 /* Uncomment the next line for PATH semantics */
4942                 /* av_push(GvAVn(PL_incgv), newSVpvs(".")); */
4943                 p++;
4944             }
4945         }
4946
4947         if ( usesep && (s = strchr(p, PERLLIB_SEP)) != NULL ) {
4948             sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
4949                       (STRLEN)(s - p));
4950             p = s + 1;
4951         }
4952         else {
4953             sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
4954             p = NULL;   /* break out */
4955         }
4956 #ifdef MACOS_TRADITIONAL
4957         if (!strchr(SvPVX(libdir), ':')) {
4958             char buf[256];
4959
4960             sv_setpv(libdir, MacPerl_CanonDir(SvPVX(libdir), buf, 0));
4961         }
4962         if (SvPVX(libdir)[SvCUR(libdir)-1] != ':')
4963             sv_catpvs(libdir, ":");
4964 #endif
4965
4966         /* Do the if() outside the #ifdef to avoid warnings about an unused
4967            parameter.  */
4968         if (canrelocate) {
4969 #ifdef PERL_RELOCATABLE_INC
4970         /*
4971          * Relocatable include entries are marked with a leading .../
4972          *
4973          * The algorithm is
4974          * 0: Remove that leading ".../"
4975          * 1: Remove trailing executable name (anything after the last '/')
4976          *    from the perl path to give a perl prefix
4977          * Then
4978          * While the @INC element starts "../" and the prefix ends with a real
4979          * directory (ie not . or ..) chop that real directory off the prefix
4980          * and the leading "../" from the @INC element. ie a logical "../"
4981          * cleanup
4982          * Finally concatenate the prefix and the remainder of the @INC element
4983          * The intent is that /usr/local/bin/perl and .../../lib/perl5
4984          * generates /usr/local/lib/perl5
4985          */
4986             const char *libpath = SvPVX(libdir);
4987             STRLEN libpath_len = SvCUR(libdir);
4988             if (libpath_len >= 4 && memEQ (libpath, ".../", 4)) {
4989                 /* Game on!  */
4990                 SV * const caret_X = get_sv("\030", 0);
4991                 /* Going to use the SV just as a scratch buffer holding a C
4992                    string:  */
4993                 SV *prefix_sv;
4994                 char *prefix;
4995                 char *lastslash;
4996
4997                 /* $^X is *the* source of taint if tainting is on, hence
4998                    SvPOK() won't be true.  */
4999                 assert(caret_X);
5000                 assert(SvPOKp(caret_X));
5001                 prefix_sv = newSVpvn(SvPVX(caret_X), SvCUR(caret_X));
5002                 /* Firstly take off the leading .../
5003                    If all else fail we'll do the paths relative to the current
5004                    directory.  */
5005                 sv_chop(libdir, libpath + 4);
5006                 /* Don't use SvPV as we're intentionally bypassing taining,
5007                    mortal copies that the mg_get of tainting creates, and
5008                    corruption that seems to come via the save stack.
5009                    I guess that the save stack isn't correctly set up yet.  */
5010                 libpath = SvPVX(libdir);
5011                 libpath_len = SvCUR(libdir);
5012
5013                 /* This would work more efficiently with memrchr, but as it's
5014                    only a GNU extension we'd need to probe for it and
5015                    implement our own. Not hard, but maybe not worth it?  */
5016
5017                 prefix = SvPVX(prefix_sv);
5018                 lastslash = strrchr(prefix, '/');
5019
5020                 /* First time in with the *lastslash = '\0' we just wipe off
5021                    the trailing /perl from (say) /usr/foo/bin/perl
5022                 */
5023                 if (lastslash) {
5024                     SV *tempsv;
5025                     while ((*lastslash = '\0'), /* Do that, come what may.  */
5026                            (libpath_len >= 3 && memEQ(libpath, "../", 3)
5027                             && (lastslash = strrchr(prefix, '/')))) {
5028                         if (lastslash[1] == '\0'
5029                             || (lastslash[1] == '.'
5030                                 && (lastslash[2] == '/' /* ends "/."  */
5031                                     || (lastslash[2] == '/'
5032                                         && lastslash[3] == '/' /* or "/.."  */
5033                                         )))) {
5034                             /* Prefix ends "/" or "/." or "/..", any of which
5035                                are fishy, so don't do any more logical cleanup.
5036                             */
5037                             break;
5038                         }
5039                         /* Remove leading "../" from path  */
5040                         libpath += 3;
5041                         libpath_len -= 3;
5042                         /* Next iteration round the loop removes the last
5043                            directory name from prefix by writing a '\0' in
5044                            the while clause.  */
5045                     }
5046                     /* prefix has been terminated with a '\0' to the correct
5047                        length. libpath points somewhere into the libdir SV.
5048                        We need to join the 2 with '/' and drop the result into
5049                        libdir.  */
5050                     tempsv = Perl_newSVpvf(aTHX_ "%s/%s", prefix, libpath);
5051                     SvREFCNT_dec(libdir);
5052                     /* And this is the new libdir.  */
5053                     libdir = tempsv;
5054                     if (PL_tainting &&
5055                         (PL_uid != PL_euid || PL_gid != PL_egid)) {
5056                         /* Need to taint reloccated paths if running set ID  */
5057                         SvTAINTED_on(libdir);
5058                     }
5059                 }
5060                 SvREFCNT_dec(prefix_sv);
5061             }
5062 #endif
5063         }
5064         /*
5065          * BEFORE pushing libdir onto @INC we may first push version- and
5066          * archname-specific sub-directories.
5067          */
5068         if (addsubdirs || addoldvers) {
5069 #ifdef PERL_INC_VERSION_LIST
5070             /* Configure terminates PERL_INC_VERSION_LIST with a NULL */
5071             const char * const incverlist[] = { PERL_INC_VERSION_LIST };
5072             const char * const *incver;
5073 #endif
5074 #ifdef VMS
5075             char *unix;
5076             STRLEN len;
5077
5078             if ((unix = tounixspec_ts(SvPV(libdir,len),NULL)) != NULL) {
5079                 len = strlen(unix);
5080                 while (unix[len-1] == '/') len--;  /* Cosmetic */
5081                 sv_usepvn(libdir,unix,len);
5082             }
5083             else
5084                 PerlIO_printf(Perl_error_log,
5085                               "Failed to unixify @INC element \"%s\"\n",
5086                               SvPV(libdir,len));
5087 #endif
5088             if (addsubdirs) {
5089 #ifdef MACOS_TRADITIONAL
5090 #define PERL_AV_SUFFIX_FMT      ""
5091 #define PERL_ARCH_FMT           "%s:"
5092 #define PERL_ARCH_FMT_PATH      PERL_FS_VER_FMT PERL_AV_SUFFIX_FMT
5093 #else
5094 #define PERL_AV_SUFFIX_FMT      "/"
5095 #define PERL_ARCH_FMT           "/%s"
5096 #define PERL_ARCH_FMT_PATH      PERL_AV_SUFFIX_FMT PERL_FS_VER_FMT
5097 #endif
5098                 /* .../version/archname if -d .../version/archname */
5099                 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT_PATH PERL_ARCH_FMT,
5100                                SVfARG(libdir),
5101                                (int)PERL_REVISION, (int)PERL_VERSION,
5102                                (int)PERL_SUBVERSION, ARCHNAME);
5103                 subdir = S_incpush_if_exists(aTHX_ subdir);
5104
5105                 /* .../version if -d .../version */
5106                 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT_PATH,
5107                                SVfARG(libdir),
5108                                (int)PERL_REVISION, (int)PERL_VERSION,
5109                                (int)PERL_SUBVERSION);
5110                 subdir = S_incpush_if_exists(aTHX_ subdir);
5111
5112                 /* .../archname if -d .../archname */
5113                 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT,
5114                                SVfARG(libdir), ARCHNAME);
5115                 subdir = S_incpush_if_exists(aTHX_ subdir);
5116
5117             }
5118
5119 #ifdef PERL_INC_VERSION_LIST
5120             if (addoldvers) {
5121                 for (incver = incverlist; *incver; incver++) {
5122                     /* .../xxx if -d .../xxx */
5123                     Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT,
5124                                    SVfARG(libdir), *incver);
5125                     subdir = S_incpush_if_exists(aTHX_ subdir);
5126                 }
5127             }
5128 #endif
5129         }
5130
5131         /* finally push this lib directory on the end of @INC */
5132         av_push(GvAVn(PL_incgv), libdir);
5133     }
5134     if (subdir) {
5135         assert (SvREFCNT(subdir) == 1);
5136         SvREFCNT_dec(subdir);
5137     }
5138 }
5139
5140
5141 void
5142 Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
5143 {
5144     dVAR;
5145     SV *atsv;
5146     volatile const line_t oldline = PL_curcop ? CopLINE(PL_curcop) : 0;
5147     CV *cv;
5148     STRLEN len;
5149     int ret;
5150     dJMPENV;
5151
5152     while (av_len(paramList) >= 0) {
5153         cv = (CV*)av_shift(paramList);
5154         if (PL_savebegin) {
5155             if (paramList == PL_beginav) {
5156                 /* save PL_beginav for compiler */
5157                 Perl_av_create_and_push(aTHX_ &PL_beginav_save, (SV*)cv);
5158             }
5159             else if (paramList == PL_checkav) {
5160                 /* save PL_checkav for compiler */
5161                 Perl_av_create_and_push(aTHX_ &PL_checkav_save, (SV*)cv);
5162             }
5163             else if (paramList == PL_unitcheckav) {
5164                 /* save PL_unitcheckav for compiler */
5165                 Perl_av_create_and_push(aTHX_ &PL_unitcheckav_save, (SV*)cv);
5166             }
5167         } else {
5168             if (!PL_madskills)
5169                 SAVEFREESV(cv);
5170         }
5171         JMPENV_PUSH(ret);
5172         switch (ret) {
5173         case 0:
5174 #ifdef PERL_MAD
5175             if (PL_madskills)
5176                 PL_madskills |= 16384;
5177 #endif
5178             CALL_LIST_BODY(cv);
5179 #ifdef PERL_MAD
5180             if (PL_madskills)
5181                 PL_madskills &= ~16384;
5182 #endif
5183             atsv = ERRSV;
5184             (void)SvPV_const(atsv, len);
5185             if (len) {
5186                 PL_curcop = &PL_compiling;
5187                 CopLINE_set(PL_curcop, oldline);
5188                 if (paramList == PL_beginav)
5189                     sv_catpvs(atsv, "BEGIN failed--compilation aborted");
5190                 else
5191                     Perl_sv_catpvf(aTHX_ atsv,
5192                                    "%s failed--call queue aborted",
5193                                    paramList == PL_checkav ? "CHECK"
5194                                    : paramList == PL_initav ? "INIT"
5195                                    : paramList == PL_unitcheckav ? "UNITCHECK"
5196                                    : "END");
5197                 while (PL_scopestack_ix > oldscope)
5198                     LEAVE;
5199                 JMPENV_POP;
5200                 Perl_croak(aTHX_ "%"SVf"", SVfARG(atsv));
5201             }
5202             break;
5203         case 1:
5204             STATUS_ALL_FAILURE;
5205             /* FALL THROUGH */
5206         case 2:
5207             /* my_exit() was called */
5208             while (PL_scopestack_ix > oldscope)
5209                 LEAVE;
5210             FREETMPS;
5211             PL_curstash = PL_defstash;
5212             PL_curcop = &PL_compiling;
5213             CopLINE_set(PL_curcop, oldline);
5214             JMPENV_POP;
5215             if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED)) {
5216                 if (paramList == PL_beginav)
5217                     Perl_croak(aTHX_ "BEGIN failed--compilation aborted");
5218                 else
5219                     Perl_croak(aTHX_ "%s failed--call queue aborted",
5220                                paramList == PL_checkav ? "CHECK"
5221                                : paramList == PL_initav ? "INIT"
5222                                : paramList == PL_unitcheckav ? "UNITCHECK"
5223                                : "END");
5224             }
5225             my_exit_jump();
5226             /* NOTREACHED */
5227         case 3:
5228             if (PL_restartop) {
5229                 PL_curcop = &PL_compiling;
5230                 CopLINE_set(PL_curcop, oldline);
5231                 JMPENV_JUMP(3);
5232             }
5233             PerlIO_printf(Perl_error_log, "panic: restartop\n");
5234             FREETMPS;
5235             break;
5236         }
5237         JMPENV_POP;
5238     }
5239 }
5240
5241 void
5242 Perl_my_exit(pTHX_ U32 status)
5243 {
5244     dVAR;
5245     DEBUG_S(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
5246                           (void*)thr, (unsigned long) status));
5247     switch (status) {
5248     case 0:
5249         STATUS_ALL_SUCCESS;
5250         break;
5251     case 1:
5252         STATUS_ALL_FAILURE;
5253         break;
5254     default:
5255         STATUS_EXIT_SET(status);
5256         break;
5257     }
5258     my_exit_jump();
5259 }
5260
5261 void
5262 Perl_my_failure_exit(pTHX)
5263 {
5264     dVAR;
5265 #ifdef VMS
5266      /* We have been called to fall on our sword.  The desired exit code
5267       * should be already set in STATUS_UNIX, but could be shifted over
5268       * by 8 bits.  STATUS_UNIX_EXIT_SET will handle the cases where a
5269       * that code is set.
5270       *
5271       * If an error code has not been set, then force the issue.
5272       */
5273     if (MY_POSIX_EXIT) {
5274
5275         /* In POSIX_EXIT mode follow Perl documentations and use 255 for
5276          * the exit code when there isn't an error.
5277          */
5278
5279         if (STATUS_UNIX == 0)
5280             STATUS_UNIX_EXIT_SET(255);
5281         else {
5282             STATUS_UNIX_EXIT_SET(STATUS_UNIX);
5283
5284             /* The exit code could have been set by $? or vmsish which
5285              * means that it may not be fatal.  So convert
5286              * success/warning codes to fatal.
5287              */
5288             if ((STATUS_NATIVE & (STS$K_SEVERE|STS$K_ERROR)) == 0)
5289                 STATUS_UNIX_EXIT_SET(255);
5290         }
5291     }
5292     else {
5293         /* Traditionally Perl on VMS always expects a Fatal Error. */
5294         if (vaxc$errno & 1) {
5295
5296             /* So force success status to failure */
5297             if (STATUS_NATIVE & 1)
5298                 STATUS_ALL_FAILURE;
5299         }
5300         else {
5301             if (!vaxc$errno) {
5302                 STATUS_UNIX = EINTR; /* In case something cares */
5303                 STATUS_ALL_FAILURE;
5304             }
5305             else {
5306                 int severity;
5307                 STATUS_NATIVE = vaxc$errno; /* Should already be this */
5308
5309                 /* Encode the severity code */
5310                 severity = STATUS_NATIVE & STS$M_SEVERITY;
5311                 STATUS_UNIX = (severity ? severity : 1) << 8;
5312
5313                 /* Perl expects this to be a fatal error */
5314                 if (severity != STS$K_SEVERE)
5315                     STATUS_ALL_FAILURE;
5316             }
5317         }
5318     }
5319
5320 #else
5321     int exitstatus;
5322     if (errno & 255)
5323         STATUS_UNIX_SET(errno);
5324     else {
5325         exitstatus = STATUS_UNIX >> 8;
5326         if (exitstatus & 255)
5327             STATUS_UNIX_SET(exitstatus);
5328         else
5329             STATUS_UNIX_SET(255);
5330     }
5331 #endif
5332     my_exit_jump();
5333 }
5334
5335 STATIC void
5336 S_my_exit_jump(pTHX)
5337 {
5338     dVAR;
5339
5340     if (PL_e_script) {
5341         SvREFCNT_dec(PL_e_script);
5342         PL_e_script = NULL;
5343     }
5344
5345     POPSTACK_TO(PL_mainstack);
5346     dounwind(-1);
5347     LEAVE_SCOPE(0);
5348
5349     JMPENV_JUMP(2);
5350 }
5351
5352 static I32
5353 read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen)
5354 {
5355     dVAR;
5356     const char * const p  = SvPVX_const(PL_e_script);
5357     const char *nl = strchr(p, '\n');
5358
5359     PERL_UNUSED_ARG(idx);
5360     PERL_UNUSED_ARG(maxlen);
5361
5362     nl = (nl) ? nl+1 : SvEND(PL_e_script);
5363     if (nl-p == 0) {
5364         filter_del(read_e_script);
5365         return 0;
5366     }
5367     sv_catpvn(buf_sv, p, nl-p);
5368     sv_chop(PL_e_script, nl);
5369     return 1;
5370 }
5371
5372 /*
5373  * Local variables:
5374  * c-indentation-style: bsd
5375  * c-basic-offset: 4
5376  * indent-tabs-mode: t
5377  * End:
5378  *
5379  * ex: set ts=8 sts=4 sw=4 noet:
5380  */