perl.c

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