perl.c

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