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