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