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